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 multithreading. Haskell is a language of easy and natural multithreading, 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:
