merged .. but colors broken..

Pioneers.cabal

@@ -26,5 +26,8 @@ executable Pioneers
                    transformers >=0.3.0 && <0.4,
                    mtl >=2.1.2,
                    stm >=2.4.2,
-                   vector >=0.10.9 && <0.11
+                   vector >=0.10.9 && <0.11,
+                   distributive >=0.3.2 && <0.4,
+                   linear >=1.3.1 && <1.4,
+                   lens >=3.10.1 && <3.11
 

shaders/vertex.shader

@@ -2,19 +2,31 @@
 
 //constant projection matrix
 uniform mat4 fg_ProjectionMatrix;
+uniform mat4 fg_ViewMatrix;
+uniform mat3 fg_NormalMatrix;
 
 //vertex-data
 in vec4 fg_Color;
 in vec3 fg_VertexIn;
-in vec3 fg_Normal;
+in vec3 fg_NormalIn;
 
 //output-data for later stages
 out vec4 fg_SmoothColor;
 
 void main()
 {
+   vec3 fg_Normal = fg_NormalIn; //vec3(0,1,0);
    //transform vec3 into vec4, setting w to 1
-   vec4 fg_Vertex = vec4(fg_VertexIn.x, fg_VertexIn.y+0.1, fg_VertexIn.z, 1.0);
+   vec4 fg_Vertex = vec4(fg_VertexIn, 1.0);
-   fg_SmoothColor = fg_Color + 0.001* fg_Normal.xyzx;
+   vec4 light = vec4(1.0,1.0,1.0,1.0);
-   gl_Position = fg_ProjectionMatrix * fg_Vertex;
+   vec4 dark  = vec4(0.0,0.0,0.0,1.0);
+   //direction to sun from origin
+   vec3 lightDir = normalize(vec3(5.0,5.0,1.0));
+
+
+   float costheta = dot(normalize(fg_Normal), lightDir);
+   float a = costheta * 0.5 + 0.5;
+
+   fg_SmoothColor = fg_Color * mix(dark, light, a);// + 0.001* fg_Normal.xyzx;
+   gl_Position = fg_ProjectionMatrix * fg_ViewMatrix * fg_Vertex;
 }

src/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 module Main (main) where
 
 --------------------------------------------------------------------------------
@@ -9,15 +10,18 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
 import Data.List                 (intercalate)
 import Data.Maybe                (catMaybes)
 import Text.PrettyPrint
+import Data.Distributive (distribute)
+import Foreign (Ptr, castPtr, with)
+import Foreign.C (CFloat)
+import Linear as L
 
 import qualified Graphics.Rendering.OpenGL.GL           as GL
-import qualified Graphics.Rendering.OpenGL.Raw.Core31   as GLRaw
+import Graphics.Rendering.OpenGL.Raw.Core31
 import qualified Graphics.UI.GLFW                       as GLFW
-import qualified Data.Vector.Storable as V
 
 import Map.Map
-import Render.Render (initShader)
+import Render.Render (initShader, initRendering)
-import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError)
+import Render.Misc (up, createFrustum, checkError, lookAt)
 
 --------------------------------------------------------------------------------
 
@@ -43,13 +47,15 @@ data State = State
     , stateDragStartY      :: !Double
     , stateDragStartXAngle :: !Double
     , stateDragStartYAngle :: !Double
-    , stateFrustum         :: [GL.GLfloat]
+    , stateFrustum         :: !(M44 CFloat)
     -- pointer to bindings for locations inside the compiled shader
     -- mutable because shaders may be changed in the future.
+    , shdrVertexIndex      :: !GL.AttribLocation
     , shdrColorIndex       :: !GL.AttribLocation
     , shdrNormalIndex      :: !GL.AttribLocation
-    , shdrVertexIndex      :: !GL.AttribLocation
     , shdrProjMatIndex     :: !GL.UniformLocation
+    , shdrViewMatIndex     :: !GL.UniformLocation
+    , shdrModelMatIndex    :: !GL.UniformLocation
     -- the map
     , stateMap             :: !GL.BufferObject
     , mapVert              :: !GL.NumArrayIndices
@@ -105,13 +111,13 @@ main = do
 
         (fbWidth, fbHeight) <- GLFW.getFramebufferSize win
 
+        initRendering
         --generate map vertices
         (mapBuffer, vert) <- getMapBufferObject
-        (ci, ni, vi, pi) <- initShader
+        (ci, ni, vi, pri, vii, mi) <- initShader
 
         let zDistClosest  = 10
             zDistFarthest = zDistClosest + 20
-            zDist         = zDistClosest + ((zDistFarthest - zDistClosest) / 2)
             fov           = 90  --field of view
             near          = 1   --near plane
             far           = 100 --far plane
