GLFW-b example

Main.hs

import Control.Applicative
import Control.Monad
import Graphics.Rendering.OpenGL.GL  -- from package "OpenGL"
import Graphics.UI.GLFW as GLFW      -- from package "GLFW-b"

windowWidth, windowHeight :: Int
(windowWidth, windowHeight) = (640, 480)

initialDots :: [Vector2 GLfloat]
initialDots = [ Vector2 0.5 0.5
              , Vector2 0.2 0.5
              , Vector2 (-0.4) 0
              , Vector2 (-0.3) (-0.5)
              ]


-- perform all operations pointwise
instance Num a => Num (Vector2 a)
  where
    (+) = liftA2 (+)
    (*) = liftA2 (*)
    (-) = liftA2 (-)
    negate = liftA negate
    abs    = liftA abs
    signum = liftA signum
    fromInteger = pure . fromInteger

-- perform all operations pointwise
instance Fractional a => Fractional (Vector2 a)
  where
    (/) = liftA2 (/)
    recip = liftA recip
    fromRational = pure . fromRational

-- convert from window coordinates to OpenGL coordinates
mousePos :: Double -> Double -> Vector2 GLfloat
mousePos x y = Vector2 (-1) 1 + frac * Vector2 2 (-2)
  where
    frac = Vector2 (realToFrac x / fromIntegral windowWidth)
                   (realToFrac y / fromIntegral windowHeight)


main :: IO ()
main = do
    True <- GLFW.init
    Just w <- createWindow windowWidth windowHeight "Gravity" Nothing Nothing
    makeContextCurrent (Just w)
    showWindow w
    
    -- main loop
    loop w initialDots
    
    destroyWindow w
    terminate

loop :: Window -> [Vector2 GLfloat] -> IO ()
loop w dots = do
    winClosed <- windowShouldClose w
    escPressed <- getKey w Key'Escape
    let shouldQuit = winClosed || escPressed == KeyState'Pressed
    
    unless shouldQuit $ do
      let dots' = updateDots dots
      renderDots w dots'
      waitEvents  -- only update when you move the mouse
                  -- (otherwise it stabilizes too fast)
      
      -- add a new dot on mouse-press
      -- (click and drag to add lots of new dots)
      mousePressed <- getMouseButton w MouseButton'1
      case mousePressed of
        MouseButtonState'Pressed -> do
            (winx, winy) <- getCursorPos w
            loop w (mousePos winx winy : dots')
        _ -> loop w dots'

updateDots :: [Vector2 GLfloat] -> [Vector2 GLfloat]
updateDots dots = map (elastic 0.3) dots
  where
    -- try to be exactly d units from every other dot
    elastic :: GLfloat -> Vector2 GLfloat -> Vector2 GLfloat
    elastic d dot = average
                  $ map (vectorRescale d)
                  $ map (dot -)
                  $ filter (/= dot) dots

average :: Fractional a => [a] -> a
average vs = sum vs / fromIntegral (length vs)

vectorRescale :: Floating a => a -> Vector2 a -> Vector2 a
vectorRescale d v = pure scaleFactor * v
  where
    scaleFactor = d / vectorNorm v

vectorNorm :: Floating a => Vector2 a -> a
vectorNorm (Vector2 x y) = sqrt (x*x + y*y)


renderDots :: Window -> [Vector2 GLfloat] -> IO ()
renderDots w xys = do
    clear [ColorBuffer]
    renderPrimitive Points $ do
      forM_ xys $ \(Vector2 x y) -> do
        vertex (Vertex3 x y 0)
    swapBuffers w