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 IORef
s 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 IORef
s.
(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
Thanks! This is great. I’ve been considering an approach like this for a small arcade game I’m making, so it’s good to see how other people implement it. Have you run into problems with only handling one event per frame?
I think the handleEvents function here is wrong, it’s a little different from the version in github.
I just did not expected a feedback so soon 🙂
Yeah, I’ve been playing with the code in the last hours and changed the `handleEvents` implementation to handle all messages.
Honestly, I don’t know how good this approach is. Possibly, some of advanced haskell libraries already uses a similar approach. Possibly, I’m heading astray and people will show me that this way is incorrect. And yes, I have had very little experience with Haskell multithreading yet.
Pingback: Моя первая попытка поиграться с OpenGL на Haskell | Записки программиста
I stumbled on your site looking for a way to handle key releases, as it seems like GLFW is buggy when I try to use them. The callbacks never get caled with Release as the keys state. This worked well with GLUT, but not with GLFW. Have you looked into this?
Hey the link to the source code is dead, could you fix this? Thanks
Thanks, fixed the link.
The code is rotten now, though (glfw-b seems changed).
P.S. Updated the source code too, now it should work with GLFW 1.4
Which GLFW version do I need
I get:
HelloGLFW.hs:12:13: error:
Not in scope: `GLFW.initialize’
Module `Graphics.UI.GLFW’ does not export `initialize’.