@@ -126,8 +132,8 @@ main = do
             state = State
               { stateWindowWidth     = fbWidth
               , stateWindowHeight    = fbHeight
-              , stateXAngle          = 0
+              , stateXAngle          = pi/6
-              , stateYAngle          = 0
+              , stateYAngle          = pi/2
               , stateZAngle          = 0
               , stateZDist           = 10
               , stateMouseDown       = False
@@ -136,10 +142,12 @@ main = do
               , stateDragStartY      = 0
               , stateDragStartXAngle = 0
               , stateDragStartYAngle = 0
-              , shdrColorIndex       = ci
-              , shdrNormalIndex      = ni
               , shdrVertexIndex      = vi
-              , shdrProjMatIndex     = pi
+              , shdrNormalIndex      = ni
+              , shdrColorIndex       = ci
+              , shdrProjMatIndex     = pri
+              , shdrViewMatIndex     = vii
+              , shdrModelMatIndex    = mi
               , stateMap             = mapBuffer
               , mapVert              = vert
               , stateFrustum         = frust
@@ -210,8 +218,7 @@ charCallback            tc win c          = atomically $ writeTQueue tc $ EventC
 --------------------------------------------------------------------------------
 
 runDemo :: Env -> State -> IO ()
-runDemo env state = do
+runDemo env state = void $ evalRWST (adjustWindow >> run) env state
-    void $ evalRWST (adjustWindow >> run) env state
 
 run :: Pioneer ()
 run = do
@@ -221,13 +228,12 @@ run = do
     draw
     liftIO $ do
         GLFW.swapBuffers win
-        GL.flush  -- not necessary, but someone recommended it
         GLFW.pollEvents
-        GL.finish
     -- getEvents & process
     processEvents
 
     -- update State
+    
     state <- get
     if stateDragging state
       then do
@@ -238,10 +244,21 @@ run = do
           (x, y) <- liftIO $ GLFW.getCursorPos win
           let myrot = (x - sodx) / 2
               mxrot = (y - sody) / 2
+--              newXAngle = if newXAngle' > 2*pi then 2*pi else
+              newXAngle = if newXAngle' > 0.45*pi then 0.45*pi else
+--                            if newXAngle' < -2*pi then -2*pi else
+                            if newXAngle' < 0 then 0 else
+                                newXAngle'
+              newXAngle' = sodxa + mxrot/100
+              newYAngle = if newYAngle' > pi then newYAngle'-2*pi else
+                            if newYAngle' < -pi then newYAngle'+2*pi else
+                                newYAngle'
+              newYAngle' = sodya + myrot/100
           put $ state
-            { stateXAngle = sodxa + mxrot
+            { stateXAngle = newXAngle
-            , stateYAngle = sodya + myrot
+            , stateYAngle = newYAngle
             }
+--          liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle]
       else do
           (kxrot, kyrot) <- liftIO $ getCursorKeyDirections win
           (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1
@@ -249,6 +266,7 @@ run = do
             { stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot)
             , stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot)
             }
+
     {-
     --modify the state with all that happened in mt time. 
     mt <- liftIO GLFW.getTime
@@ -376,37 +394,44 @@ draw :: Pioneer ()
 draw = do
     env   <- ask
     state <- get
-    let xa = stateXAngle state
+    let xa = fromRational $ toRational $ stateXAngle state
-        ya = stateYAngle state
+        ya = fromRational $ toRational $ stateYAngle state
         za = stateZAngle state
         (GL.UniformLocation proj)  = shdrProjMatIndex state
-        ci = shdrColorIndex state
+        (GL.UniformLocation vmat)  = shdrViewMatIndex state
-        ni = shdrNormalIndex state
         vi = shdrVertexIndex state
+        ni = shdrNormalIndex state
+        ci = shdrColorIndex state
         numVert = mapVert state
         map' = stateMap state
         frust = stateFrustum state
     liftIO $ do
-        GLRaw.glClearDepth 1.0
+        --(vi,GL.UniformLocation proj) <- initShader
-        GLRaw.glDisable GLRaw.gl_CULL_FACE
+        GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1
-        --lookAtUniformMatrix4fv (0.0,0.0,0.0) (0, 15, 0) up frust proj 1
+        GL.clear [GL.ColorBuffer, GL.DepthBuffer]
+        --set up projection (= copy from state)
+        with (distribute $ frust) $ \ptr ->
+              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
 
--------------
+        --set up camera
 
-        let fov = 90
+        let ! cam     = lookAt (cpos ^+^ at') at' up
-            s = recip (tan $ fov * 0.5 * pi / 180)
-            f = 1000
-            n = 1
 
-        let perspective = V.fromList [ s, 0, 0, 0
+            at'      = V3 5 0 5
-                                      , 0, s, 0, 0
+            upmap    = (fromQuaternion $
-                                      , 0, 0, -(f/(f - n)), -1
+                                axisAngle (V3 0 1 0) (ya::CFloat) :: M33 CFloat)
-                                      , 0, 0, -((f*n)/(f-n)), 0
+                                !* (V3 1 0 0)
-                                      ]
+            crot'    = (
+                            (fromQuaternion $
+                                axisAngle upmap (xa::CFloat))
+                            !*!
+                            (fromQuaternion $
+                                axisAngle (V3 0 1 0) (ya::CFloat))
+                                ) :: M33 CFloat
+            cpos     = crot' !* (V3 0 0 (-10))
 
-        V.unsafeWith perspective $ \ptr -> GLRaw.glUniformMatrix4fv proj 1 0 ptr
+        with (distribute $ cam) $ \ptr ->
-
+              glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
----------------
 
         GL.bindBuffer GL.ArrayBuffer GL.$= Just map'
         GL.vertexAttribPointer ci GL.$= fgColorIndex

src/Map/Map.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, BangPatterns #-}
 module Map.Map 
 
 (
@@ -47,40 +47,38 @@ lineHeight :: GLfloat
 lineHeight = 0.8660254
 
 numComponents :: Int
-numComponents = 4  --color
+numComponents = 10
-                +3 --normal
-                +3 --vertex
 
 mapStride :: Stride
-mapStride = fromIntegral (sizeOf (0.0 :: GLfloat)) * fromIntegral numComponents
+mapStride = fromIntegral (sizeOf (0.0 :: GLfloat) * numComponents)
 
-bufferObjectPtr :: Integral a => a -> Ptr b
+bufferObjectPtr :: Integral a => a -> Ptr GLfloat
-bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral
+bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral
 
-mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a
+mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat
 mapVertexArrayDescriptor count' offset =
-   VertexArrayDescriptor count' Float mapStride (bufferObjectPtr (fromIntegral numComponents * offset))
+   VertexArrayDescriptor count' Float mapStride (bufferObjectPtr ((fromIntegral offset)*sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset))
 
-fgColorIndex :: (IntegerHandling, VertexArrayDescriptor a)
+fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
 fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0)  --color first
 
-fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor a)
+fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
 fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
 
-fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor a)
+fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
 fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
 
 getMapBufferObject :: IO (BufferObject, NumArrayIndices)
 getMapBufferObject = do
         map' <- testmap
-        map' <- return $ generateTriangles map'
+        ! map' <- return $ P.map (*1) (generateTriangles map')
         putStrLn $ P.unlines $ P.map show (prettyMap map')
         len <- return $ fromIntegral $ P.length map' `div` numComponents
         putStrLn $ P.unwords ["num verts",show len]
         bo <- genObjectName                     -- create a new buffer
         bindBuffer ArrayBuffer $= Just bo       -- bind buffer
         withArray map' $ \buffer ->
-                bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: Float)*P.length map',
+                bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: GLfloat)*P.length map',
                                            buffer,
                                            StaticDraw)
         checkError "initBuffer"
@@ -90,6 +88,51 @@ prettyMap :: [GLfloat] -> [(GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfl
 prettyMap (a:b:c:d:x:y:z:u:v:w:ms) = (a,b,c,d,x,y,z,u,v,w):(prettyMap ms)
 prettyMap _ = []
 
+generateCube :: [GLfloat]
+generateCube = [  -- lower plane
+                  -3.0,-3.0,-3.0,
+                  3.0,-3.0,3.0,
+                  3.0,-3.0,-3.0,
+                  -3.0,-3.0,-3.0,
+                  -3.0,-3.0,3.0,
+                  3.0,-3.0,3.0,
+                  -- upper plane
+                  -3.0,3.0,-3.0,
+                  3.0,3.0,3.0,
+                  3.0,3.0,-3.0,
+                  -3.0,3.0,-3.0,
+                  -3.0,3.0,3.0,
+                  3.0,3.0,3.0,
+                   -- left plane
+                  -3.0,-3.0,-3.0,
+                  -3.0,3.0,3.0,
+                  -3.0,-3.0,3.0,
+                  -3.0,-3.0,-3.0,
+                  -3.0,3.0,3.0,
+                  -3.0,3.0,-3.0,
+                   -- right plane
+                  3.0,-3.0,-3.0,
+                  3.0,3.0,3.0,
+                  3.0,-3.0,3.0,
+                  3.0,-3.0,-3.0,
+                  3.0,3.0,3.0,
+                  3.0,3.0,-3.0,
+                   -- front plane
+                  -3.0,-3.0,-3.0,
+                  3.0,3.0,-3.0,
+                  3.0,-3.0,-3.0,
+                  -3.0,-3.0,-3.0,
+                  3.0,3.0,-3.0,
+                  -3.0,3.0,-3.0,
+                   -- back plane
+                  -3.0,-3.0,3.0,
+                  3.0,3.0,3.0,
+                  3.0,-3.0,3.0,
+                  -3.0,-3.0,3.0,
+                  3.0,3.0,3.0,
+                  -3.0,3.0,3.0
+                  ]
+
 generateTriangles :: PlayMap -> [GLfloat] 
 generateTriangles map' =
                 let ((xl,yl),(xh,yh)) = bounds map' in
@@ -161,7 +204,7 @@ coordLookup (x,z) y =
                 if even x then
                         (fromIntegral $ x `div` 2, y, fromIntegral (2 * z) * lineHeight)
                 else
-                        (fromIntegral (x `div` 2) / 2.0, y, fromIntegral (2 * z + 1) * lineHeight)
+                        (fromIntegral (x `div` 2) + 0.5, y, fromIntegral (2 * z + 1) * lineHeight)
 
 
 -- if writing in ASCII-Format transpose so i,j -> y,x
@@ -192,14 +235,20 @@ testMapTemplate = T.transpose [
 
 testMapTemplate2 :: [Text]
 testMapTemplate2 = T.transpose [
-                "~~~~~~"
+                "~~~~~~~~~~~~"
                 ]
 
 testmap :: IO PlayMap
 testmap = do
+                g <- getStdGen
+                rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate)
+                return $ listArray ((0,0),(19,19)) rawMap
+
+testmap2 :: IO PlayMap
+testmap2 = do
                 g <- getStdGen
                 rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2)
-                return $ listArray ((0,0),(5,0)) rawMap
+                return $ listArray ((0,0),(9,0)) rawMap
 
 
 parseTemplate :: [Int] -> Text -> [MapEntry]

src/Render/Misc.hs

@@ -4,16 +4,17 @@ import           Control.Monad
 import qualified Data.ByteString                            as B (ByteString)
 import           Foreign.Marshal.Array                      (allocaArray,
                                                              pokeArray)
+import Foreign.C (CFloat)
 import           Graphics.Rendering.OpenGL.GL.Shaders
 import           Graphics.Rendering.OpenGL.GL.StateVar
 import           Graphics.Rendering.OpenGL.GL.StringQueries
 import           Graphics.Rendering.OpenGL.GLU.Errors
 import           Graphics.Rendering.OpenGL.Raw.Core31
 import           System.IO                                  (hPutStrLn, stderr)
+import Linear
 
-
+up :: V3 CFloat
-up :: (Double, Double, Double)
+up = V3 0 1 0
-up = (0.0, 1.0, 1.0)
 
 checkError :: String -> IO ()
 checkError functionName = get errors >>= mapM_ reportError
@@ -58,16 +59,21 @@ createProgramUsing shaders = do
    linkAndCheck program
    return program
 
-createFrustum :: Float -> Float -> Float -> Float -> [GLfloat]
+createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat
-createFrustum fov n f rat =
+createFrustum fov n' f' rat =
-                let s = recip (tan $ fov*0.5 * pi / 180) in
+                let 
-
+                    f = realToFrac f'
-                map (fromRational . toRational) [
+                    n = realToFrac n'
-                        rat*s,0,0,0,
+                    s = realToFrac $ recip (tan $ fov*0.5 * pi / 180)
-                        0,rat*s,0,0,
+                    (ratw,rath) = if rat > 1 then
-                        0,0,-(f/(f-n)), -1,
+                                        (1,1/realToFrac rat)
-                        0,0,-((f*n)/(f-n)), 1
+                                  else
-                ]
+                                        (realToFrac rat,1)
+                in
+                    V4 (V4 (s/ratw)     0            0                   0)
+                       (V4    0     (s/rath)         0                   0)
+                       (V4    0         0    (-((f+n)/(f-n)))  (-((2*f*n)/(f-n))))
+                       (V4    0         0          (-1)                  0)
 
 lookAtUniformMatrix4fv :: (Double, Double, Double)  --origin
                         -> (Double, Double, Double) --camera-pos
@@ -126,9 +132,23 @@ infixl 5 ><
                 ]
 _ >< _ = error "non-conformat matrix-multiplication"
 
+
+-- from vmath.h
+lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
+lookAt eye@(V3 ex ey ez) center up =
+        V4
+         (V4 xx xy xz (-dot x eye))
+         (V4 yx yy yz (-dot y eye))
+         (V4 zx zy zz (-dot z eye))
+         (V4 0 0 0 1)
+        where
+                z@(V3 zx zy zz) = normalize (eye ^-^ center)
+                x@(V3 xx xy xz) = normalize (cross up z)
+                y@(V3 yx yy yz) = normalize (cross z x)
+
 -- generates 4x4-Projection-Matrix
-lookAt :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat]
+lookAt_ :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat]
-lookAt at eye up =
+lookAt_ at eye up =
         map (fromRational . toRational) [
          xx, yx, zx, 0,
          xy, yy, zy, 0,

src/Render/Render.hs

@@ -7,12 +7,13 @@ import           Foreign.Storable                           (sizeOf)
 import           Graphics.Rendering.OpenGL.GL.BufferObjects
 import           Graphics.Rendering.OpenGL.GL.Framebuffer   (clearColor)
 import           Graphics.Rendering.OpenGL.GL.ObjectName
+import           Graphics.Rendering.OpenGL.GL.PerFragment
 import           Graphics.Rendering.OpenGL.GL.Shaders
 import           Graphics.Rendering.OpenGL.GL.StateVar
 import           Graphics.Rendering.OpenGL.GL.VertexArrays  (Capability (..),
                                                              vertexAttribArray)
 import           Graphics.Rendering.OpenGL.GL.VertexSpec
-import           Graphics.Rendering.OpenGL.Raw.Core31.Types (GLfloat)
+import           Graphics.Rendering.OpenGL.Raw.Core31
 import           Render.Misc
 
 vertexShaderFile :: String
@@ -33,7 +34,7 @@ initBuffer varray =
            checkError "initBuffer"
            return bufferObject
 
-initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation)
+initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation, UniformLocation, UniformLocation)
 initShader = do
    ! vertexSource <- B.readFile vertexShaderFile
    ! fragmentSource <- B.readFile fragmentShaderFile
@@ -49,22 +50,35 @@ initShader = do
    projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix")
    checkError "projMat"
 
-   colorIndex <- get (attribLocation program "fg_Color")
+   viewMatrixIndex <- get (uniformLocation program "fg_ViewMatrix")
-   vertexAttribArray colorIndex $= Enabled
+   checkError "viewMat"
-   checkError "colorInd"
 
-   normalIndex <- get (attribLocation program "fg_Normal")
+   modelMatrixIndex <- get (uniformLocation program "fg_ModelMatrix")
-   vertexAttribArray normalIndex $= Enabled
+   checkError "modelMat"
-   checkError "normalInd"
 
    vertexIndex <- get (attribLocation program "fg_VertexIn")
    vertexAttribArray vertexIndex $= Enabled
    checkError "vertexInd"
 
+   normalIndex <- get (attribLocation program "fg_NormalIn")
+   vertexAttribArray normalIndex $= Enabled
+   checkError "normalInd"
+
+   colorIndex <- get (attribLocation program "fg_Color")
+   vertexAttribArray colorIndex $= Enabled
+   checkError "colorInd"
+
+   att <- get (activeAttribs program)
+
+   putStrLn $ unlines $ "Attributes: ":map show att
+   putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)]
+
    checkError "initShader"
-   return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex)
+   return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex)
 
 initRendering :: IO ()
 initRendering = do
         clearColor $= Color4 0 0 0 0
+        depthFunc $= Just Less
+        glCullFace gl_BACK
         checkError "initRendering"

test2.hs

@@ -0,0 +1,660 @@
+module Main (main) where
+
+--------------------------------------------------------------------------------
+
+import Control.Concurrent.STM    (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue)
+import Control.Monad             (unless, when, void)
+import Control.Monad.RWS.Strict  (RWST, ask, asks, evalRWST, get, liftIO, modify, put)
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Data.List                 (intercalate)
+import Data.Maybe                (catMaybes)
+import Text.PrettyPrint
+import Control.Applicative
+import Control.Lens
+import Control.Monad (forever)
+import Data.Distributive (distribute)
+import Foreign (Ptr, castPtr, nullPtr, sizeOf, with)
+import Foreign.C (CFloat)
+
+import Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.Rendering.OpenGL.Raw as GL
+import qualified Graphics.UI.GLFW          as GLFW
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.Vector.Storable as V
+import Linear as L
+import Linear ((!*!))
+
+import Data.IORef
+
+--------------------------------------------------------------------------------
+
+data Env = Env
+    { envEventsChan    :: TQueue Event
+    , envWindow        :: !GLFW.Window
+    , envGear1         :: !GL.DisplayList
+    , envGear2         :: !GL.DisplayList
+    , envGear3         :: !GL.DisplayList
+    , envZDistClosest  :: !Double
+    , envZDistFarthest :: !Double
+    }
+
+data State = State
+    { stateWindowWidth     :: !Int
+    , stateWindowHeight    :: !Int
+    , stateXAngle          :: !Double
+    , stateYAngle          :: !Double
+    , stateZAngle          :: !Double
+    , stateGearZAngle      :: !Double
+    , stateZDist           :: !Double
+    , stateMouseDown       :: !Bool
+    , stateDragging        :: !Bool
+    , stateDragStartX      :: !Double
+    , stateDragStartY      :: !Double
+    , stateDragStartXAngle :: !Double
+    , stateDragStartYAngle :: !Double
+    }
+
+type Demo = RWST Env () State IO
+
+--------------------------------------------------------------------------------
+
+data Event =
+    EventError           !GLFW.Error !String
+  | EventWindowPos       !GLFW.Window !Int !Int
+  | EventWindowSize      !GLFW.Window !Int !Int
+  | EventWindowClose     !GLFW.Window
+  | EventWindowRefresh   !GLFW.Window
+  | EventWindowFocus     !GLFW.Window !GLFW.FocusState
+  | EventWindowIconify   !GLFW.Window !GLFW.IconifyState
+  | EventFramebufferSize !GLFW.Window !Int !Int
+  | EventMouseButton     !GLFW.Window !GLFW.MouseButton !GLFW.MouseButtonState !GLFW.ModifierKeys
+  | EventCursorPos       !GLFW.Window !Double !Double
+  | EventCursorEnter     !GLFW.Window !GLFW.CursorState
+  | EventScroll          !GLFW.Window !Double !Double
+  | EventKey             !GLFW.Window !GLFW.Key !Int !GLFW.KeyState !GLFW.ModifierKeys
+  | EventChar            !GLFW.Window !Char
+  deriving Show
+
+--------------------------------------------------------------------------------
+
+--------------------------------------------------------------------------------
+triangleTransformation :: (Epsilon a, Floating a) => a -> M44 a
+triangleTransformation =
+  liftA2 (!*!) triangleTranslation triangleRotation
+
+--------------------------------------------------------------------------------
+triangleRotation :: (Epsilon a, Floating a) => a -> M44 a
+triangleRotation t =
+  m33_to_m44 $
+    fromQuaternion $
+      axisAngle (V3 0 1 0) (t * 2)
+
+triangleTranslation :: Floating a => a -> M44 a
+triangleTranslation t =
+  eye4 & translation .~ V3 (sin t * 2) 0 (-5)
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+    let width  = 640
+        height = 480
+
+    eventsChan <- newTQueueIO :: IO (TQueue Event)
+
+    withWindow width height "GLFW-b-demo" $ \win -> do
+          let z = 0
+          let vertices = V.fromList [ 0, 1, 0
+                                    , -1, -1, z
+                                    , 1, -1, z ] :: V.Vector Float
+              vertexAttribute = GL.AttribLocation 0
+        
+          cubeVbo <- GL.genObjectName
+        
+          GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
+        
+          V.unsafeWith vertices $ \v -> GL.bufferData GL.ArrayBuffer $=
+            (fromIntegral $ V.length vertices * sizeOf (0 :: Float), v, GL.StaticDraw)
+        
+          GL.vertexAttribPointer vertexAttribute $=
+            (GL.ToFloat, GL.VertexArrayDescriptor 3 GL.Float 0 nullPtr)
+        
+          GL.vertexAttribArray vertexAttribute $= GL.Enabled
+          GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
+        
+          vertexShader <- GL.createShader GL.VertexShader
+          fragmentShader <- GL.createShader GL.FragmentShader
+        
+          GL.shaderSourceBS vertexShader $= Text.encodeUtf8
+            (Text.pack $ unlines
+              [ "#version 130"
+              , "uniform mat4 projection;"
+              , "uniform mat4 model;"
+              , "in vec3 in_Position;"
+              , "void main(void) {"
+              , "  gl_Position = projection * model * vec4(in_Position, 1.0);"
+              , "}"
+              ])
+        
+          GL.shaderSourceBS fragmentShader $= Text.encodeUtf8
+            (Text.pack $ unlines
+              [ "#version 130"
+              , "out vec4 fragColor;"
+              , "void main(void) {"
+              , "  fragColor = vec4(1.0,1.0,1.0,1.0);"
+              , "}"
+              ])
+        
+          GL.compileShader vertexShader
+          GL.compileShader fragmentShader
+        
+          shaderProg <- GL.createProgram
+          GL.attachShader shaderProg vertexShader
+          GL.attachShader shaderProg fragmentShader
+          GL.attribLocation shaderProg "in_Position" $= vertexAttribute
+          GL.linkProgram shaderProg
+          GL.currentProgram $= Just shaderProg
+        
+          let fov = 90
+              s = recip (tan $ fov * 0.5 * pi / 180)
+              f = 1000
+              n = 1
+        
+          let perspective = V.fromList [ s, 0, 0, 0
+                                      , 0, s, 0, 0
+                                      , 0, 0, -(f/(f - n)), -1
+                                      , 0, 0, -((f*n)/(f-n)), 0
+                                      ]
+        
+          GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "projection")
+          V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv loc 1 0 ptr
+        
+          tr <- newIORef 0
+          forever $ do
+            t <- readIORef tr
+        
+            GL.clearColor $= GL.Color4 0.5 0.2 1 1
+            GL.clear [GL.ColorBuffer]
+        
+            GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "model")
+            with (distribute $ triangleTransformation t) $ \ptr ->
+              GL.glUniformMatrix4fv loc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
+        
+            GL.drawArrays GL.Triangles 0 3
+        
+            GLFW.swapBuffers win
+            writeIORef tr (t + 0.1)
+
+--------------------------------------------------------------------------------
+
+-- GLFW-b is made to be very close to the C API, so creating a window is pretty
+-- clunky by Haskell standards. A higher-level API would have some function
+-- like withWindow.
+
+withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO ()
+withWindow width height title f = do
+    GLFW.setErrorCallback $ Just simpleErrorCallback
+    r <- GLFW.init
+    when r $ do
+        m <- GLFW.createWindow width height title Nothing Nothing
+        case m of
+          (Just win) -> do
+              GLFW.makeContextCurrent m
+              f win
+              GLFW.setErrorCallback $ Just simpleErrorCallback
+              GLFW.destroyWindow win
+          Nothing -> return ()
+        GLFW.terminate
+  where
+    simpleErrorCallback e s =
+        putStrLn $ unwords [show e, show s]
+
+--------------------------------------------------------------------------------
+
+-- Each callback does just one thing: write an appropriate Event to the events
+-- TQueue.
+
+errorCallback           :: TQueue Event -> GLFW.Error -> String                                                            -> IO ()
+windowPosCallback       :: TQueue Event -> GLFW.Window -> Int -> Int                                                       -> IO ()
+windowSizeCallback      :: TQueue Event -> GLFW.Window -> Int -> Int                                                       -> IO ()
+windowCloseCallback     :: TQueue Event -> GLFW.Window                                                                     -> IO ()
+windowRefreshCallback   :: TQueue Event -> GLFW.Window                                                                     -> IO ()
+windowFocusCallback     :: TQueue Event -> GLFW.Window -> GLFW.FocusState                                                  -> IO ()
+windowIconifyCallback   :: TQueue Event -> GLFW.Window -> GLFW.IconifyState                                                -> IO ()
+framebufferSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int                                                       -> IO ()
+mouseButtonCallback     :: TQueue Event -> GLFW.Window -> GLFW.MouseButton   -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO ()
+cursorPosCallback       :: TQueue Event -> GLFW.Window -> Double -> Double                                                 -> IO ()
+cursorEnterCallback     :: TQueue Event -> GLFW.Window -> GLFW.CursorState                                                 -> IO ()
+scrollCallback          :: TQueue Event -> GLFW.Window -> Double -> Double                                                 -> IO ()
+keyCallback             :: TQueue Event -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys            -> IO ()
+charCallback            :: TQueue Event -> GLFW.Window -> Char                                                             -> IO ()
+
+errorCallback           tc e s            = atomically $ writeTQueue tc $ EventError           e s
+windowPosCallback       tc win x y        = atomically $ writeTQueue tc $ EventWindowPos       win x y
+windowSizeCallback      tc win w h        = atomically $ writeTQueue tc $ EventWindowSize      win w h
+windowCloseCallback     tc win            = atomically $ writeTQueue tc $ EventWindowClose     win
+windowRefreshCallback   tc win            = atomically $ writeTQueue tc $ EventWindowRefresh   win
+windowFocusCallback     tc win fa         = atomically $ writeTQueue tc $ EventWindowFocus     win fa
+windowIconifyCallback   tc win ia         = atomically $ writeTQueue tc $ EventWindowIconify   win ia
+framebufferSizeCallback tc win w h        = atomically $ writeTQueue tc $ EventFramebufferSize win w h
+mouseButtonCallback     tc win mb mba mk  = atomically $ writeTQueue tc $ EventMouseButton     win mb mba mk
+cursorPosCallback       tc win x y        = atomically $ writeTQueue tc $ EventCursorPos       win x y
+cursorEnterCallback     tc win ca         = atomically $ writeTQueue tc $ EventCursorEnter     win ca
+scrollCallback          tc win x y        = atomically $ writeTQueue tc $ EventScroll          win x y
+keyCallback             tc win k sc ka mk = atomically $ writeTQueue tc $ EventKey             win k sc ka mk
+charCallback            tc win c          = atomically $ writeTQueue tc $ EventChar            win c
+
+--------------------------------------------------------------------------------
+
+runDemo :: Env -> State -> IO ()
+runDemo env state = do
+    printInstructions
+    void $ evalRWST (adjustWindow >> run) env state
+
+run :: Demo ()
+run = do
+    win <- asks envWindow
+
+    draw
+    liftIO $ do
+        GLFW.swapBuffers win
+        GL.flush  -- not necessary, but someone recommended it
+        GLFW.pollEvents
+    processEvents
+
+    state <- get
+    if stateDragging state
+      then do
+          let sodx  = stateDragStartX      state
+              sody  = stateDragStartY      state
+              sodxa = stateDragStartXAngle state
+              sodya = stateDragStartYAngle state
+          (x, y) <- liftIO $ GLFW.getCursorPos win
+          let myrot = (x - sodx) / 2
+              mxrot = (y - sody) / 2
+          put $ state
+            { stateXAngle = sodxa + mxrot
+            , stateYAngle = sodya + myrot
+            }
+      else do
+          (kxrot, kyrot) <- liftIO $ getCursorKeyDirections win
+          (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1
+          put $ state
+            { stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot)
+            , stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot)
+            }
+
+    mt <- liftIO GLFW.getTime
+    modify $ \s -> s
+      { stateGearZAngle = maybe 0 (realToFrac . (100*)) mt
+      }
+
+    q <- liftIO $ GLFW.windowShouldClose win
+    unless q run
+
+processEvents :: Demo ()
+processEvents = do
+    tc <- asks envEventsChan
+    me <- liftIO $ atomically $ tryReadTQueue tc
+    case me of
+      Just e -> do
+          processEvent e
+          processEvents
+      Nothing -> return ()
+
+processEvent :: Event -> Demo ()
+processEvent ev =
+    case ev of
+      (EventError e s) -> do
+          printEvent "error" [show e, show s]
+          win <- asks envWindow
+          liftIO $ GLFW.setWindowShouldClose win True
+
+      (EventWindowPos _ x y) ->
+          printEvent "window pos" [show x, show y]
+
+      (EventWindowSize _ width height) ->
+          printEvent "window size" [show width, show height]
+
+      (EventWindowClose _) ->
+          printEvent "window close" []
+
+      (EventWindowRefresh _) ->
+          printEvent "window refresh" []
+
+      (EventWindowFocus _ fs) ->
+          printEvent "window focus" [show fs]
+
+      (EventWindowIconify _ is) ->
+          printEvent "window iconify" [show is]
+
+      (EventFramebufferSize _ width height) -> do
+          printEvent "framebuffer size" [show width, show height]
+          modify $ \s -> s
+            { stateWindowWidth  = width
+            , stateWindowHeight = height
+            }
+          adjustWindow
+
+      (EventMouseButton _ mb mbs mk) -> do
+          printEvent "mouse button" [show mb, show mbs, showModifierKeys mk]
+          when (mb == GLFW.MouseButton'1) $ do
+              let pressed = mbs == GLFW.MouseButtonState'Pressed
+              modify $ \s -> s
+                { stateMouseDown = pressed
+                }
+              unless pressed $
+                modify $ \s -> s
+                  { stateDragging = False
+                  }
+
+      (EventCursorPos _ x y) -> do
+          let x' = round x :: Int
+              y' = round y :: Int
+          printEvent "cursor pos" [show x', show y']
+          state <- get
+          when (stateMouseDown state && not (stateDragging state)) $
+            put $ state
+              { stateDragging        = True
+              , stateDragStartX      = x
+              , stateDragStartY      = y
+              , stateDragStartXAngle = stateXAngle state
+              , stateDragStartYAngle = stateYAngle state
+              }
+
+      (EventCursorEnter _ cs) ->
+          printEvent "cursor enter" [show cs]
+
+      (EventScroll _ x y) -> do
+          let x' = round x :: Int
+              y' = round y :: Int
+          printEvent "scroll" [show x', show y']
+          env <- ask
+          modify $ \s -> s
+            { stateZDist =
+                let zDist' = stateZDist s + realToFrac (negate $ y / 2)
+                in curb (envZDistClosest env) (envZDistFarthest env) zDist'
+            }
+          adjustWindow
+
+      (EventKey win k scancode ks mk) -> do
+          printEvent "key" [show k, show scancode, show ks, showModifierKeys mk]
+          when (ks == GLFW.KeyState'Pressed) $ do
+              -- Q, Esc: exit
+              when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $
+                liftIO $ GLFW.setWindowShouldClose win True
+              -- ?: print instructions
+              when (k == GLFW.Key'Slash && GLFW.modifierKeysShift mk) $
+                liftIO printInstructions
+              -- i: print GLFW information
+              when (k == GLFW.Key'I) $
+                liftIO $ printInformation win
+
+      (EventChar _ c) ->
+          printEvent "char" [show c]
+
+adjustWindow :: Demo ()
+adjustWindow = do
+    state <- get
+    let width  = stateWindowWidth  state
+        height = stateWindowHeight state
+        zDist  = stateZDist        state
+
+    let pos   = GL.Position 0 0
+        size  = GL.Size (fromIntegral width) (fromIntegral height)
+        h     = fromIntegral height / fromIntegral width :: Double
+        znear = 1           :: Double
+        zfar  = 40          :: Double
+        xmax  = znear * 0.5 :: Double
+    liftIO $ do
+        GL.viewport   GL.$= (pos, size)
+        GL.matrixMode GL.$= GL.Projection
+        GL.loadIdentity
+        GL.frustum (realToFrac $ -xmax)
+                   (realToFrac    xmax)
+                   (realToFrac $ -xmax * realToFrac h)
+                   (realToFrac $  xmax * realToFrac h)
+                   (realToFrac    znear)
+                   (realToFrac    zfar)
+        GL.matrixMode GL.$= GL.Modelview 0
+        GL.loadIdentity
+        GL.translate (GL.Vector3 0 0 (negate $ realToFrac zDist) :: GL.Vector3 GL.GLfloat)
+
+draw :: Demo ()
+draw = do
+    env   <- ask
+    state <- get
+    let gear1 = envGear1 env
+        gear2 = envGear2 env
+        gear3 = envGear3 env
+        xa = stateXAngle state
+        ya = stateYAngle state
+        za = stateZAngle state
+        ga = stateGearZAngle  state
+    liftIO $ do
+        GL.clear [GL.ColorBuffer, GL.DepthBuffer]
+        GL.preservingMatrix $ do
+            GL.rotate (realToFrac xa) xunit
+            GL.rotate (realToFrac ya) yunit
+            GL.rotate (realToFrac za) zunit
+            GL.preservingMatrix $ do
+                GL.translate gear1vec
+                GL.rotate (realToFrac ga) zunit
+                GL.callList gear1
+            GL.preservingMatrix $ do
+                GL.translate gear2vec
+                GL.rotate (-2 * realToFrac ga - 9) zunit
+                GL.callList gear2
+            GL.preservingMatrix $ do
+                GL.translate gear3vec
+                GL.rotate (-2 * realToFrac ga - 25) zunit
+                GL.callList gear3
+      where
+        gear1vec = GL.Vector3 (-3)   (-2)  0 :: GL.Vector3 GL.GLfloat
+        gear2vec = GL.Vector3   3.1  (-2)  0 :: GL.Vector3 GL.GLfloat
+        gear3vec = GL.Vector3 (-3.1)   4.2 0 :: GL.Vector3 GL.GLfloat
+        xunit = GL.Vector3 1 0 0 :: GL.Vector3 GL.GLfloat
+        yunit = GL.Vector3 0 1 0 :: GL.Vector3 GL.GLfloat
+        zunit = GL.Vector3 0 0 1 :: GL.Vector3 GL.GLfloat
+
+getCursorKeyDirections :: GLFW.Window -> IO (Double, Double)
+getCursorKeyDirections win = do
+    x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up
+    x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down
+    y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left
+    y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right
+    let x0n = if x0 then (-1) else 0
+        x1n = if x1 then   1  else 0
+        y0n = if y0 then (-1) else 0
+        y1n = if y1 then   1  else 0
+    return (x0n + x1n, y0n + y1n)
+
+getJoystickDirections :: GLFW.Joystick -> IO (Double, Double)
+getJoystickDirections js = do
+    maxes <- GLFW.getJoystickAxes js
+    return $ case maxes of
+      (Just (x:y:_)) -> (-y, x)
+      _              -> ( 0, 0)
+
+isPress :: GLFW.KeyState -> Bool
+isPress GLFW.KeyState'Pressed   = True
+isPress GLFW.KeyState'Repeating = True
+isPress _                       = False
+
+--------------------------------------------------------------------------------
+
+printInstructions :: IO ()
+printInstructions =
+    putStrLn $ render $
+      nest 4 (
+        text "------------------------------------------------------------" $+$
+        text "'?': Print these instructions"                                $+$
+        text "'i': Print GLFW information"                                  $+$
+        text ""                                                             $+$
+        text "* Mouse cursor, keyboard cursor keys, and/or joystick"        $+$
+        text "  control rotation."                                          $+$
+        text "* Mouse scroll wheel controls distance from scene."           $+$
+        text "------------------------------------------------------------"
+      )
+
+printInformation :: GLFW.Window -> IO ()
+printInformation win = do
+    version       <- GLFW.getVersion
+    versionString <- GLFW.getVersionString
+    monitorInfos  <- runMaybeT getMonitorInfos
+    joystickNames <- getJoystickNames
+    clientAPI     <- GLFW.getWindowClientAPI              win
+    cv0           <- GLFW.getWindowContextVersionMajor    win
+    cv1           <- GLFW.getWindowContextVersionMinor    win
+    cv2           <- GLFW.getWindowContextVersionRevision win
+    robustness    <- GLFW.getWindowContextRobustness      win
+    forwardCompat <- GLFW.getWindowOpenGLForwardCompat    win
+    debug         <- GLFW.getWindowOpenGLDebugContext     win
+    profile       <- GLFW.getWindowOpenGLProfile          win
+
+    putStrLn $ render $
+      nest 4 (
+        text "------------------------------------------------------------" $+$
+        text "GLFW C library:" $+$
+        nest 4 (
+          text "Version:"        <+> renderVersion version $+$
+          text "Version string:" <+> renderVersionString versionString
+        ) $+$
+        text "Monitors:" $+$
+        nest 4 (
+          renderMonitorInfos monitorInfos
+        ) $+$
+        text "Joysticks:" $+$
+        nest 4 (
+          renderJoystickNames joystickNames
+        ) $+$
+        text "OpenGL context:" $+$
+        nest 4 (
+          text "Client API:"            <+> renderClientAPI clientAPI $+$
+          text "Version:"               <+> renderContextVersion cv0 cv1 cv2 $+$
+          text "Robustness:"            <+> renderContextRobustness robustness $+$
+          text "Forward compatibility:" <+> renderForwardCompat forwardCompat $+$
+          text "Debug:"                 <+> renderDebug debug $+$
+          text "Profile:"               <+> renderProfile profile
+        ) $+$
+        text "------------------------------------------------------------"
+      )
+  where
+    renderVersion (GLFW.Version v0 v1 v2) =
+        text $ intercalate "." $ map show [v0, v1, v2]
+
+    renderVersionString =
+        text . show
+
+    renderMonitorInfos =
+        maybe (text "(error)") (vcat . map renderMonitorInfo)
+
+    renderMonitorInfo (name, (x,y), (w,h), vms) =
+        text (show name) $+$
+        nest 4 (
+          location <+> size $+$
+          fsep (map renderVideoMode vms)
+        )
+      where
+        location = int x <> text "," <> int y
+        size     = int w <> text "x" <> int h <> text "mm"
+
+    renderVideoMode (GLFW.VideoMode w h r g b rr) =
+        brackets $ res <+> rgb <+> hz
+      where
+        res = int w <> text "x" <> int h
+        rgb = int r <> text "x" <> int g <> text "x" <> int b
+        hz  = int rr <> text "Hz"
+
+    renderJoystickNames pairs =
+        vcat $ map (\(js, name) -> text (show js) <+> text (show name)) pairs
+
+    renderContextVersion v0 v1 v2 =
+        hcat [int v0, text ".", int v1, text ".", int v2]
+
+    renderClientAPI         = text . show
+    renderContextRobustness = text . show
+    renderForwardCompat     = text . show
+    renderDebug             = text . show
+    renderProfile           = text . show
+
+type MonitorInfo = (String, (Int,Int), (Int,Int), [GLFW.VideoMode])
+
+getMonitorInfos :: MaybeT IO [MonitorInfo]
+getMonitorInfos =
+    getMonitors >>= mapM getMonitorInfo
+  where
+    getMonitors :: MaybeT IO [GLFW.Monitor]
+    getMonitors = MaybeT GLFW.getMonitors
+
+    getMonitorInfo :: GLFW.Monitor -> MaybeT IO MonitorInfo
+    getMonitorInfo mon = do
+        name <- getMonitorName mon
+        vms  <- getVideoModes mon
+        MaybeT $ do
+            pos  <- liftIO $ GLFW.getMonitorPos mon
+            size <- liftIO $ GLFW.getMonitorPhysicalSize mon
+            return $ Just (name, pos, size, vms)
+
+    getMonitorName :: GLFW.Monitor -> MaybeT IO String
+    getMonitorName mon = MaybeT $ GLFW.getMonitorName mon
+
+    getVideoModes :: GLFW.Monitor -> MaybeT IO [GLFW.VideoMode]
+    getVideoModes mon = MaybeT $ GLFW.getVideoModes mon
+
+getJoystickNames :: IO [(GLFW.Joystick, String)]
+getJoystickNames =
+    catMaybes `fmap` mapM getJoystick joysticks
+  where
+    getJoystick js =
+        fmap (maybe Nothing (\name -> Just (js, name)))
+             (GLFW.getJoystickName js)
+
+--------------------------------------------------------------------------------
+
+printEvent :: String -> [String] -> Demo ()
+printEvent cbname fields =
+    liftIO $ putStrLn $ cbname ++ ": " ++ unwords fields
+
+showModifierKeys :: GLFW.ModifierKeys -> String
+showModifierKeys mk =
+    "[mod keys: " ++ keys ++ "]"
+  where
+    keys = if null xs then "none" else unwords xs
+    xs = catMaybes ys
+    ys = [ if GLFW.modifierKeysShift   mk then Just "shift"   else Nothing
+         , if GLFW.modifierKeysControl mk then Just "control" else Nothing
+         , if GLFW.modifierKeysAlt     mk then Just "alt"     else Nothing
+         , if GLFW.modifierKeysSuper   mk then Just "super"   else Nothing
+         ]
+
+curb :: Ord a => a -> a -> a -> a
+curb l h x
+  | x < l     = l
+  | x > h     = h
+  | otherwise = x
+
+--------------------------------------------------------------------------------
+
+joysticks :: [GLFW.Joystick]
+joysticks =
+  [ GLFW.Joystick'1
+  , GLFW.Joystick'2
+  , GLFW.Joystick'3
+  , GLFW.Joystick'4
+  , GLFW.Joystick'5
+  , GLFW.Joystick'6
+  , GLFW.Joystick'7
+  , GLFW.Joystick'8
+  , GLFW.Joystick'9
+  , GLFW.Joystick'10
+  , GLFW.Joystick'11
+  , GLFW.Joystick'12
+  , GLFW.Joystick'13
+  , GLFW.Joystick'14
+  , GLFW.Joystick'15
+  , GLFW.Joystick'16
+  ]
+