Haskell OpenGL animation done right: using closures and channels instead of IORef’s

There is a lot of Haskell OpenGL tutorials on the web introducing to basic OpenGL drawing in Haskell. I’ve read about a dozen of them, but none are highlighting an important issue right: how to react to user’s input? The tutorials either omit this topic, or fall back to ugly and non-idiomatic IORefs to return data from callbacks (even the Haskell wiki goes this way). Although there is a much nicer way to handle GLUT/GLFW callbacks which is explained below.

First of all, there’s a very simple fact to realize: interactivity means concurrency. Haskell is a language of easy and natural concurrency, thus it is silly not to use it when appropriate (the case of an interactive application is more than appropriate).

The second topic is the UI choice. Traditionally people use GLUT for introductions to OpenGL programming, but there are better alternatives like GLFW which is quite similar to GLUT, but being more actively developed. See the discussion.

So, we’ll start with GLFW Haskell bindings (I choose glfw-b over glfw package, it seems to be a matter of taste) and STM for message passing:

 $ cabal install OpenGL stm glfw-b

I assume you can use another excellent introduction to GLFW to get a barebones example running, so let’s start with a stub like this.

---

The idea

…is that we can keep the events in STM communication channels, created with newTChanIO :: TChan StateChange. This channel is passed to events callbacks as the first parameter: e.g. GLFW.setKeyCallback gets a partially applied function with full type TChan StateChange -> GLFW.KeyCallback (that is the same as TChan StateChange -> GLFW.Key -> Bool -> IO ()), thus the callback knows the channel to write into. The same channel is passed in the mainLoop, enabling it to read events from the channel.

Actually, we won’t use explicit forkIO because callbacks already are asynchronous. The tool we need is message passing: all information about user’s input will be stored in message passing channels: a callback writes information about some event to it, the main thread reads it and changes its world before rendering. Using STM, we’re guaranteed that there are no deadlocks and race conditions, though our case is very simple and it may be an overkill.

---

World description

What our world will be? I want to be able to walk around it and see a primitive feedback. So, let’s assume we have a horizontal platform of size about 20×20 meters, the camera view from altitude 1.8 meter above the platform looking in any direction (changing it with arrow keys) and moving forward/sideword along the look direction with w/s/d/a keys.

So, let’s outline the message protocol:

type Distance = GL.GLfloat
type Angle = GL.GLfloat
data StateChange
    = Move (Distance,Distance) -- move (forward,right) along the look direction
    | Look Angle   -- turn look direction by 'angle' up (down if negative)
    | Turn Angle   -- turn look direction by 'angle' right (left if negative)
    | Quit         -- the world must shut down
  deriving Show

The next thing is state of our view. Let’s encode it into a “world” structure:

data WorldState = WorldState {
  posX, posY :: Distance, -- horizontal position of the eye, height is always 1.8
  angRL, angUD :: Angle, -- two angles in spherical coordinates
  isDoomed :: Bool       -- is this world going to shut down
}

Let’s draw the world:

draw world = do
  (w, h) <- GLFW.getWindowDimensions

  GL.clear [GL.ColorBuffer, GL.DepthBuffer]

  GL.matrixMode $= GL.Projection
  let ratio = (int w / int h)
  GL.loadIdentity
  GL.frustum (-ratio) ratio (-1.0) 1.0 1.8 30

  GL.matrixMode $= GL.Modelview 0
  GL.loadIdentity
  let ang = angRL world
      eye = glVertex3d (flt $ posX world, flt $ posY world, 1.8)
      at = glVertex3d (flt $ posX world + cos ang,
                       flt $ posY world - sin ang,
                       flt $ 1.8 + sin (angUD world))
      up = glVector3d (0, 0, 1)
  GL.lookAt eye at up

  GL.renderPrimitive GL.Quads $ do
    let a = 20.0
    forM_ [(0,0), (a,0), (a,a), (0,a)] $ \(x, y) ->
      let vtx = glVertex3f (x,y,0)
          col = glColor4f (0,1,0,1)
      in GL.color col >> GL.vertex vtx

  printErrors
  GL.flush
  GLFW.swapBuffers

printErrors = GL.get GL.errors >>= mapM_ print

Also, let’s add some trigonometry to handle events:

moveView (fwd,aside) w =
    w { posX = dX + posX w, posY = dY + posY w }
  where dX = fwd * cos ang - aside * sin ang
        dY = (-fwd) * sin ang - aside * cos ang
        ang = angRL w

turnViewUD ang w = w { angUD = ang'' }
  where ang'' = if ang' > pi/2 then pi - ang'
                else if ang' < (-pi/2) then pi + ang'
                else ang'
        ang' = ang + angUD w

turnViewRL ang w = w { angRL = ang'' }
  where ang'' = if ang' > pi then 2 * pi - ang'
                else if ang' < (-pi) then 2 * pi + ang'
                else ang'
        ang' = ang + angRL w

---

Interaction with user

What the main thread of the program will do? We’ll draw exactly 60 frames per second, using GLFW.getTime to get how time we can sleep with threadDelay:

mainLoop :: WorldState -> TChan StateChange -> IO ()
mainLoop world chan = do
  -- here we are handling user events, adjusting the world:
  world' <- handleEvents chan world
  if isDoomed world'     -- is it going to shut down
  then return ()
  else do
    t0 <- GLFW.getTime
    draw world'
    dt <- (t0 + spf -) <$> GLFW.getTime
    when (dt > 0) $ threadDelay (toMicroseconds dt)
    mainLoop world' chan
  where fps = 60
        spf = recip fps

handleEvents reads events from the channel until it’s empty (it’s the only reader of the channel) and updates the world:

handleEvents chan world = do
  -- reading from the channel:
  emptyChan <- atomically $ isEmptyTChan
  if emptyChan then return world
  else do
    msg <- atomically $ readTChan chan
    print msg >> hFlush stdout
    handleEvents chan $ case msg of
      Move (fwd,side) -> moveView (fwd,side) world
      Look angUD ->      turnViewUD angUD world
      Turn angRL ->      turnViewRL angRL world
      Quit ->            world { isDoomed = True }

Code of the callbacks:

cbChar chan c action = do
  let step = 0.5
  let cacts = [ ('w', Move (step,0)), ('s', Move ((-step),0)) ]
  case lookup c cacts of
    Just act -> atomically $ writeTChan chan act
    _ -> return ()

cbKey chan key action = do
  let tangle = 0.02
  let kacts = [ (GLFW.KeyEsc,   Quit),
                (GLFW.KeyLeft,  Turn (-tangle)),
                (GLFW.KeyRight, Turn tangle),
                (GLFW.KeyDown,  Look (-tangle)),
                (GLFW.KeyUp,    Look tangle) ]
  case lookup key kacts of
    -- write an event to the channel:
    Just act -> atomically $ writeTChan chan act
    _ -> return ()

And finally let’s put that alltogether, the main function (initiliazing callbacks):

main = do
  True <- GLFW.initialize

  True <- GLFW.openWindow GLFW.defaultDisplayOptions {
    GLFW.displayOptions_numRedBits = 8,
    GLFW.displayOptions_numGreenBits = 8,
    GLFW.displayOptions_numBlueBits = 8,
    GLFW.displayOptions_numDepthBits = 8,
    GLFW.displayOptions_width = 640,
    GLFW.displayOptions_height = 480
  }

  GL.depthFunc $= Just GL.Less

  chan <- newTChanIO :: IO (TChan StateChange)

  GLFW.setKeyCallback (cbKey chan)
  GLFW.setCharCallback (cbChar chan)
 
  GLFW.enableKeyRepeat

  let initworld = WorldState { 
    posX = 0, posY = 0, 
    angRL = (-pi)/4, angUD = 0, 
    isDoomed = False 
  }                                                                                                    
  (mainLoop initworld chan) `finally` (GLFW.closeWindow >> GLFW.terminate)

Also I needed quite a bit of helper stuff, like toMicroseconds and glVertex3f, glVector3f, which is accessible by the link below.

This is a raw version of the code, it does not handle key releases and has a bit of rough corners, but it works without ugly hacks like emulation of global variables through IORefs.

(Disclaimer: I am very obliged to author of this article for great introduction into GLFW and for GLFW initialization code I used).

You can find the full source on GitHub.

---

Let’s see…

Let’s compile and run it:

$ ghc InteractGLFW.hs && ./InteractGLFW

Voila, look from the blue corner:

let’s walk to the yellow one: