40 files changed, 1420 insertions, 779 deletions

diff --git a/Demos/Balls/Main.hs b/Demos/Balls/Main.hs
new file mode 100644
index 0000000..d266d85
--- /dev/null
+++ b/Demos/Balls/Main.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+--{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+
+module Main where
+
+import           Spear.App
+import           Spear.Game
+import           Spear.Math.AABB
+import qualified Spear.Math.Matrix3         as Matrix3
+import qualified Spear.Math.Matrix4         as Matrix4
+import           Spear.Math.Spatial
+import           Spear.Math.Spatial2
+import           Spear.Math.Vector
+import           Spear.Physics.Collision
+--import           Spear.Prelude
+import           Spear.Render.Core.Pipeline
+import           Spear.Render.Core.State
+import           Spear.Render.Immediate
+import           Spear.Sound.Sound
+import           Spear.Sound.State
+import           Spear.Window
+
+import           Control.Monad              (when)
+
+
+ballSize = 0.01
+numBalls = 1000
+
+data Ball = Ball
+  { ballPosition :: {-# UNPACK #-} !Vector2
+  , ballVelocity :: {-# UNPACK #-} !Vector2
+  }
+
+instance Positional Ball Vector2 where
+  setPosition p ball = ball { ballPosition = p }
+  position = ballPosition
+  translate v ball = ball { ballPosition = v + ballPosition ball }
+
+instance Bounded2 Ball where
+  boundingVolume ball = aabb2Volume $ translate (ballPosition ball) (AABB2 (-size) size)
+    where size = vec2 s s
+          s    = ballSize / (2::Float)
+
+data World = World
+  { viewProjection :: Matrix4.Matrix4
+  , balls          :: [Ball]
+  }
+
+type GameState = AppState World
+
+
+options = defaultAppOptions { title = "Balls" }
+
+app = App options initGame endGame step render resize
+
+
+main :: IO ()
+main = runApp app
+
+initGame :: Game AppContext World
+initGame =
+  let
+    world          = zipWith Ball positions velocities
+    positions      = (+vec2 0.5 0.5) . makePosition <$> numbers
+    makePosition i = radius * vec2 (sin (f*i)) (cos (f*i))
+    velocities     = makeVelocity <$> numbers
+    makeVelocity i = scale speed $ vec2 (sin (f*i)) (cos (f*i))
+    numbers        = [1..numBalls]
+    f              = 2*pi / numBalls
+    radius         = 0.05
+    speed          = 0.4
+  in
+    return $ World Matrix4.id world
+
+endGame :: Game GameState ()
+endGame = return ()
+
+
+step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
+step elapsed dt inputEvents = do
+  modifyGameState $ \world -> world
+    { balls = moveBalls dt $ balls world
+    }
+  return (not $ exitRequested inputEvents)
+
+exitRequested = elem (KeyDown KEY_ESC)
+
+moveBalls :: Elapsed -> [Ball] -> [Ball]
+moveBalls dt = (bounceBall dt . moveBall dt <$>)
+
+moveBall :: Elapsed -> Ball -> Ball
+moveBall dt ball = translate (scale (realToFrac dt) $ ballVelocity ball) ball
+
+bounceBall :: Elapsed -> Ball -> Ball
+bounceBall dt ball =
+  let
+    (AABB2Volume (AABB2 pmin pmax)) = boundingVolume ball
+    sideCollision = x pmin < 0 || x pmax > 1
+    backCollision = y pmin < 0 || y pmax > 1
+    flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v
+    flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v
+    velocity = ballVelocity ball
+    velocity'
+      = flipX
+      . flipY
+      $ velocity
+    collision = velocity' /= velocity
+    -- Apply offset when collision occurs to avoid sticky collisions.
+    delta = if collision then 1 else 0
+    dt' = realToFrac dt
+   in
+    ball
+    { ballPosition = ballPosition ball + scale (delta * dt') velocity'
+    , ballVelocity = velocity'
+    }
+
+
+render :: Game GameState ()
+render = do
+  gameState <- getGameState
+  siblingGame $ do
+    immStart
+    immSetViewProjectionMatrix (viewProjection gameState)
+    -- Clear the background to a different colour than the playable area to make
+    -- the latter distinguishable.
+    setClearColour (0.2, 0.2, 0.2, 0.0)
+    clearBuffers [ColourBuffer]
+    render' $ balls gameState
+    immEnd
+
+render' :: [Ball] -> Game ImmRenderState ()
+render' balls = do
+  immLoadIdentity
+  renderBackground
+  -- Draw objects.
+  immSetColour (vec4 1.0 1.0 1.0 1.0)
+  mapM_ renderBall balls
+
+renderBackground :: Game ImmRenderState ()
+renderBackground =
+  let pmin = 0 :: Float
+      pmax = 1 :: Float
+  in do
+    immSetColour (vec4 0.0 0.25 0.41 1.0)
+    immDrawQuads2d [
+      (vec2 pmin pmin
+      ,vec2 pmax pmin
+      ,vec2 pmax pmax
+      ,vec2 pmin pmax)]
+
+renderBall :: Ball -> Game ImmRenderState ()
+renderBall ball =
+  let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume ball
+  in
+    immDrawQuads2d [
+      (vec2 xmin ymin
+      ,vec2 xmax ymin
+      ,vec2 xmax ymax
+      ,vec2 xmin ymax)]
+
+
+resize :: WindowEvent -> Game GameState ()
+resize (ResizeEvent w h) =
+  let r = fromIntegral w / fromIntegral h
+      pad    = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
+      left   = if r > 1 then -pad else 0
+      right  = if r > 1 then 1 + pad else 1
+      bottom = if r > 1 then 0 else -pad
+      top    = if r > 1 then 1 else 1 + pad
+  in do
+    setViewport 0 0 w h
+    modifyGameState $ \pong -> pong {
+      viewProjection = Matrix4.ortho left right bottom top (-1) 1
+    }
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index 0237a26..22b1021 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module Main where
 
 import           Pong
@@ -5,66 +7,85 @@ import           Pong
 import           Spear.App
 import           Spear.Game
 import           Spear.Math.AABB
-import           Spear.Math.Matrix4         as Matrix4 hiding (position)
+import           Spear.Math.Matrix4         as Matrix4
 import           Spear.Math.Spatial
 import           Spear.Math.Spatial2
 import           Spear.Math.Vector
+import           Spear.Physics.Collision
 import           Spear.Render.Core.Pipeline
 import           Spear.Render.Core.State
 import           Spear.Render.Immediate
+import           Spear.Sound.Sound
+import           Spear.Sound.State
 import           Spear.Window
 
-import           Data.Maybe                 (mapMaybe)
+import           Control.Monad              (when)
 
 
-data GameState = GameState
-  { window          :: Window
-  , renderCoreState :: RenderCoreState
-  , immRenderState  :: ImmRenderState
-  , viewProjection  :: Matrix4
+data Pong = Pong
+  { viewProjection  :: Matrix4
+  , backgroundMusic :: SoundSource
   , world           :: [GameObject]
   }
 
-app = App step render resize
+type GameState = AppState Pong
+
+
+options = defaultAppOptions { title = "Pong" }
+
+app = App options initGame endGame step render resize
 
-main =
-  withWindow (900, 600) (Just "Pong") initGame endGame $
-    loop app
 
-initGame :: Window -> Game () GameState
-initGame window = do
-  (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState
-  return $ GameState window renderCoreState immRenderState Matrix4.id newWorld
+main :: IO ()
+main = runApp app
+
+initGame :: Game AppContext Pong
+initGame = do
+  music <- siblingGame $ do
+    musicBuffer <- loadAudioFile "/home/jeanne/Casual Tiki Party Main.wav"
+    music <- makeSoundSource
+    setSoundSourceBuffer music musicBuffer
+    setSoundLoopMode music Loop
+    playSounds [music]
+    return music
+  return $ Pong Matrix4.id music newWorld
 
 endGame :: Game GameState ()
-endGame = do
-  game <- getGameState
-  runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)
+endGame = return ()
+
 
 step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
 step elapsed dt inputEvents = do
-  gs <- getGameState
-  let events = translateEvents inputEvents
-  modifyGameState $ \gs ->
-    gs
-      { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
-      }
+  appState  <- get
+  gameState <- getGameState
+  events    <- processInput (appWindow appState)
+  --when (events /= []) $ liftIO . putStrLn $ show events
+  modifyGameState $ \pong -> pong
+    { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gameState)
+    }
   return (not $ exitRequested inputEvents)
 
+processInput :: Window -> Game GameState [GameEvent]
+processInput window = processKeys window
+  [ (KEY_A, MoveLeft)
+  , (KEY_D, MoveRight)
+  ]
+
+exitRequested = elem (KeyDown KEY_ESC)
+
+
 render :: Game GameState ()
 render = do
   gameState <- getGameState
-  immRenderState' <- flip execSubGame (immRenderState gameState) $ do
+  siblingGame $ do
     immStart
     immSetViewProjectionMatrix (viewProjection gameState)
     -- Clear the background to a different colour than the playable area to make
     -- the latter distinguishable.
-    gameIO $ do
-      setClearColour (0.2, 0.2, 0.2, 0.0)
-      clearBuffers [ColourBuffer]
+    setClearColour (0.2, 0.2, 0.2, 0.0)
+    clearBuffers [ColourBuffer]
     render' $ world gameState
     immEnd
-  saveGameState $ gameState { immRenderState = immRenderState' }
 
 render' :: [GameObject] -> Game ImmRenderState ()
 render' world = do
@@ -79,7 +100,7 @@ renderBackground =
   let pmin = 0 :: Float
       pmax = 1 :: Float
   in do
-    immSetColour (vec4 0.6 0.35 0.6 1.0)
+    immSetColour (vec4 0.0 0.25 0.41 1.0)
     immDrawQuads2d [
       (vec2 pmin pmin
       ,vec2 pmax pmin
@@ -87,18 +108,16 @@ renderBackground =
       ,vec2 pmin pmax)]
 
 renderGO :: GameObject -> Game ImmRenderState ()
-renderGO go = do
-  let (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax)) = aabb go
-      (Vector2 xcenter ycenter) = position go
-  immPreservingMatrix $ do
-    immTranslate (vec3 xcenter ycenter 0)
+renderGO go =
+  let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume go
+  in
     immDrawQuads2d [
       (vec2 xmin ymin
       ,vec2 xmax ymin
       ,vec2 xmax ymax
       ,vec2 xmin ymax)]
 
--- TODO: Fix the resize hang.
+
 resize :: WindowEvent -> Game GameState ()
 resize (ResizeEvent w h) =
   let r = fromIntegral w / fromIntegral h
@@ -108,16 +127,7 @@ resize (ResizeEvent w h) =
       bottom = if r > 1 then 0 else -pad
       top    = if r > 1 then 1 else 1 + pad
   in do
-    gameIO $ setViewport 0 0 w h
-    modifyGameState $ \state -> state {
+    setViewport 0 0 w h
+    modifyGameState $ \pong -> pong {
       viewProjection = Matrix4.ortho left right bottom top (-1) 1
     }
-
-translateEvents = mapMaybe translateEvents'
-  where translateEvents' (KeyDown KEY_LEFT)  = Just MoveLeft
-        translateEvents' (KeyDown KEY_RIGHT) = Just MoveRight
-        translateEvents' (KeyUp KEY_LEFT)    = Just StopLeft
-        translateEvents' (KeyUp KEY_RIGHT)   = Just StopRight
-        translateEvents' _                   = Nothing
-
-exitRequested = elem (KeyDown KEY_ESC)
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs
index 104a92e..0df05ea 100644
--- a/Demos/Pong/Pong.hs
+++ b/Demos/Pong/Pong.hs
@@ -3,12 +3,11 @@
 {-# LANGUAGE TypeSynonymInstances  #-}
 
 module Pong
-  ( GameEvent (..),
-    GameObject,
-    newWorld,
-    stepWorld,
-    aabb,
-  )
+( GameEvent (..)
+, GameObject
+, newWorld
+, stepWorld
+)
 where
 
 import           Spear.Math.AABB
@@ -16,21 +15,23 @@ import           Spear.Math.Algebra
 import           Spear.Math.Spatial
 import           Spear.Math.Spatial2
 import           Spear.Math.Vector
+import           Spear.Physics.Collision
 import           Spear.Prelude
 import           Spear.Step
 
-import           Data.Monoid         (mconcat)
+import           Data.Monoid             (mconcat)
 
 
 -- Configuration
 
-padSize             = vec2 0.07 0.02
-ballSize            = 0.012 :: Float
-ballSpeed           = 0.6 :: Float
+padSize             = vec2 0.070 0.015
+ballSize            = vec2 0.012 0.012
+ballSpeed           = 0.7 :: Float
 initialBallVelocity = vec2 1 1
 maxBounceAngle      = (65::Float) * (pi::Float)/(180::Float)
 playerSpeed         = 1.0 :: Float
-enemySpeed          = 3.0 :: Float
+enemySpeed          = 7.0 :: Float
+enemyMomentum       = 1.0 :: Float
 initialEnemyPos     = vec2 0.5 0.9
 initialPlayerPos    = vec2 0.5 0.1
 initialBallPos      = vec2 0.5 0.5
@@ -40,16 +41,22 @@ initialBallPos      = vec2 0.5 0.5
 data GameEvent
   = MoveLeft
   | MoveRight
-  | StopLeft
-  | StopRight
-  deriving (Eq, Ord)
+  | Collision GameObjectId GameObjectId
+  deriving (Eq, Show)
 
 -- Game objects
 
+data GameObjectId
+  = Ball
+  | Enemy
+  | Player
+  deriving (Eq, Show)
+
 data GameObject = GameObject
-  { aabb   :: AABB2,
-    basis  :: Transform2,
-    gostep :: Step [GameObject] [GameEvent] GameObject GameObject
+  { gameObjectId   :: !GameObjectId
+  , gameObjectSize :: {-# UNPACK #-} !Vector2
+  , basis          :: {-# UNPACK #-} !Transform2
+  , gostep         :: Step [GameObject] [GameEvent] GameObject GameObject
   }
 
 
@@ -79,108 +86,113 @@ instance Spatial GameObject Vector2 Angle Transform2 where
   transform = basis
 
 
-stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
-stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
-
-update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
-update elapsed dt evts gos go =
-  let (go', s') = runStep (gostep go) elapsed dt gos evts go
-   in go' {gostep = s'}
+instance Bounded2 GameObject where
+  boundingVolume obj = aabb2Volume $ translate (position obj) (AABB2 (-size) size)
+    where size = gameObjectSize obj
 
-ballBox, padBox :: AABB2
-ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
-padBox = AABB2 (-padSize) padSize
 
 newWorld =
-  [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
-    GameObject padBox  (makeAt initialEnemyPos)  stepEnemy,
-    GameObject padBox  (makeAt initialPlayerPos) stepPlayer
+  [ GameObject Ball   ballSize (makeAt initialBallPos) $ stepBall initialBallVelocity,
+    GameObject Enemy  padSize  (makeAt initialEnemyPos)  stepEnemy,
+    GameObject Player padSize  (makeAt initialPlayerPos) stepPlayer
   ]
   where makeAt = newTransform2 unitx2 unity2
 
+
+-- Step the game world:
+--   1. Simulate physics.
+--   2. Collide objects and clip -> produce collision events.
+--   3. Update game objects      <- input collision events.
+stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
+stepWorld elapsed dt events gos@[ball, enemy, player] =
+  let
+    collisions = collide [ball] [enemy, player]
+    collisionEvents = (\(x,y) -> Collision (gameObjectId x) (gameObjectId y)) <$> collisions
+    events' = events ++ collisionEvents
+  in
+    map (update elapsed dt events' gos) gos
+
+update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
+update elapsed dt events gos go =
+  let (go', s') = runStep (gostep go) elapsed dt gos events go
+   in go' { gostep = s' }
+
+
 -- Ball steppers
 
-stepBall vel = collideBall vel .> moveBall
-
--- TODO: in collideBall and paddleBounce, we should an apply an offset to the
--- ball when collision is detected.
-collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
-collideBall vel = step $ \_ dt gos _ ball ->
-  let (AABB2 pmin pmax) = translate (position ball) (aabb ball)
-      collideSide = x pmin < 0 || x pmax > 1
-      collideBack = y pmin < 0 || y pmax > 1
-      collidePaddle = any (collide ball) (tail gos)
-      flipX v@(Vector2 x y) = if collideSide then vec2 (-x) y else v
-      flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v
-      vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel
-      -- A small delta to apply when collision occurs.
-      delta = (1::Float) + if collideSide || collideBack || collidePaddle then (2::Float)*dt else (0::Float)
-   in ((ballSpeed * delta * vel', ball), collideBall vel')
-
-paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2
-paddleBounce ball v paddle =
-  if collide ball paddle
+stepBall vel = bounceBall vel .> moveBall -- .> clamp
+
+bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
+bounceBall vel = step $ \_ dt gos events ball ->
+  let (AABB2Volume (AABB2 pmin pmax)) = boundingVolume ball
+      sideCollision = x pmin < 0 || x pmax > 1
+      backCollision = y pmin < 0 || y pmax > 1
+      flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v
+      flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v
+      collideWithPaddles vel = foldl (paddleBounce ball events) vel (tail gos)
+      vel' = normalise
+           . collideWithPaddles
+           . flipX
+           . flipY
+           $ vel
+      collision = vel' /= vel
+      -- Apply offset when collision occurs to avoid sticky collisions.
+      delta = (1::Float) + if collision then (3::Float)*dt else (0::Float)
+   in ((ballSpeed * delta * vel', ball), bounceBall vel')
+
+paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2
+paddleBounce ball events vel paddle =
+  let collision = Collision Ball (gameObjectId paddle) `elem` events
+  in if collision
   then
-    let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle)
+    let (AABB2Volume (AABB2 pmin pmax)) = boundingVolume paddle
         center = (x pmin + x pmax) / (2::Float)
         -- Normalized offset of the ball from the paddle's center, [-1, +1].
         -- It's outside the [-1, +1] range if there is no collision.
         offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float))
         angle  = offset * maxBounceAngle
         -- When it bounces off of a paddle, y vel is flipped.
-        ysign = -(signum (y v))
+        ysign = -(signum (y vel))
     in vec2 (sin angle) (ysign * cos angle)
-  else v
-
-collide :: GameObject -> GameObject -> Bool
-collide go1 go2 =
-  let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
-        translate (position go1) (aabb go1)
-      (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
-        translate (position go2) (aabb go2)
-   in not $
-        xmax1 < xmin2
-          || xmin1 > xmax2
-          || ymax1 < ymin2
-          || ymin1 > ymax2
+  else vel
 
 moveBall :: Step s e (Vector2, GameObject) GameObject
 moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
 
+
 -- Enemy stepper
 
-stepEnemy = movePad
+stepEnemy = movePad 0 .> spure clamp
+
+movePad :: Float -> Step [GameObject] e GameObject GameObject
+movePad previousMomentumVector = step $ \_ dt gos _ pad ->
+  let ball           = head gos
+      heading        = (x . position $ ball) - (x . position $ pad)
+      chaseVector    = enemySpeed * heading
+      momentumVector = previousMomentumVector + enemyMomentum * heading * dt
+      vx             = chaseVector * dt + momentumVector
+   in (translate (vec2 vx 0) pad, movePad momentumVector)
 
-movePad :: Step s e GameObject GameObject
-movePad = step $ \elapsed _ _ _ pad ->
-  let enemyY = 0.9
-      p = vec2 px enemyY
-      px =
-        (sin (enemySpeed * elapsed) * (0.5::Float) + (0.5::Float))
-          * ((1::Float) - (2::Float) * x padSize)
-          + x padSize
-   in (setPosition p pad, movePad)
 
 -- Player stepper
 
-stepPlayer = sfold moveGO .> clamp
+stepPlayer = sfold movePlayer .> spure clamp
 
-moveGO =
-  mconcat
-    [ switch StopLeft  sid MoveLeft  (moveGO' $ vec2 (-playerSpeed) 0),
-      switch StopRight sid MoveRight (moveGO' $ vec2   playerSpeed  0)
-    ]
+movePlayer = mconcat
+  [ swhen MoveLeft  $ movePlayer' (vec2 (-playerSpeed) 0)
+  , swhen MoveRight $ movePlayer' (vec2   playerSpeed  0)
+  ]
 
-moveGO' :: Vector2 -> Step s e GameObject GameObject
-moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir)
+movePlayer' :: Vector2 -> Step s e GameObject GameObject
+movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir)
 
-clamp :: Step s e GameObject GameObject
-clamp = spure $ \go ->
-  let p' = vec2 (clamp' x s (1 - s)) y
+clamp :: GameObject -> GameObject
+clamp go =
+  let p' = vec2 (clamp' x sx (1 - sx)) y
       (Vector2 x y) = position go
       clamp' x a b
         | x < a = a
         | x > b = b
         | otherwise = x
-      (Vector2 s _) = padSize
+      (Vector2 sx _) = gameObjectSize go
    in setPosition p' go
diff --git a/README.md b/README.md
index 386250d..3296c35 100644
--- a/README.md
+++ b/README.md
@@ -12,9 +12,7 @@ Installation (Ubuntu)
 Install dependencies, then build with cabal:

 

 ```

-$ sudo apt install libxxf86vm-dev libglfw3-dev

-$ git clone https://github.com/jeannekamikaze/Spear.git

-$ cd Spear

+$ sudo apt install libxxf86vm-dev libglfw3-dev libopenal-dev libopenalut-dev

 $ cabal build

 ```

 

diff --git a/Spear.cabal b/Spear.cabal
index b044ae2..56eb302 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -14,6 +14,8 @@ data-dir: ""
 library

     build-depends:

       GLFW-b -any,

+      OpenAL -any,

+      ALUT -any,

       OpenGL >= 3,

       OpenGLRaw -any,

       StateVar -any,

@@ -21,9 +23,11 @@ library
       bytestring -any,

       directory -any,

       exceptions -any,

+      file-embed -any,

       hashable -any,

       hashmap -any,

       mtl -any,

+      text -any,

       transformers -any,

       resourcet -any,

       parsec >= 3,

@@ -62,6 +66,8 @@ library
       Spear.Math.Vector.Vector2

       Spear.Math.Vector.Vector3

       Spear.Math.Vector.Vector4

+      Spear.Physics.Collision

+      Spear.Physics.RigidBody

       Spear.Prelude

       Spear.Render.AnimatedModel

       Spear.Render.Core

@@ -75,10 +81,13 @@ library
       Spear.Render.Material

       Spear.Render.Model

       Spear.Render.Program

+      Spear.Render.Shaders

       Spear.Render.StaticModel

       Spear.Scene.Graph

       Spear.Scene.Loader

       Spear.Scene.SceneResources

+      Spear.Sound.Sound

+      Spear.Sound.State

       Spear.Step

       Spear.Sys.Store

       Spear.Sys.Store.ID

@@ -91,8 +100,6 @@ library
 

     build-tools: hsc2hs -any

 

-    cc-options: -O2 -g -Wno-unused-result

-

     c-sources:

       Spear/Assets/Image/Image.c

       Spear/Assets/Image/BMP/BMP_load.c

@@ -123,18 +130,26 @@ library
       Spear/Assets/Image

       Spear/Assets/Image/BMP

       Spear/Assets/Model

-      Spear/Contrib/glad/include/

       Spear/Render

       Spear/Sys

 

     hs-source-dirs: .

 

-    ghc-options: -O2

-

-    ghc-prof-options: -O2 -fprof-auto -fprof-cafs

+    cc-options:       -O2 -Wno-unused-result

+    ghc-options:      -O2

+    ghc-prof-options: -O2 -g -fprof-auto -fprof-cafs

 

 executable pong

   hs-source-dirs:      Demos/Pong

   main-is:             Main.hs

   other-modules:       Pong

-  build-depends:       base, Spear, OpenGL

+  build-depends:       base, Spear

+  ghc-options:         -O2

+  ghc-prof-options:    -O2 -g -fprof-auto -fprof-cafs

+

+executable balls

+  hs-source-dirs:      Demos/Balls

+  main-is:             Main.hs

+  build-depends:       base, Spear

+  ghc-options:         -O2

+  ghc-prof-options:    -O2 -g -fprof-auto -fprof-cafs

diff --git a/Spear/App.hs b/Spear/App.hs
index f70dd06..e85c46b 100644
--- a/Spear/App.hs
+++ b/Spear/App.hs
@@ -1,20 +1,35 @@
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module Spear.App
-  ( App(..),
-    Elapsed,
-    Dt,
-    Step,
-    loop,
-  )
+( App(..)
+, AppOptions(..)
+, AppContext(..)
+, AppState(..)
+, Elapsed
+, Dt
+, Step
+, defaultAppOptions
+, getGameState
+, putGameState
+, modifyGameState
+, runApp
+, loop
+)
 where
 
-import           Control.Monad
-import           Data.Fixed      (mod')
-import           GHC.Float
 import           Spear.Game
-import           Spear.Sys.Timer as Timer
+import           Spear.Render.Core.State
+import           Spear.Render.Immediate
+import           Spear.Sound.Sound
+import           Spear.Sound.State
+import           Spear.Sys.Timer         as Timer
 import           Spear.Window
 
-maxFPS = 60
+import           Control.Monad
+import           Data.Fixed              (mod')
+import           GHC.Float
+
 
 -- | Time elapsed.
 type Elapsed = Double
@@ -25,68 +40,217 @@ type Dt = Double
 -- | Return true if the application should continue running, false otherwise.
 type Step s = Elapsed -> Dt -> [InputEvent] -> Game s Bool
 
--- | Application functions.
+-- | Application options.
+--
+-- Use `defaultOptions` for default options.
+data AppOptions = AppOptions
+  { title           :: String
+  , windowWidth     :: Int
+  , windowHeight    :: Int
+  , maxFPS          :: Int
+  , animationFPS    :: Int
+  , enableProfiling :: Bool
+  }
+
+-- | Default application options.
+defaultAppOptions = AppOptions
+  { title           = "Spear Application"
+  , windowWidth     = 1920
+  , windowHeight    = 1080
+  , maxFPS          = 0  -- If non-zero, cap frame rate to this value.
+  , animationFPS    = 60 -- If non-zero, use fixed time step animation.
+  , enableProfiling = False
+  }
+
+-- | Application descriptor.
 data App s = App
-  { stepApp   :: Step s
-  , renderApp :: Game s ()
-  , resizeApp :: WindowEvent -> Game s ()
+  { appOptions :: AppOptions
+  , initApp    :: Game AppContext s
+  , endApp     :: Game (AppState s) ()
+  , stepApp    :: Step (AppState s)
+  , renderApp  :: Game (AppState s) ()
+  , resizeApp  :: WindowEvent -> Game (AppState s) ()
+  }
+
+-- | Application context.
+--
+-- The application context is the initial state from which the application's
+-- `AppState` is bootstrapped with `initApp`.
+data AppContext = AppContext
+  { contextWindow          :: Window
+  , contextRenderCoreState :: RenderCoreState
+  , contextSoundState      :: SoundState
+  , contextImmRenderState  :: ImmRenderState
+  }
+
+instance HasState AppContext RenderCoreState where
+  getInnerState = contextRenderCoreState
+  setInnerState context state = context { contextRenderCoreState = state }
+
+instance HasState AppContext SoundState where
+  getInnerState = contextSoundState
+  setInnerState context state = context { contextSoundState = state }
+
+instance HasState AppContext ImmRenderState where
+  getInnerState = contextImmRenderState
+  setInnerState context state = context { contextImmRenderState = state }
+
+-- | Application state.
+data AppState s = AppState
+  { appWindow          :: Window
+  , appRenderCoreState :: RenderCoreState
+  , appSoundState      :: SoundState
+  , appImmRenderState  :: ImmRenderState
+  , appCustomState     :: s
   }
 
+-- Requires FlexibleInstances.
+instance HasState (AppState s) s where
+  getInnerState = appCustomState
+  setInnerState appState state = appState { appCustomState = state }
+
+instance HasState (AppState s) RenderCoreState where
+  getInnerState = appRenderCoreState
+  setInnerState appState state = appState { appRenderCoreState = state }
+
+instance HasState (AppState s) SoundState where
+  getInnerState = appSoundState
+  setInnerState appState state = appState { appSoundState = state }
+
+instance HasState (AppState s) ImmRenderState where
+  getInnerState = appImmRenderState
+  setInnerState appState state = appState { appImmRenderState = state }
+
+
+-- | Get the custom state in the app state.
+getGameState :: Game (AppState s) s
+getGameState = appCustomState <$> get
+
+-- | Put the custom state in the app state.
+putGameState :: s -> Game (AppState s) ()
+putGameState custom = do
+  appState <- get
+  put $ appState { appCustomState = custom }
+
+-- | Modify the custom state in the app state.
+modifyGameState :: (s -> s) -> Game (AppState s) ()
+modifyGameState f = modify $ \appState -> appState { appCustomState = f (appCustomState appState )}
+
+-- | Run the application.
+runApp :: App s -> IO ()
+runApp app =
+  let ops = appOptions app
+      w = windowWidth  ops
+      h = windowHeight ops
+  in -- Initialize subsystems.
+    withWindow (w, h) (title ops) $ \window ->
+      withSoundContext $ eval runGame () $ do
+        -- Create initial context.
+        -- We could modify function signatures such as:
+        --   newImmRenderer :: HasState s RenderCoreState => Game s ImmRenderState
+        -- to simplify things a bit. But I'm not sure I want HasState to
+        -- proliferate like that right now.
+        initialSoundState <- eval runSiblingGame () initSoundSystem
+        (immRenderState, renderCoreState) <- runSiblingGame newRenderCoreState newImmRenderer
+        let context = AppContext window renderCoreState initialSoundState immRenderState
+        -- Create initial app state.
+        (gameState, context') <- runSiblingGame context (initApp app)
+        let appState = AppState {
+          appWindow          = contextWindow context'
+        , appRenderCoreState = contextRenderCoreState context'
+        , appSoundState      = contextSoundState context'
+        , appImmRenderState  = contextImmRenderState context'
+        , appCustomState     = gameState
+        }
+        -- Run app.
+        (result, endAppState) <- runChildGame appState $ do
+          loop app window
+          endApp app
+        -- Shut down.
+        exec' runSiblingGame (appRenderCoreState endAppState) $ deleteImmRenderer (appImmRenderState endAppState)
+        exec' runSiblingGame (appSoundState endAppState) destroySoundSystem
+
 -- | Enter the main application loop.
-loop :: App s -> Window -> Game s ()
+loop :: App s -> Window -> Game (AppState s) ()
 loop app window = do
   -- For convenience, trigger an initial resize followed by a render of the
   -- application's initial state.
-  (width, height) <- gameIO $ getWindowSize window
+  (width, height) <- getWindowSize window
   resizeApp app (ResizeEvent width height)
   renderApp app
 
-  let ddt = secToTimeDelta $ 1.0 / fromIntegral maxFPS -- Desired delta time.
-  timer <- gameIO newTimer
-  gameIO $ Timer.start timer
-  loop' window ddt timer 0 0 app
+  let ddt          = fpsToDdt .       maxFPS . appOptions $ app -- Desired render time step.
+  let animationDdt = fpsToDdt . animationFPS . appOptions $ app -- Desired animation time step.
+
+  timer <- newTimer
+  Timer.start timer
+  let lastAnimationTime = lastTick timer
+  loop' window ddt animationDdt lastAnimationTime timer app
 
 loop' ::
   Window ->
-  TimeDelta -> -- Desired frame delta time.
+  TimeDelta -> -- Desired render time delta.
+  TimeDelta -> -- Desired animation time delta.
+  TimePoint -> -- Time point of last animation update.
   Timer ->
-  TimeDelta -> -- Total elapsed app time.
-  TimeDelta -> -- Time budget.
   App s ->
-  Game s ()
-loop' window ddt inputTimer elapsed timeBudget app = do
-  timer <- gameIO $ tick inputTimer
-
-  let timeBudgetThisFrame = timeBudget + deltaTime timer
-  let steps = timeBudgetThisFrame `div` ddt
-
-  continue <- and <$> forM [1..steps] (\i -> do
-    let t  = timeDeltaToSec $ elapsed + i * ddt
-    let dt = timeDeltaToSec ddt
-    inputEvents <- gameIO $ pollInputEvents window
-    stepApp app t dt inputEvents)
-
-  let elapsed' = elapsed + steps * ddt
-  let timeBudget' = timeBudgetThisFrame `mod` ddt
-
-  when continue $ do
-    windowEvents <- gameIO $ pollWindowEvents window
-    forM_ windowEvents $ \event -> case event of
-      ResizeEvent {} -> resizeApp app event
+  Game (AppState s) ()
+loop' window renderDdt animationDdt lastAnimationTime inputTimer app = do
+  timer        <- tick inputTimer
+  windowEvents <- pollWindowEvents window
+  close        <- shouldWindowClose window
+
+  (continue, lastAnimationTimeNextFrame) <- case animationDdt of
+    0 -> do
+      -- Variable time step game animation.
+      let t  = timeDeltaToSec $ runningTime timer
+      let dt = timeDeltaToSec $ deltaTime   timer
+      inputEvents <- pollInputEvents window
+      continue <- stepApp app t dt inputEvents
+      return (continue, lastAnimationTime)
+
+    _ -> do
+      -- Fixed time step animation.
+      let ddt = animationDdt
+      {- let elapsed = runningTime timer
+      let dt = timeDeltaToSec ddt
+      let timeBudgetThisFrame = timeBudget + deltaTime timer
+      let timeBudgetNextFrame = timeBudgetThisFrame `mod` ddt
+      let steps = timeBudgetThisFrame `div` ddt -}
+      --liftIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt
+      let elapsed = runningTime timer
+      let dt = timeDeltaToSec ddt
+      let timeBudgetThisFrame = timeDiff lastAnimationTime (lastTick timer)
+      let steps = timeBudgetThisFrame `div` ddt
+      let lastAnimationTimeNextFrame = timeAdd lastAnimationTime (steps * ddt)
+      --liftIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt
+      continue <- and <$> forM [1..steps] (\i -> do
+        inputEvents <- pollInputEvents window
+        let t = timeDeltaToSec $ elapsed + i * ddt
+        stepApp app t dt inputEvents)
+      return (continue, lastAnimationTimeNextFrame)
+
+  -- Process window events.
+  resized <- or <$> forM windowEvents (\event -> case event of
+    ResizeEvent {} -> resizeApp app event >> return True)
+
+  -- For smoother resizing, render only while not resizing.
+  unless resized $ do
     renderApp app
-    gameIO $ swapBuffers window
+    swapBuffers window
 
-    frameEnd <- gameIO now
+  -- Limit frame rate if so requested by the application.
+  -- This currently makes the rendering stutter and is not very desirable.
+  when ((maxFPS . appOptions $ app) > 0) $ do
+    frameEnd <- now
+    let ddt = renderDdt
     let frameTime = timeDiff (lastTick timer) frameEnd
     when (frameTime < ddt) $ do
-      gameIO $ Timer.sleep (ddt - frameTime)
-
-    close <- gameIO $ shouldWindowClose window
-    when (continue && not close) $
-      loop'
-        window
-        ddt
-        timer
-        elapsed'
-        timeBudget'
-        app
+      Timer.sleep (ddt - frameTime)
+
+  when (continue && not close) $ do
+    loop' window renderDdt animationDdt lastAnimationTimeNextFrame timer app
+
+-- | Convert FPS to desired delta time.
+fpsToDdt :: Int -> TimeDelta
+fpsToDdt fps = if fps > 0 then secToTimeDelta (1.0 / fromIntegral fps) else 0
diff --git a/Spear/Assets/Image.hsc b/Spear/Assets/Image.hsc
index f9fc025..db90afe 100644
--- a/Spear/Assets/Image.hsc
+++ b/Spear/Assets/Image.hsc
@@ -46,24 +46,24 @@ data CImage = CImage
 instance Storable CImage where

     sizeOf _    = #{size Image}

     alignment _ = alignment (undefined :: CInt)

-    

+

     peek ptr = do

         width  <- #{peek Image, width}  ptr

         height <- #{peek Image, height} ptr

         bpp    <- #{peek Image, bpp}    ptr

         pixels <- #{peek Image, pixels} ptr

         return $ CImage width height bpp pixels

-    

+

     poke ptr (CImage width height bpp pixels) = do

         #{poke Image, width}  ptr width

         #{poke Image, height} ptr height

         #{poke Image, bpp}    ptr bpp

         #{poke Image, pixels} ptr pixels

 

--- | Represents an image 'Resource'.

+-- | An image resource.

 data Image = Image

     { imageData :: CImage

-    , rkey      :: Resource

+    , rkey      :: ReleaseKey

     }

 

 instance ResourceClass Image where

@@ -84,15 +84,15 @@ loadImage file = do
     dotPos <- case elemIndex '.' file of

             Nothing -> gameError $ "file name has no extension: " ++ file

             Just p  -> return p

-    

+

     let ext = map toLower . tail . snd $ splitAt dotPos file

-    

-    result <- gameIO . alloca $ \ptr -> do

+

+    result <- liftIO . alloca $ \ptr -> do

         status <- withCString file $ \fileCstr -> do

             case ext of

                 "bmp" -> bmp_load fileCstr ptr

                 _     -> return ImageNoSuitableLoader

-        

+

         case status of

             ImageSuccess               -> peek ptr >>= return . Right

             ImageReadError             -> return . Left $ "read error"

@@ -100,7 +100,7 @@ loadImage file = do
             ImageFileNotFound          -> return . Left $ "file not found"

             ImageInvalidFormat         -> return . Left $ "invalid format"

             ImageNoSuitableLoader      -> return . Left $ "no suitable loader for extension " ++ ext

-        

+

     case result of

         Right image -> register (freeImage image) >>= return . Image image

         Left  err   -> gameError $ "loadImage: " ++ err

diff --git a/Spear/Assets/Model.hsc b/Spear/Assets/Model.hsc
index 74666f2..02e1edf 100644
--- a/Spear/Assets/Model.hsc
+++ b/Spear/Assets/Model.hsc
@@ -65,12 +65,12 @@ data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float
 instance Storable Vec2 where

     sizeOf _ = 2*sizeFloat

     alignment _ = alignment (undefined :: CFloat)

-    

+

     peek ptr = do

         f0 <- peekByteOff ptr 0

         f1 <- peekByteOff ptr sizeFloat

         return $ Vec2 f0 f1

-    

+

     poke ptr (Vec2 f0 f1) = do

         pokeByteOff ptr 0         f0

         pokeByteOff ptr sizeFloat f1

@@ -81,13 +81,13 @@ data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Flo
 instance Storable Vec3 where

     sizeOf _ = 3*sizeFloat

     alignment _ = alignment (undefined :: CFloat)

-    

+

     peek ptr = do

         f0 <- peekByteOff ptr 0

         f1 <- peekByteOff ptr sizeFloat

         f2 <- peekByteOff ptr (2*sizeFloat)

         return $ Vec3 f0 f1 f2

-    

+

     poke ptr (Vec3 f0 f1 f2) = do

         pokeByteOff ptr 0             f0

         pokeByteOff ptr sizeFloat     f1

@@ -99,12 +99,12 @@ data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float
 instance Storable TexCoord where

     sizeOf _ = 2*sizeFloat

     alignment _ = alignment (undefined :: CFloat)

-    

+

     peek ptr = do

         f0 <- peekByteOff ptr 0

         f1 <- peekByteOff ptr sizeFloat

         return $ TexCoord f0 f1

-    

+

     poke ptr (TexCoord f0 f1) = do

         pokeByteOff ptr 0         f0

         pokeByteOff ptr sizeFloat f1

@@ -122,23 +122,23 @@ data CTriangle = CTriangle
 instance Storable CTriangle where

     sizeOf _ = #{size triangle}

     alignment _ = alignment (undefined :: CUShort)

-    

+

     peek ptr = do

         v0 <- #{peek triangle, vertexIndices[0]} ptr

         v1 <- #{peek triangle, vertexIndices[1]} ptr

         v2 <- #{peek triangle, vertexIndices[2]} ptr

-        

+

         t0 <- #{peek triangle, textureIndices[0]} ptr

         t1 <- #{peek triangle, textureIndices[1]} ptr

         t2 <- #{peek triangle, textureIndices[2]} ptr

-        

+

         return $ CTriangle v0 v1 v2 t0 t1 t2

-    

+

     poke ptr (CTriangle v0 v1 v2 t0 t1 t2) = do

         #{poke triangle, vertexIndices[0]} ptr v0

         #{poke triangle, vertexIndices[1]} ptr v1

         #{poke triangle, vertexIndices[2]} ptr v2

-        

+

         #{poke triangle, textureIndices[0]} ptr t0

         #{poke triangle, textureIndices[1]} ptr t1

         #{poke triangle, textureIndices[2]} ptr t2

@@ -149,7 +149,7 @@ data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3
 instance Storable Box where

     sizeOf _ = 6 * sizeFloat

     alignment _ = alignment (undefined :: CFloat)

-    

+

     peek ptr = do

         xmin <- peekByteOff ptr 0

         ymin <- peekByteOff ptr sizeFloat

@@ -158,7 +158,7 @@ instance Storable Box where
         ymax <- peekByteOff ptr $ 4*sizeFloat

         zmax <- peekByteOff ptr $ 5*sizeFloat

         return $ Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)

-    

+

     poke ptr (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = do

         pokeByteOff ptr 0             xmin

         pokeByteOff ptr sizeFloat     ymin

@@ -173,11 +173,11 @@ newtype Skin = Skin { skinName :: B.ByteString }
 instance Storable Skin where

     sizeOf (Skin s) = 64

     alignment _ = 1

-    

+

     peek ptr = do

         s <- B.packCString $ unsafeCoerce ptr

         return $ Skin s

-    

+

     poke ptr (Skin s) = do

         B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len

 

@@ -193,13 +193,13 @@ data Animation = Animation
 instance Storable Animation where

     sizeOf _    = #{size animation}

     alignment _ = alignment (undefined :: CUInt)

-    

+

     peek ptr = do

         name  <- B.packCString (unsafeCoerce ptr)

         start <- #{peek animation, start} ptr

         end   <- #{peek animation, end}   ptr

         return $ Animation name start end

-    

+

     poke ptr (Animation name start end) = do

         B.useAsCStringLen name $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len

         #{poke animation, start} ptr start

@@ -224,7 +224,7 @@ data Model = Model
 instance Storable Model where

     sizeOf _    = #{size Model}

     alignment _ = alignment (undefined :: CUInt)

-    

+

     peek ptr = do

         numFrames     <- #{peek Model, numFrames}     ptr

         numVertices   <- #{peek Model, numVertices}   ptr

@@ -232,7 +232,7 @@ instance Storable Model where
         numTexCoords  <- #{peek Model, numTexCoords}  ptr

         numSkins      <- #{peek Model, numSkins}      ptr

         numAnimations <- #{peek Model, numAnimations} ptr

-        pVerts        <- peek (unsafeCoerce ptr) 

+        pVerts        <- peek (unsafeCoerce ptr)

         pNormals      <- peekByteOff ptr sizePtr

         pTexCoords    <- peekByteOff ptr (2*sizePtr)

         pTriangles    <- peekByteOff ptr (3*sizePtr)

@@ -247,7 +247,7 @@ instance Storable Model where
         return $

             Model vertices normals texCoords triangles skins animations

                   numFrames numVertices numTriangles numTexCoords numSkins numAnimations

-    

+

     poke ptr

         (Model verts normals texCoords tris skins animations

          numFrames numVerts numTris numTex numSkins numAnimations) =

@@ -288,7 +288,7 @@ data Triangle = Triangle
 instance Storable Triangle where

     sizeOf _ = #{size model_triangle}

     alignment _ = alignment (undefined :: Float)

-    

+

     peek ptr = do

         v0 <- #{peek model_triangle, v0} ptr

         v1 <- #{peek model_triangle, v1} ptr

@@ -300,7 +300,7 @@ instance Storable Triangle where
         t1 <- #{peek model_triangle, t1} ptr

         t2 <- #{peek model_triangle, t2} ptr

         return $ Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2

-    

+

     poke ptr (Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2) = do

         #{poke model_triangle, v0} ptr v0

         #{poke model_triangle, v1} ptr v1

@@ -335,16 +335,16 @@ loadModel file = do
     dotPos <- case elemIndex '.' file of

             Nothing -> gameError $ "file name has no extension: " ++ file

             Just p  -> return p

-    

+

     let ext = map toLower . tail . snd $ splitAt dotPos file

-    

-    result <- gameIO . alloca $ \ptr -> do

+

+    result <- liftIO . alloca $ \ptr -> do

         status <- withCString file $ \fileCstr -> do

             case ext of

                 "md2" -> md2_load fileCstr 0 0 ptr

                 "obj" -> obj_load fileCstr 0 0 ptr

                 _     -> return ModelNoSuitableLoader

-        

+

         case status of

             ModelSuccess -> do

                 model <- peek ptr

@@ -355,7 +355,7 @@ loadModel file = do
             ModelFileNotFound           -> return . Left $ "file not found"

             ModelFileMismatch           -> return . Left $ "file mismatch"

             ModelNoSuitableLoader       -> return . Left $ "no suitable loader for extension " ++ ext

-    

+

     case result of

         Right model -> return model

         Left err    -> gameError $ "loadModel: " ++ err

@@ -392,7 +392,7 @@ transformVerts model f = model { vertices = vertices' }
     where

         n = numVerts model * numFrames model

         vertices' = S.generate n f'

-        f' i = f $ vertices model S.! i 

+        f' i = f $ vertices model S.! i

 

 -- | Transform the model's normals.

 transformNormals :: Model -> (Vec3 -> Vec3) -> Model

@@ -400,14 +400,14 @@ transformNormals model f = model { normals = normals' }
     where

         n = numVerts model * numFrames model

         normals' = S.generate n f'

-        f' i = f $ normals model S.! i 

+        f' i = f $ normals model S.! i

 

 -- | Translate the model such that its lowest point has y = 0.

 toGround :: Model -> IO Model

 toGround model =

     let model' = model { vertices = S.generate n $ \i -> vertices model S.! i }

         n = numVerts model * numFrames model

-    in    

+    in

         with model' model_to_ground >> return model'

 

 foreign import ccall "Model.h model_to_ground"

diff --git a/Spear/GL.hs b/Spear/GL.hs
index f463109..3c1734b 100644
--- a/Spear/GL.hs
+++ b/Spear/GL.hs
@@ -36,7 +36,7 @@ module Spear.GL
     Data.StateVar.get,

 

     -- * VAOs

-    VAO,

+    VAO(..),

     newVAO,

     bindVAO,

     unbindVAO,

@@ -48,7 +48,7 @@ module Spear.GL
     drawElements,

 

     -- * Buffers

-    GLBuffer,

+    GLBuffer(..),

     TargetBuffer (..),

     BufferUsage (..),

     newBuffer,

@@ -122,7 +122,7 @@ import           Unsafe.Coerce
 -- | A GLSL shader handle.

 data GLSLShader = GLSLShader

   { getShader    :: GLuint,

-    getShaderKey :: Resource

+    getShaderKey :: ReleaseKey

   }

 

 instance ResourceClass GLSLShader where

@@ -131,7 +131,7 @@ instance ResourceClass GLSLShader where
 -- | A GLSL program handle.

 data GLSLProgram = GLSLProgram

   { getProgram    :: GLuint,

-    getProgramKey :: Resource

+    getProgramKey :: ReleaseKey

   }

 

 instance ResourceClass GLSLProgram where

@@ -173,11 +173,11 @@ attribLocation prog var = makeStateVar get set
 -- | Create a new program.

 newProgram :: [GLSLShader] -> Game s GLSLProgram

 newProgram shaders = do

-  h <- gameIO glCreateProgram

+  h <- liftIO glCreateProgram

   when (h == 0) $ gameError "glCreateProgram failed"

   rkey <- register $ deleteProgram h

   let program = GLSLProgram h rkey

-  mapM_ (gameIO . attachShader program) shaders

+  mapM_ (liftIO . attachShader program) shaders

   linkProgram program

   return program

 

@@ -192,7 +192,7 @@ deleteProgram prog = do
 linkProgram :: GLSLProgram -> Game s ()

 linkProgram prog = do

   let h = getProgram prog

-  err <- gameIO $ do

+  err <- liftIO $ do

     glLinkProgram h

     alloca $ \statptr -> do

       glGetProgramiv h GL_LINK_STATUS statptr

@@ -235,7 +235,7 @@ loadShader shaderType file = do
 -- | Create a new shader.

 newShader :: ShaderType -> Game s GLSLShader

 newShader shaderType = do

-  h <- gameIO $ glCreateShader (toGLShader shaderType)

+  h <- liftIO $ glCreateShader (toGLShader shaderType)

   case h of

     0 -> gameError "glCreateShader failed"

     _ -> do

@@ -253,10 +253,10 @@ deleteShader shader = do
 -- into the shader.

 loadSource :: FilePath -> GLSLShader -> Game s ()

 loadSource file h = do

-  exists <- gameIO $ doesFileExist file

+  exists <- liftIO $ doesFileExist file

   case exists of

     False -> gameError "the specified shader file does not exist"

-    True -> gameIO $ do

+    True -> liftIO $ do

       code <- readSource file

       withCString code $ shaderSource h

 

@@ -272,10 +272,10 @@ compile file shader = do
   let h = getShader shader

 

   -- Compile

-  gameIO $ glCompileShader h

+  liftIO $ glCompileShader h

 

   -- Verify status

-  err <- gameIO $

+  err <- liftIO $

     alloca $ \statusPtr -> do

       glGetShaderiv h GL_COMPILE_STATUS statusPtr

       result <- peek statusPtr

@@ -438,7 +438,7 @@ instance Uniform [Int] where
 -- | A vertex array object.

 data VAO = VAO

   { getVAO :: GLuint,

-    vaoKey :: Resource

+    vaoKey :: ReleaseKey

   }

 

 instance ResourceClass VAO where

@@ -454,7 +454,7 @@ instance Ord VAO where
 -- | Create a new vao.

 newVAO :: Game s VAO

 newVAO = do

-  h <- gameIO . alloca $ \ptr -> do

+  h <- liftIO . alloca $ \ptr -> do

     glGenVertexArrays 1 ptr

     peek ptr

 

@@ -533,11 +533,11 @@ drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
 -- | An OpenGL buffer.

 data GLBuffer = GLBuffer

   { getBuffer :: GLuint,

-    rkey      :: Resource

+    bufferKey :: ReleaseKey

   }

 

 instance ResourceClass GLBuffer where

-  getResource = rkey

+  getResource = bufferKey

 

 -- | The type of target buffer.

 data TargetBuffer

@@ -580,7 +580,7 @@ fromUsage DynamicCopy = GL_DYNAMIC_COPY
 -- | Create a new buffer.

 newBuffer :: Game s GLBuffer

 newBuffer = do

-  h <- gameIO . alloca $ \ptr -> do

+  h <- liftIO . alloca $ \ptr -> do

     glGenBuffers 1 ptr

     peek ptr

 

@@ -656,7 +656,7 @@ withGLBuffer buf f = f $ getBuffer buf
 -- | Represents a texture resource.

 data Texture = Texture

   { getTex :: GLuint,

-    texKey :: Resource

+    texKey :: ReleaseKey

   }

 

 instance Eq Texture where

@@ -672,7 +672,7 @@ instance ResourceClass Texture where
 -- | Create a new texture.

 newTexture :: Game s Texture

 newTexture = do

-  tex <- gameIO . alloca $ \ptr -> do

+  tex <- liftIO . alloca $ \ptr -> do

     glGenTextures 1 ptr

     peek ptr

 

@@ -697,7 +697,7 @@ loadTextureImage ::
 loadTextureImage file minFilter magFilter = do

   image <- loadImage file

   tex <- newTexture

-  gameIO $ do

+  liftIO $ do

     let w = width image

         h = height image

         pix = pixels image

@@ -794,7 +794,7 @@ printGLError =
 assertGL :: Game s a -> String -> Game s a

 assertGL action err = do

   result <- action

-  status <- gameIO getGLError

+  status <- liftIO getGLError

   case status of

     Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str

     Nothing  -> return result

diff --git a/Spear/Game.hs b/Spear/Game.hs
index 14e3f20..ae986c8 100644
--- a/Spear/Game.hs
+++ b/Spear/Game.hs
@@ -1,143 +1,141 @@
+{-# LANGUAGE FlexibleInstances          #-}

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

+{-# LANGUAGE MultiParamTypeClasses      #-}

+

 module Spear.Game

-  ( Game,

-    GameException (..),

-    Resource,

-    ResourceClass (..),

-

-    -- * Game state

-    getGameState,

-    saveGameState,

-    modifyGameState,

-

-    -- * Game resources

-    register,

-    release,

-    release',

-

-    -- * Error handling

-    gameError,

-    assertMaybe,

-    catchGameError,

-    catchGameErrorFinally,

-

-    -- * Running and IO

-    runGame,

-    evalGame,

-    runSubGame,

-    runSubGame',

-    evalSubGame,

-    execSubGame,

-    runSiblingGame,

-    runSiblingGame',

-    evalSiblingGame,

-    execSiblingGame,

-    gameIO,

-  )

+( Game

+, GameException(..)

+, HasState(..)

+, ResourceClass(..)

+, ReleaseKey

+  -- * Game state

+, get

+, put

+, modify

+  -- * Game resources

+, register

+, release

+, release'

+  -- * Error handling

+, gameError

+, assertMaybe

+, catch

+  -- * Running and IO

+, runGame

+, runChildGame

+, runSiblingGame

+, eval

+, exec

+, exec'

+, siblingGame

+, liftIO

+)

 where

 

 import           Control.Monad.Catch

 import           Control.Monad.State.Strict

 import           Control.Monad.Trans.Class    (lift)

-import qualified Control.Monad.Trans.Resource as R

-

+import           Control.Monad.Trans.Resource

 

-type Resource = R.ReleaseKey

 

+-- | Anything that holds a resource.

+--

+-- This is a convenient wrapper so that we can define the general `release'`

+-- function on any type of resource.

 class ResourceClass a where

-  getResource :: a -> Resource

-

-type Game s = StateT s (R.ResourceT IO)

+  getResource :: a -> ReleaseKey

 

+-- | A game exception.

+--

+-- This is mostly a convenient wrapper around `String` so that we can throw

+-- strings directly with `gameError`.

 newtype GameException = GameException String deriving (Show)

 

 instance Exception GameException

 

+-- | The game monad.

+--

+-- The game monad performs three different roles:

+--

+--   1. I/O

+--   2. Resource management.

+--   3. State management.

+newtype Game s a = Game { getGame :: StateT s (ResourceT IO) a }

+  deriving

+  ( Functor

+  , Applicative

+  , Monad

+  , MonadIO

+  , MonadThrow

+  , MonadCatch

+  , MonadState s

+  , MonadResource

+  )

 

--- | Retrieve the game state.

-getGameState :: Game s s

-getGameState = get

-

--- | Save the game state.

-saveGameState :: s -> Game s ()

-saveGameState = put

-

--- | Modify the game state.

-modifyGameState :: (s -> s) -> Game s ()

-modifyGameState = modify

+-- | A class used to define state hierarchies.

+--

+-- By declaring `HasState s t`, a `Game s` monad can then execute actions of a

+-- `Game t` monad more conveniently with `siblingGame`.

+class HasState s t where

+  getInnerState :: s -> t

+  setInnerState :: s -> t -> s

 

--- | Register the given cleaner.

-register :: IO () -> Game s Resource

-register = lift . R.register

+-- Identity instance.

+instance HasState s s where

+  getInnerState = id

+  setInnerState s s' = s'

 

--- | Release the given 'Resource'.

-release :: ResourceClass a => a -> Game s ()

-release = lift . R.release . getResource

 

 -- | Release the given 'Resource'.

-release' :: ResourceClass a => a -> IO ()

-release' = R.release . getResource

+release' :: ResourceClass a => a -> Game s ()

+release' = release . getResource

 

 -- | Throw an error from the 'Game' monad.

 gameError :: String -> Game s a

-gameError = gameError' . GameException

-

--- | Throw an error from the 'Game' monad.

-gameError' :: GameException -> Game s a

-gameError' = lift . lift . throwM

+gameError = throwM . GameException

 

 -- | Throw the given error if given 'Nothing'.

 assertMaybe :: Maybe a -> GameException -> Game s a

-assertMaybe Nothing err = gameError' err

+assertMaybe Nothing err = throwM err

 assertMaybe (Just x) _  = return x

 

--- | Run the given game with the given error handler.

-catchGameError :: Game s a -> (GameException -> Game s a) -> Game s a

-catchGameError = catch

-

--- | Run the given game, catch any error, run the given finaliser and rethrow the error.

-catchGameErrorFinally :: Game s a -> Game s a -> Game s a

-catchGameErrorFinally game finally = catch game $ \err -> finally >> gameError' err

-

--- | Run the given game.

-runGame :: Game s a -> s -> IO (a, s)

-runGame game = R.runResourceT . runStateT game

+-- | Run the given game, unrolling the full monad stack and returning the game's

+-- result and its final state.

+--

+-- Any resources acquired by the given game are released when this returns.

+runGame :: s -> Game s a -> IO (a, s)

+runGame state game = runResourceT . runStateT (getGame game) $ state

+

+-- | Run the given child game, unrolling the full monad stack and returning the

+-- game's result and its final state.

+--

+-- Like `runGame`, this frees any resources that are acquired by the sub-game.

+-- If you want to keep acquired resources, see `runSiblingGame` instead.

+runChildGame :: s -> Game s a -> Game t (a, s)

+runChildGame state game = liftIO $ runGame state game

+

+-- | Run the given sibling game, unrolling the state transformer but not the

+-- resource transformer.

+--

+-- Unlike `runChildGame`, any resources acquired by the sibling game are *not*

+-- released.

+runSiblingGame :: s -> Game s a -> Game t (a, s)

+runSiblingGame state game = Game . lift $ runStateT (getGame game) state

 

 -- | Run the given game and return its result.

-evalGame :: Game s a -> s -> IO a

-evalGame g s = fst <$> runGame g s

-

--- | Fully run the given sub game, unrolling the entire monad stack.

-runSubGame :: Game s a -> s -> Game t (a, s)

-runSubGame g s = gameIO $ runGame g s

-

--- | Like 'runSubGame', but discarding the result.

-runSubGame' :: Game s a -> s -> Game t ()

-runSubGame' g s = void $ runSubGame g s

-

--- | Run the given sub game and return its result.

-evalSubGame :: Game s a -> s -> Game t a

-evalSubGame g s = fst <$> runSubGame g s

-

--- | Run the given sub game and return its state.

-execSubGame :: Game s a -> s -> Game t s

-execSubGame g s = snd <$> runSubGame g s

-

--- | Run the given sibling game, unrolling StateT but not ResourceT.

-runSiblingGame :: Game s a -> s -> Game t (a, s)

-runSiblingGame g s = lift $ runStateT g s

-

--- | Like 'runSiblingGame', but discarding the result.

-runSiblingGame' :: Game s a -> s -> Game t ()

-runSiblingGame' g s = void $ runSiblingGame g s

-

--- | Run the given sibling game and return its result.

-evalSiblingGame :: Game s a -> s -> Game t a

-evalSiblingGame g s = fst <$> runSiblingGame g s

-

--- | Run the given sibling game and return its state.

-execSiblingGame :: Game s a -> s -> Game t s

-execSiblingGame g s = snd <$> runSiblingGame g s

-

--- | Perform the given IO action in the 'Game' monad.

-gameIO :: IO a -> Game s a

-gameIO = lift . lift

+--eval :: (Monad m s, Monad n s) => (m s a -> s -> n (a, s)) -> m s a -> s -> m a

+eval  runner game state = fst <$> runner game state

+

+-- | Run the given game and return its final state.

+exec  runner game state = snd <$> runner game state

+

+-- | Run the given game and ignore both its result and final state.

+exec' runner game state = void $  runner game state

+

+-- | Run a sibling game on nested state.

+siblingGame :: HasState s t => Game t a -> Game s a

+siblingGame tAction = do

+  outerState <- getInnerState <$> get

+  (result, outerState') <- runSiblingGame outerState tAction

+  modify $ \outerState -> setInnerState outerState outerState'

+  return result

diff --git a/Spear/Math/Physics/Rigid.hs b/Spear/Math/Physics/Rigid.hs
deleted file mode 100644
index 28995bd..0000000
--- a/Spear/Math/Physics/Rigid.hs
+++ /dev/null
@@ -1,125 +0,0 @@
-module Spear.Math.Physics.Rigid

-(

-    module Spear.Math.Physics.Types

-,   RigidBody(..)

-,   rigidBody

-,   update

-,   setVelocity

-,   setAcceleration

-)

-where

-

-import qualified Spear.Math.Matrix3 as M3

-import Spear.Math.Spatial2

-import Spear.Math.Vector

-import Spear.Physics.Types

-

-import Data.List (foldl')

-import Control.Monad.State

-

-data RigidBody = RigidBody

-    { mass         :: {-# UNPACK #-} !Float

-    , position     :: {-# UNPACK #-} !Position

-    , velocity     :: {-# UNPACK #-} !Velocity

-    , acceleration :: {-# UNPACK #-} !Acceleration

-    }

-

-instance Spatial2 RigidBody where

-

-    move v body = body { position = v + position body }

-

-    moveFwd     speed body = body { position = position body + scale speed unity2 }

-

-    moveBack    speed body = body { position = position body + scale (-speed) unity2 }

-

-    strafeLeft  speed body = body { position = position body + scale (-speed) unitx2 }

-

-    strafeRight speed body = body { position = position body + scale speed unitx2 }

-

-    rotate angle = id

-

-    setRotation angle = id

-

-    pos = position

-

-    fwd _ = unity2

-

-    up _ = unity2

-

-    right _ = unitx2

-

-    transform body = M3.transform unitx2 unity2 $ position body

-

-    setTransform transf body = body { position = M3.position transf }

-

-    setPos p body = body { position = p }

-

--- | Build a 'RigidBody'.

-rigidBody :: Mass -> Position -> RigidBody

-rigidBody m x = RigidBody m x zero2 zero2

-

--- | Update the given 'RigidBody'.

-update :: [Force] -> Dt -> RigidBody -> RigidBody

-update forces dt body =

-    let netforce = foldl' (+) zero2 forces

-        m  = mass body

-        r1 = position body

-        v1 = velocity body

-        a1 = acceleration body

-        r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1

-        v' = v1 + scale (0.5*dt) a1

-        a2 = a1 + scale (1/m) netforce

-        v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2

-    in

-        RigidBody m r2 v2 a2

-

--- | Set the body's velocity.

-setVelocity :: Velocity -> RigidBody -> RigidBody

-setVelocity v body = body { velocity = v }

-

--- | Set the body's acceleration.

-setAcceleration :: Acceleration -> RigidBody -> RigidBody

-setAcceleration a body = body { acceleration = a }

-

-

--- test

-{-gravity = vec2 0 (-10)

-b0 = rigidBody 50 $ vec2 0 1000

-

-

-debug :: IO ()

-debug = evalStateT debug' b0

-

-

-

-debug' :: StateT RigidBody IO ()

-debug' = do

-    lift . putStrLn $ "Initial body:"

-    lift . putStrLn . show' $ b0

-    lift . putStrLn $ "Falling..."

-    step $ update [gravity*50] 1

-    step $ update [gravity*50] 1

-    step $ update [gravity*50] 1

-    lift . putStrLn $ "Jumping"

-    step $ update [gravity*50, vec2 0 9000] 1

-    lift . putStrLn $ "Falling..."

-    step $ update [gravity*50] 1

-    step $ update [gravity*50] 1

-    step $ update [gravity*50] 1

-

-

-step :: (RigidBody -> RigidBody) -> StateT RigidBody IO ()

-step update = do

-    modify update

-    body <- get

-    lift . putStrLn . show' $ body

-

-

-show' body =

-    "mass " ++ (show $ mass body) ++

-    ", position " ++ (showVec $ position body) ++

-    ", velocity " ++ (showVec $ velocity body) ++

-    ", acceleration " ++ (showVec $ acceleration body)

-

-

-showVec v = (show $ x v) ++ ", " ++ (show $ y v)-}

diff --git a/Spear/Math/Physics/Types.hs b/Spear/Math/Physics/Types.hs
deleted file mode 100644
index 59e6c74..0000000
--- a/Spear/Math/Physics/Types.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Spear.Math.Physics.Types

-where

-

-import Spear.Math.Vector

-

-type Dt = Float

-type Force = Vector2

-type Mass = Float

-type Position = Vector2

-type Velocity = Vector2

-type Acceleration = Vector2

diff --git a/Spear/Math/Plane.hs b/Spear/Math/Plane.hs
index 5440a43..cbf5aed 100644
--- a/Spear/Math/Plane.hs
+++ b/Spear/Math/Plane.hs
@@ -2,41 +2,75 @@
 

 module Spear.Math.Plane

 (

-    Plane

-,   plane

-,   classify

+  Plane(..)

+, AxisPlane(..)

+, plane

+, axisPlane

+, planeClassify

+, axisPlaneClassify

 )

 where

 

 import           Spear.Math.Vector

 import           Spear.Prelude

 

+

+data Axis = X | Y | Z deriving (Eq, Show)

+

+data AxisOrientation = PositiveAxis | NegativeAxis deriving (Eq, Show)

+

 data PointPlanePos = Front | Back | Contained deriving (Eq, Show)

 

+-- | A 3D plane.

 data Plane = Plane

-    { n :: {-# UNPACK #-} !Vector3,

-      d :: {-# UNPACK #-} !Float

+    { planeNormal   :: {-# UNPACK #-} !Vector3

+    , planeDistance :: {-# UNPACK #-} !Float

     }

     deriving(Eq, Show)

 

+-- | An axis-aligned 3D plane.

+data AxisPlane = AxisPlane

+    { axisPlaneAxis     :: !Axis

+    , axisPlaneDistance :: {-# UNPACK #-} !Float

+    , axisPlaneNormal   :: !AxisOrientation

+    }

+    deriving (Eq, Show)

+

+

 -- | Construct a plane from  a normal vector and a distance from the origin.

 plane :: Vector3 -> Float -> Plane

 plane n d = Plane (normalise n) d

 

+-- | Construct an axis-aligned plane.

+axisPlane :: Axis -> Float -> AxisOrientation -> AxisPlane

+axisPlane = AxisPlane

+

 -- | Construct a plane from three points.

 --

 -- Points must be given in counter-clockwise order.

-fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane

-fromPoints p0 p1 p2 = Plane n d

-           where n  = normalise $ v1 `cross` v2

-                 v1 = p2 - p1

-                 v2 = p0 - p1

-                 d  = p0 `dot` n

+planeFromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane

+planeFromPoints p0 p1 p2 = Plane n d

+    where n  = normalise $ v1 `cross` v2

+          v1 = p2 - p1

+          v2 = p0 - p1

+          d  = p0 `dot` n

 

 -- | Classify the given point's relative position with respect to the plane.

-classify :: Plane -> Vector3 -> PointPlanePos

-classify (Plane n d) pt =

+planeClassify :: Plane -> Vector3 -> PointPlanePos

+planeClassify (Plane n d) pt =

     case (n `dot` pt - d) `compare` 0 of

         GT -> Front

         LT -> Back

         EQ -> Contained

+

+-- | Classify the given point's relative position with respect to the plane.

+axisPlaneClassify :: AxisPlane -> Vector3 -> PointPlanePos

+axisPlaneClassify (AxisPlane axis d _) (Vector3 x y z) =

+    let classify coord

+          | coord < d = Back

+          | coord > d = Front

+          | otherwise = Contained

+    in case axis of

+        X -> classify x

+        Y -> classify y

+        Z -> classify z

diff --git a/Spear/Math/Spatial.hs b/Spear/Math/Spatial.hs
index bfab6c2..b6a3ede 100644
--- a/Spear/Math/Spatial.hs
+++ b/Spear/Math/Spatial.hs
@@ -88,22 +88,22 @@ class (Positional a v, Rotational a v r) => Spatial a v r t | a -> t where
 move :: Positional a v => Float -> (a -> v) -> a -> a
 move delta axis a = translate (axis a * delta) a
 
--- | Move the spatial upwards.
+-- | Move the spatial along its right axis.
 moveRight delta = move delta right
 
--- | Move the spatial downwards.
+-- | Move the spatial along its left axis.
 moveLeft delta = moveRight (-delta)
 
--- | Move the spatial upwards.
+-- | Move the spatial along its up axis.
 moveUp delta = move delta up
 
--- | Move the spatial downwards.
+-- | Move the spatial along its down axis.
 moveDown delta = moveUp (-delta)
 
--- | Move the spatial forwards.
+-- | Move the spatial along its forward axis.
 moveFwd delta = move delta forward
 
--- | Move the spatial backwards.
+-- | Move the spatial along its backward axis.
 moveBack delta = moveFwd (-delta)
 
 -- | Make the spatial look at the given point.
diff --git a/Spear/Math/Spatial2.hs b/Spear/Math/Spatial2.hs
index 1cc2b65..62eb75a 100644
--- a/Spear/Math/Spatial2.hs
+++ b/Spear/Math/Spatial2.hs
@@ -14,6 +14,8 @@ import           Spear.Math.Vector
 import           Spear.Prelude

 

 

+-- TODO: These type synonyms don't seem to work well when trying to instantiate

+-- the classes.

 type Positional2 a = Positional a Vector2

 type Rotational2 a = Rotational a Angle

 type Spatial2    s = Spatial    s Vector2 Angle Transform2

diff --git a/Spear/Math/Vector/Vector.hs b/Spear/Math/Vector/Vector.hs
index e7f6d53..d9cd64f 100644
--- a/Spear/Math/Vector/Vector.hs
+++ b/Spear/Math/Vector/Vector.hs
@@ -48,3 +48,6 @@ class
 
       -- | Normalise the given vector.
       normalise :: v -> v
+
+      -- | Scale the vector.
+      scale :: Float -> v -> v
diff --git a/Spear/Math/Vector/Vector2.hs b/Spear/Math/Vector/Vector2.hs
index 1ede3a9..b74cfef 100644
--- a/Spear/Math/Vector/Vector2.hs
+++ b/Spear/Math/Vector/Vector2.hs
@@ -33,7 +33,10 @@ type Position2 = Vector2
 

 

 -- | Represents a vector in 2D.

-data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show)

+data Vector2 = Vector2

+    {-# UNPACK #-} !Float

+    {-# UNPACK #-} !Float

+    deriving (Eq, Show)

 

 

 instance Addition Vector2 Vector2 where

@@ -129,6 +132,9 @@ instance Vector Vector2 where
                 n = if n' == 0 then 1 else n'

             in ((1.0::Float) / n) * v

 

+    {-# INLINABLE scale #-}

+    scale s (Vector2 x y) = Vector2 (s*x) (s*y)

+

 

 sizeFloat = sizeOf (undefined :: CFloat)

 

diff --git a/Spear/Math/Vector/Vector3.hs b/Spear/Math/Vector/Vector3.hs
index db5dc45..6ad4fe1 100644
--- a/Spear/Math/Vector/Vector3.hs
+++ b/Spear/Math/Vector/Vector3.hs
@@ -163,6 +163,9 @@ instance Vector Vector3 where
                 n = if n' == 0 then 1 else n'

             in ((1.0::Float) / n) * v

 

+    {-# INLINABLE scale #-}

+    scale s (Vector3 x y z) = Vector3 (s*x) (s*y) (s*z)

+

 

 sizeFloat = sizeOf (undefined :: CFloat)

 

diff --git a/Spear/Math/Vector/Vector4.hs b/Spear/Math/Vector/Vector4.hs
index 907295e..3ca27c9 100644
--- a/Spear/Math/Vector/Vector4.hs
+++ b/Spear/Math/Vector/Vector4.hs
@@ -161,6 +161,9 @@ instance Vector Vector4 where
                 n  = if n' == 0 then 1 else n'

             in ((1.0::Float) / n) * v

 

+    {-# INLINABLE scale #-}

+    scale s (Vector4 x y z w) = Vector4 (s*x) (s*y) (s*z) (s*w)

+

 

 sizeFloat = sizeOf (undefined :: CFloat)

 

diff --git a/Spear/Physics/Collision.hs b/Spear/Physics/Collision.hs
new file mode 100644
index 0000000..9ade9ca
--- /dev/null
+++ b/Spear/Physics/Collision.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+
+module Spear.Physics.Collision
+(
+  BoundingVolume2(..)
+, Bounded2(..)
+, aabb2Volume
+, collide
+)
+where
+
+import           Spear.Math.AABB
+import           Spear.Math.Spatial
+import           Spear.Math.Spatial2
+import           Spear.Math.Vector
+import           Spear.Prelude
+
+import           Data.Maybe          (mapMaybe)
+
+
+-- Currently supporting AABB2. Add circles later when needed.
+data BoundingVolume2
+  = AABB2Volume { box2 :: {-# UNPACK #-} !AABB2 }
+
+
+class Bounded2 a where
+  boundingVolume :: a -> BoundingVolume2
+
+
+-- | Construct a new bounding volume from a 2D axis-aligned box.
+aabb2Volume :: AABB2 -> BoundingVolume2
+aabb2Volume = AABB2Volume
+
+
+-- | Find collisions between the objects in the first list and the objects in
+-- the second list.
+collide :: Bounded2 a => [a] -> [a] -> [(a,a)]
+collide xs ys =
+  mapMaybe testCollision pairs
+  where
+    testCollision [o1, o2] = if objectsCollide o1 o2 then Just (o1, o2) else Nothing
+    pairs = sequence [xs, ys]
+
+
+-- | Test two objects for collision.
+objectsCollide :: Bounded2 a => a -> a -> Bool
+objectsCollide o1 o2 =
+  collideAABB2 (box2 . boundingVolume $ o1) (box2 . boundingVolume $ o2)
+
+
+-- | Test two 2D axis-aligned bounding boxes for collision.
+collideAABB2 :: AABB2 -> AABB2 -> Bool
+collideAABB2 box1 box2 =
+  let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = box1
+      (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = box2
+  in not $
+    xmax1 < xmin2 ||
+    xmin1 > xmax2 ||
+    ymax1 < ymin2 ||
+    ymin1 > ymax2
diff --git a/Spear/Physics/RigidBody.hs b/Spear/Physics/RigidBody.hs
new file mode 100644
index 0000000..1a8fe0a
--- /dev/null
+++ b/Spear/Physics/RigidBody.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE FlexibleContexts      #-}

+{-# LANGUAGE MultiParamTypeClasses #-}

+{-# LANGUAGE NoImplicitPrelude     #-}

+{-# LANGUAGE TypeSynonymInstances  #-}

+

+module Spear.Physics.RigidBody

+(

+  RigidBody2

+, rigidBody

+, setVelocity

+, setAcceleration

+, update

+)

+where

+

+import           Spear.Math.Spatial

+import           Spear.Math.Spatial2

+import           Spear.Math.Vector

+import           Spear.Prelude

+

+import           Control.Monad.State

+import           Data.List           (foldl')

+

+

+type Dt = Float

+type Force = Vector2

+type Mass = Float

+type Position = Vector2

+type Velocity = Vector2

+type Acceleration = Vector2

+

+

+{- class RigidBody2 a where

+  bodyMass         :: a -> Float

+  bodyPosition     :: a -> Vector2

+  bodyVelocity     :: a -> Vector2

+  bodyAcceleration :: a -> Vector2 -}

+

+

+data RigidBody2 = RigidBody2

+    { bodyMass         :: {-# UNPACK #-} !Float

+    , bodyPosition     :: {-# UNPACK #-} !Position

+    , bodyVelocity     :: {-# UNPACK #-} !Velocity

+    , bodyAcceleration :: {-# UNPACK #-} !Acceleration

+    }

+

+

+instance Positional RigidBody2 Vector2 where

+  setPosition p body = body { bodyPosition = p }

+  position = bodyPosition

+  translate v body = body { bodyPosition = bodyPosition body + v }

+

+

+-- | Build a 'RigidBody'.

+rigidBody :: Mass -> Position -> RigidBody2

+rigidBody mass position = RigidBody2 mass position zero2 zero2

+

+

+-- | Set the body's velocity.

+setVelocity :: Velocity -> RigidBody2 -> RigidBody2

+setVelocity velocity body = body { bodyVelocity = velocity }

+

+

+-- | Set the body's acceleration.

+setAcceleration :: Acceleration -> RigidBody2 -> RigidBody2

+setAcceleration acceleration body = body { bodyAcceleration = acceleration }

+

+

+-- | Update the given 'RigidBody'.

+update :: [Force] -> Dt -> RigidBody2 -> RigidBody2

+update forces dt body@(RigidBody2 m p v a) =

+    let f = foldl' (+) zero2 forces

+        a' = a + (f / m)

+        v' = v + (a' * dt)

+        p' = p + (v' * dt)

+    in

+        RigidBody2 m p' v' a'

diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs
index 8f0d6bd..e5b29ec 100644
--- a/Spear/Render/AnimatedModel.hs
+++ b/Spear/Render/AnimatedModel.hs
@@ -66,7 +66,7 @@ data AnimatedModelResource = AnimatedModelResource
     material  :: Material,

     texture   :: Texture,

     boxes     :: V.Vector Box,

-    rkey      :: Resource

+    rkey      :: ReleaseKey

   }

 

 instance Eq AnimatedModelResource where

@@ -121,12 +121,12 @@ animatedModelResource
   material

   texture

   model = do

-    RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model

+    RenderModel elements numFrames numVertices <- liftIO . renderModelFromModel $ model

     elementBuf <- newBuffer

     vao <- newVAO

-    boxes <- gameIO $ modelBoxes model

+    boxes <- liftIO $ modelBoxes model

 

-    gameIO $ do

+    liftIO $ do

       let elemSize = 56::CUInt

           elemSize' = fromIntegral elemSize

           n = numVertices * numFrames

@@ -149,9 +149,8 @@ animatedModelResource
       enableVAOAttrib texChan

 

     rkey <- register $ do

-      putStrLn "Releasing animated model resource"

-      release' vao

-      release' elementBuf

+      release $ vaoKey vao

+      release $ bufferKey elementBuf

 

     return $

       AnimatedModelResource

diff --git a/Spear/Render/Core/Buffer.hs b/Spear/Render/Core/Buffer.hs
index a4e98a4..3003987 100644
--- a/Spear/Render/Core/Buffer.hs
+++ b/Spear/Render/Core/Buffer.hs
@@ -14,6 +14,7 @@ import           Spear.Math.Vector
 import           Spear.Render.Core.State
 
 import           Control.Monad           (unless, void)
+import           Control.Monad.IO.Class
 import qualified Data.HashMap            as HashMap
 import           Data.Word
 import           Foreign.C.Types
@@ -53,24 +54,23 @@ makeBufferAndView desc = do
 
 makeBuffer :: BufferDesc -> Game RenderCoreState Buffer
 makeBuffer (BufferDesc usage bufferData) = do
-  handle <- gameIO $ alloca $ \ptr -> glGenBuffers 1 ptr >> peek ptr
+  handle <- liftIO $ alloca $ \ptr -> glGenBuffers 1 ptr >> peek ptr
   resourceKey <- register $ deleteBuffer' handle
   let buffer = Buffer handle resourceKey usage
-  gameIO $ updateBuffer buffer bufferData
-  modifyGameState (\state -> state {
+  liftIO $ updateBuffer buffer bufferData
+  modify (\state -> state {
     buffers = HashMap.insert handle buffer (buffers state) })
   return buffer
 
 deleteBuffer :: Buffer -> Game RenderCoreState ()
 deleteBuffer buffer = do
-  let matches buffer = (==bufferHandle buffer) . bufferHandle
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     buffers = HashMap.delete (bufferHandle buffer) (buffers state) })
-  release buffer
+  release' buffer
 
 -- TODO: use glBufferSubData for updates.
-updateBuffer :: Buffer -> BufferData -> IO ()
-updateBuffer buffer bufferData =
+updateBuffer :: MonadIO io => Buffer -> BufferData -> io ()
+updateBuffer buffer bufferData = liftIO $
   unless (bufferEmpty bufferData) $ do
     glBindBuffer GL_ARRAY_BUFFER (bufferHandle buffer)
     uploadData (bufferUsage buffer) bufferData
diff --git a/Spear/Render/Core/Geometry.hs b/Spear/Render/Core/Geometry.hs
index 6c05b38..05c23ec 100644
--- a/Spear/Render/Core/Geometry.hs
+++ b/Spear/Render/Core/Geometry.hs
@@ -21,6 +21,7 @@ import           Spear.Render.Core.Buffer
 import           Spear.Render.Core.Constants
 import           Spear.Render.Core.State
 
+import           Control.Monad.IO.Class
 import           Data.HashMap                as HashMap
 import           Data.IORef
 import           Data.Maybe                  (fromJust)
@@ -87,26 +88,26 @@ newGeometryDesc = GeometryDesc
 makeGeometry :: GeometryDesc -> Game RenderCoreState Geometry
 makeGeometry desc = do
   gdata  <- geometryDescToData desc
-  handle <- gameIO $ alloca $ \ptr -> glGenVertexArrays 1 ptr >> peek ptr
-  gameIO $ do
+  handle <- liftIO $ alloca $ \ptr -> glGenVertexArrays 1 ptr >> peek ptr
+  liftIO $ do
     glBindVertexArray handle
     configureVertexAttributes gdata
     glBindVertexArray 0
-  gdataRef <- gameIO $ newIORef gdata
+  gdataRef <- liftIO $ newIORef gdata
   resourceKey <- register $ deleteGeometry' handle
   let geometry = Geometry handle resourceKey gdataRef
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     geometries = HashMap.insert handle geometry (geometries state) })
   return geometry
 
 deleteGeometry :: Geometry -> Game RenderCoreState ()
 deleteGeometry geometry = do
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     geometries = HashMap.delete (geometryVao geometry) (geometries state) })
-  release geometry
+  release' geometry
 
-renderGeometry :: Geometry -> IO ()
-renderGeometry geometry = do
+renderGeometry :: MonadIO io => Geometry -> io ()
+renderGeometry geometry = liftIO $ do
   gdata <- readIORef (geometryData geometry)
   let mode = toGLPrimitiveType $ geometryPrimitiveType gdata
   glBindVertexArray (geometryVao geometry)
@@ -121,8 +122,8 @@ renderGeometry geometry = do
 
 -- Functions for updating dynamic geometry.
 
-setPositions :: Geometry -> [Vector3] -> IO ()
-setPositions geometry vectors = do
+setPositions :: MonadIO io => Geometry -> [Vector3] -> io ()
+setPositions geometry vectors = liftIO $ do
   gdata <- readIORef $ geometryData geometry
   case vertexPositions gdata of
     VertexPositions3d view -> do
diff --git a/Spear/Render/Core/Pipeline.hs b/Spear/Render/Core/Pipeline.hs
index 724b391..ee9c7d2 100644
--- a/Spear/Render/Core/Pipeline.hs
+++ b/Spear/Render/Core/Pipeline.hs
@@ -13,8 +13,9 @@ module Spear.Render.Core.Pipeline
 )
 where
 
-import           Data.Bits          ((.|.))
-import           Data.List          (foldl')
+import           Control.Monad.IO.Class
+import           Data.Bits              ((.|.))
+import           Data.List              (foldl')
 import           Graphics.GL.Core46
 
 
@@ -24,7 +25,7 @@ data BufferTarget
   | StencilBuffer
 
 
-clearBuffers :: [BufferTarget] -> IO ()
+clearBuffers :: MonadIO io => [BufferTarget] -> io ()
 clearBuffers = glClear . toBufferBitfield
   where toBufferBitfield = foldl' (.|.) 0 . (<$>) toGLEnum
         toGLEnum target = case target of
@@ -32,28 +33,28 @@ clearBuffers = glClear . toBufferBitfield
           DepthBuffer   -> GL_DEPTH_BUFFER_BIT
           StencilBuffer -> GL_STENCIL_BUFFER_BIT
 
-setBlending :: Bool -> IO ()
+setBlending :: MonadIO io => Bool -> io ()
 setBlending enable =
   if enable
     then glEnable  GL_BLEND >> glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
     else glDisable GL_BLEND
 
-setClearColour :: (Float, Float, Float, Float) -> IO ()
+setClearColour :: MonadIO io => (Float, Float, Float, Float) -> io ()
 setClearColour (r,g,b,a) = glClearColor r g b a
 
-setClearDepth :: Double -> IO ()
+setClearDepth :: MonadIO io => Double -> io ()
 setClearDepth = glClearDepth
 
-setClearStencil :: Int -> IO ()
+setClearStencil :: MonadIO io => Int -> io ()
 setClearStencil = glClearStencil . fromIntegral
 
-setCulling :: Bool -> IO ()
+setCulling :: MonadIO io => Bool -> io ()
 setCulling enable = (if enable then glEnable else glDisable) GL_CULL_FACE
 
-setDepthMask :: Bool -> IO ()
+setDepthMask :: MonadIO io => Bool -> io ()
 setDepthMask enable = glDepthMask (if enable then GL_TRUE else GL_FALSE)
 
-setPolygonOffset :: Float -> Float -> IO ()
+setPolygonOffset :: MonadIO io => Float -> Float -> io ()
 setPolygonOffset scale bias = do
   glPolygonOffset scale bias
   if scale /= 0 && bias /= 0
@@ -61,6 +62,7 @@ setPolygonOffset scale bias = do
     else glDisable GL_POLYGON_OFFSET_FILL
 
 setViewport ::
+  MonadIO io =>
   -- | x
   Int ->
   -- | y
@@ -69,6 +71,6 @@ setViewport ::
   Int ->
   -- | height
   Int ->
-  IO ()
+  io ()
 setViewport x y width height =
   glViewport (fromIntegral x) (fromIntegral y) (fromIntegral width) (fromIntegral height)
diff --git a/Spear/Render/Core/Shader.hs b/Spear/Render/Core/Shader.hs
index 4ed4430..ce29d4b 100644
--- a/Spear/Render/Core/Shader.hs
+++ b/Spear/Render/Core/Shader.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Spear.Render.Core.Shader
 (
   Define(..)
@@ -20,11 +22,15 @@ import           Spear.Math.Vector
 import           Spear.Render.Core.State
 
 import           Control.Monad           (mapM_)
+import           Control.Monad.IO.Class
 import           Data.Bits
+import           Data.ByteString         as B
 import           Data.Hashable
 import           Data.HashMap            as HashMap
 import           Data.IORef
-import           Data.List               (deleteBy, foldl', intercalate)
+import           Data.List               as List (deleteBy, foldl', intercalate)
+import           Data.Text               as T
+import           Data.Text.Encoding      as T
 import           Foreign.C.String
 import           Foreign.Marshal.Alloc
 import           Foreign.Marshal.Array
@@ -35,11 +41,12 @@ import           Graphics.GL.Core46
 import           Unsafe.Coerce
 
 
-type Define = (String, String)
+type Define = (ByteString, ByteString)
 
 data ShaderSource
-  = ShaderFromString String
-  | ShaderFromFile   FilePath
+  = ShaderFromString     String
+  | ShaderFromByteString ByteString
+  | ShaderFromFile       FilePath
   deriving Show
 
 data ShaderDesc = ShaderDesc
@@ -48,27 +55,31 @@ data ShaderDesc = ShaderDesc
   , shaderDescDefines :: [Define]
   }
 
+-- Header prepended to all shaders.
+header = "#version 400 core\n"
+
 
 compileShader :: ShaderDesc -> Game RenderCoreState Shader
 compileShader (ShaderDesc shaderType source defines) = do
   code <- case source of
-    ShaderFromString code -> return code
-    ShaderFromFile   file -> gameIO $ readFile file
-  state <- getGameState
+    ShaderFromString     code -> return (T.encodeUtf8 . T.pack $ code)
+    ShaderFromByteString code -> return code
+    ShaderFromFile       file -> liftIO $ B.readFile file
+  state <- get
   let shaderHash = hash code -- TODO: Should also include defines.
   case HashMap.lookup shaderHash (shaders state) of
     Just shader -> return shader
     Nothing -> do
       let definesString = makeDefinesString defines
-      handle <- gameIO $ glCreateShader (toGLShaderType shaderType)
-      gameIO $ withCStringLen code $ \(codeCString, codeLen) ->
-        withCStringLen definesString $ \(definesCString, definesLen) ->
+      handle <- liftIO $ glCreateShader (toGLShaderType shaderType)
+      liftIO $ B.useAsCStringLen code $ \(codeCString, codeLen) ->
+        B.useAsCStringLen definesString $ \(definesCString, definesLen) ->
           withCStringLen header $ \(headerCString, headerLen) ->
             withArray [headerCString, definesCString, codeCString] $ \strPtrs ->
               withArray (fromIntegral <$> [headerLen, definesLen, codeLen] :: [GLint])
                 $ \lengths ->
                   glShaderSource handle 3 strPtrs lengths
-      err <- gameIO $ do
+      err <- liftIO $ do
         glCompileShader handle
         alloca $ \statusPtr -> do
           glGetShaderiv handle GL_COMPILE_STATUS statusPtr
@@ -79,7 +90,7 @@ compileShader (ShaderDesc shaderType source defines) = do
               len <- peek lenPtr
               case len of
                 0 -> return $ Just ""
-                _ -> withCString (replicate (fromIntegral len) '\0') $ \logPtr -> do
+                _ -> withCString (Prelude.replicate (fromIntegral len) '\0') $ \logPtr -> do
                   glGetShaderInfoLog handle len nullPtr logPtr
                   Just <$> peekCString logPtr
             _ -> return Nothing
@@ -87,7 +98,7 @@ compileShader (ShaderDesc shaderType source defines) = do
         Nothing -> do
           resourceKey <- register $ deleteShader' handle
           let shader = Shader handle resourceKey shaderType shaderHash
-          saveGameState $ state {
+          put $ state {
             shaders = HashMap.insert shaderHash shader (shaders state)
           }
           return shader
@@ -96,17 +107,17 @@ compileShader (ShaderDesc shaderType source defines) = do
 
 compileShaderProgram :: [Shader] -> Game RenderCoreState ShaderProgram
 compileShaderProgram shaders = do
-  state <- getGameState
+  state <- get
   let programHash = hashShaders shaders
   case HashMap.lookup programHash (shaderPrograms state) of
     Just program -> return program
     Nothing -> do
-      handle <- gameIO glCreateProgram
+      handle <- liftIO glCreateProgram
       case handle of
         0 -> gameError "Failed to create shader program"
         _ -> do
-          mapM_ (gameIO . glAttachShader handle) (shaderHandle <$> shaders)
-          err <- gameIO $ do
+          mapM_ (liftIO . glAttachShader handle) (shaderHandle <$> shaders)
+          err <- liftIO $ do
             glLinkProgram handle
             alloca $ \statusPtr -> do
               glGetProgramiv handle GL_LINK_STATUS statusPtr
@@ -117,51 +128,51 @@ compileShaderProgram shaders = do
                   len <- peek lenPtr
                   case len of
                     0 -> return $ Just "Unknown error"
-                    _ -> withCString (replicate (fromIntegral len) '\0') $ \logPtr -> do
+                    _ -> withCString (Prelude.replicate (fromIntegral len) '\0') $ \logPtr -> do
                       glGetShaderInfoLog handle len nullPtr logPtr
                       Just <$> peekCString logPtr
                 _ -> return Nothing
           case err of
             Nothing -> do
               resourceKey <- register $ deleteShaderProgram' handle
-              uniforms <- gameIO $ newIORef []
+              uniforms <- liftIO $ newIORef []
               let program = ShaderProgram handle resourceKey programHash uniforms
-              saveGameState $ state {
+              put $ state {
                 shaderPrograms = HashMap.insert programHash program (shaderPrograms state)
               }
               return program
             Just err -> gameError $
               "Failed to compile shader program: " ++ err ++ "; shaders: " ++
-                intercalate ", " (show . shaderHandle <$> shaders)
+                List.intercalate ", " (show . shaderHandle <$> shaders)
 
 deleteShader :: Shader -> Game RenderCoreState ()
 deleteShader shader = do
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     shaders = HashMap.delete (shaderHash shader) (shaders state) })
-  release shader
+  release' shader
 
 deleteShaderProgram :: ShaderProgram -> Game RenderCoreState ()
 deleteShaderProgram program = do
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     shaderPrograms = HashMap.delete (shaderProgramHash program) (shaderPrograms state)})
-  release program
+  release' program
 
-activateShaderProgram :: ShaderProgram -> IO ()
+activateShaderProgram :: MonadIO io => ShaderProgram -> io ()
 activateShaderProgram program = do
   glUseProgram . shaderProgramHandle $ program
   applyUniforms program
 
-deactivateShaderProgram :: ShaderProgram -> IO ()
+deactivateShaderProgram :: MonadIO io => ShaderProgram -> io ()
 deactivateShaderProgram _ = glUseProgram 0
 
-setUniform :: ShaderUniform -> ShaderProgram -> IO ()
-setUniform uniform program =
+setUniform :: MonadIO io => ShaderUniform -> ShaderProgram -> io ()
+setUniform uniform program = liftIO $
   modifyIORef (shaderProgramUniforms program) (setUniform' . removeUniform)
     where removeUniform = deleteBy matchesUniform uniform
           matchesUniform uniform u = uniformName u == uniformName uniform
           setUniform' = (:) uniform
 
-applyUniforms :: ShaderProgram -> IO ()
+applyUniforms :: MonadIO io => ShaderProgram -> io ()
 applyUniforms program =
   let update (FloatUniform name value) =
           glGetUniformLocation' handle name >>=
@@ -179,9 +190,9 @@ applyUniforms program =
       update (Mat4ArrayUniform name mat4s) =
         glGetUniformLocation' handle name >>=
           \location -> withArray mat4s $ \ptrMat4s ->
-            glUniformMatrix4fv location (fromIntegral $ length mat4s) GL_FALSE (unsafeCoerce ptrMat4s)
+            glUniformMatrix4fv location (fromIntegral $ Prelude.length mat4s) GL_FALSE (unsafeCoerce ptrMat4s)
       handle = shaderProgramHandle program
-  in do
+  in liftIO $ do
     uniforms <- readIORef (shaderProgramUniforms program)
     mapM_ update uniforms
     writeIORef (shaderProgramUniforms program) []
@@ -189,7 +200,7 @@ applyUniforms program =
 -- Private
 
 glGetUniformLocation' :: GLuint -> String -> IO GLint
-glGetUniformLocation' handle name =
+glGetUniformLocation' handle name = liftIO $
   withCString name $ \nameCStr ->
     glGetUniformLocation (fromIntegral handle) (unsafeCoerce nameCStr)
 
@@ -200,7 +211,7 @@ deleteShaderProgram' :: GLuint -> IO ()
 deleteShaderProgram' = glDeleteProgram
 
 hashShaders :: [Shader] -> Int
-hashShaders = foldl' hashF 0
+hashShaders = List.foldl' hashF 0
   where hashF hash shader = (hash `shiftL` 32) .|. fromIntegral (shaderHandle shader)
 
 toGLShaderType :: ShaderType -> GLenum
@@ -208,9 +219,6 @@ toGLShaderType VertexShader   = GL_VERTEX_SHADER
 toGLShaderType FragmentShader = GL_FRAGMENT_SHADER
 toGLShaderType ComputeShader  = GL_COMPUTE_SHADER
 
-makeDefinesString :: [Define] -> String
-makeDefinesString defines = intercalate "\n" body ++ "\n"
-  where body = (\(name, value) -> "#define " ++ name ++ " " ++ value) <$> defines
-
--- Header prepended to all shaders.
-header = "#version 400 core\n"
+makeDefinesString :: [Define] -> ByteString
+makeDefinesString defines = B.concat[B.intercalate "\n" body, "\n"]
+  where body = (\(name, value) -> B.concat["#define ", name, " ", value]) <$> defines
diff --git a/Spear/Render/Core/State.hs b/Spear/Render/Core/State.hs
index f7e5627..aa42635 100644
--- a/Spear/Render/Core/State.hs
+++ b/Spear/Render/Core/State.hs
@@ -18,7 +18,7 @@ data BufferUsage
 -- | A data buffer (e.g., vertex attributes, indices).
 data Buffer = Buffer
   { bufferHandle   :: GLuint
-  , bufferResource :: Resource
+  , bufferResource :: ReleaseKey
   , bufferUsage    :: BufferUsage
   }
 
@@ -72,7 +72,7 @@ data GeometryData = GeometryData
 -- its state cannot become stale after an update.
 data Geometry = Geometry
   { geometryVao      :: GLuint
-  , geometryResource :: Resource
+  , geometryResource :: ReleaseKey
   , geometryData     :: IORef GeometryData
   }
 
@@ -80,7 +80,7 @@ data Geometry = Geometry
 -- | A shader.
 data Shader = Shader
   { shaderHandle   :: GLuint
-  , shaderResource :: Resource
+  , shaderResource :: ReleaseKey
   , shaderType     :: ShaderType
   , shaderHash     :: Int
   }
@@ -102,7 +102,7 @@ data ShaderUniform
 -- | A shader program.
 data ShaderProgram = ShaderProgram
   { shaderProgramHandle   :: GLuint
-  , shaderProgramResource :: Resource
+  , shaderProgramResource :: ReleaseKey
   , shaderProgramHash     :: Int
   -- Dirty set of uniforms that have been set since the last time uniforms were
   -- applied. OpenGL retains the values of uniforms for a program until the
@@ -123,7 +123,6 @@ type ShaderHash = Int
 type ShaderProgramHash = Int
 
 
-
 instance ResourceClass Buffer where
   getResource = bufferResource
 
diff --git a/Spear/Render/Immediate.hs b/Spear/Render/Immediate.hs
index 3c5f6ad..94a7abf 100644
--- a/Spear/Render/Immediate.hs
+++ b/Spear/Render/Immediate.hs
@@ -32,6 +32,7 @@ import           Spear.Render.Core.Buffer
 import           Spear.Render.Core.Geometry
 import           Spear.Render.Core.Shader
 import           Spear.Render.Core.State    hiding (shaders)
+import           Spear.Render.Shaders       as Shaders
 
 import           Control.Monad              (unless)
 import           Data.List                  (foldl')
@@ -47,11 +48,8 @@ data ImmRenderState = ImmRenderState
 
 newImmRenderer :: Game RenderCoreState ImmRenderState
 newImmRenderer = do
-  -- TODO: Move shaders to Spear project.
-  vs <- compileShader $ ShaderDesc VertexShader
-    (ShaderFromFile "/home/jeanne/src/gfx/gfx/shaders/immediate_mode.vert") []
-  ps <- compileShader $ ShaderDesc FragmentShader
-    (ShaderFromFile "/home/jeanne/src/gfx/gfx/shaders/immediate_mode.frag") []
+  vs <- compileShader $ ShaderDesc VertexShader   (ShaderFromByteString Shaders.immediateModeVert) []
+  ps <- compileShader $ ShaderDesc FragmentShader (ShaderFromByteString Shaders.immediateModeFrag) []
   shader <- compileShaderProgram [vs, ps]
 
   triangles <- makeGeometry $ newGeometryDesc
@@ -74,27 +72,28 @@ deleteImmRenderer immState = do
   deleteGeometry (triangles immState)
 
 -- The functions below are all defined inside the Game ImmRenderState monad so
--- that all of the drawing can conveniently happen inside the monad.
+-- that all of the drawing can conveniently happen inside the monad. They could
+-- technically be defined inside MonadIO, but then we would have to explicitly
+-- pass in the ImmRenderState.
 
 immStart :: Game ImmRenderState ()
 immStart = do
-  state <- getGameState
-  gameIO $ activateShaderProgram (shader state)
+  state <- get
+  activateShaderProgram (shader state)
 
 immEnd :: Game ImmRenderState ()
 immEnd = do
-  state <- getGameState
-  gameIO $ deactivateShaderProgram (shader state)
+  state <- get
+  deactivateShaderProgram (shader state)
 
 immDrawTriangles :: [Vector3] -> Game ImmRenderState ()
-immDrawTriangles vertices = do
+immDrawTriangles vertices =
   unless (null vertices) $ do
     loadMatrixStack
-    state <- getGameState
-    gameIO $ do
-      setPositions (triangles state) vertices
-      applyUniforms (shader state)
-      renderGeometry (triangles state)
+    state <- get
+    setPositions (triangles state) vertices
+    applyUniforms (shader state)
+    renderGeometry (triangles state)
 
 -- NOTE: consider using triangle strips for quads. This will require a separate
 -- Geometry. Using Vector3 for everything currently makes this simple.
@@ -112,42 +111,42 @@ immDrawQuads2d =
   immDrawQuads . (<$>) (\(p0, p1, p2, p3) -> (to3d p0, to3d p1, to3d p2, to3d p3))
 
 immLoadIdentity :: Game ImmRenderState ()
-immLoadIdentity = modifyGameState $ \state -> state {
+immLoadIdentity = modify $ \state -> state {
   matrixStack = [Matrix4.id] }
 
 immTranslate :: Vector3 -> Game ImmRenderState ()
-immTranslate vector = modifyGameState $ pushMatrix (Matrix4.translatev vector)
+immTranslate vector = modify $ pushMatrix (Matrix4.translatev vector)
 
 immPushMatrix :: Matrix4 -> Game ImmRenderState ()
-immPushMatrix matrix = modifyGameState $ pushMatrix matrix
+immPushMatrix matrix = modify $ pushMatrix matrix
 
 immPopMatrix :: Game ImmRenderState ()
-immPopMatrix = modifyGameState $ \state -> state {
+immPopMatrix = modify $ \state -> state {
   matrixStack = case matrixStack state of
     [x]  -> [x] -- Always keep the identity matrix on the stack.
     x:xs -> xs }
 
 immPreservingMatrix :: Game ImmRenderState a -> Game ImmRenderState a
 immPreservingMatrix f = do
-  originalStack <- matrixStack <$> getGameState
+  originalStack <- matrixStack <$> get
   result <- f
-  modifyGameState $ \state -> state { matrixStack = originalStack }
+  modify $ \state -> state { matrixStack = originalStack }
   return result
 
 immSetColour :: Vector4 -> Game ImmRenderState ()
 immSetColour colour = do
-  state <- getGameState
-  gameIO $ setUniform (Vec4Uniform "Colour" colour) (shader state)
+  state <- get
+  setUniform (Vec4Uniform "Colour" colour) (shader state)
 
 immSetModelMatrix :: Matrix4 -> Game ImmRenderState ()
 immSetModelMatrix model = do
-  state <- getGameState
-  gameIO $ setUniform (Mat4Uniform "Model" model) (shader state)
+  state <- get
+  setUniform (Mat4Uniform "Model" model) (shader state)
 
 immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState ()
 immSetViewProjectionMatrix viewProjection = do
-  state <- getGameState
-  gameIO $ setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state)
+  state <- get
+  setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state)
 
 -- Private
 
@@ -157,7 +156,7 @@ pushMatrix matrix state = state {
 
 loadMatrixStack :: Game ImmRenderState ()
 loadMatrixStack = do
-  state <- getGameState
+  state <- get
   immSetModelMatrix (head $ matrixStack state)
 
 to3d :: Vector2 -> Vector3
diff --git a/Spear/Render/Shaders.hs b/Spear/Render/Shaders.hs
new file mode 100644
index 0000000..bdf403d
--- /dev/null
+++ b/Spear/Render/Shaders.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Spear.Render.Shaders where
+
+import           Data.ByteString
+import           Data.FileEmbed
+
+immediateModeFrag :: ByteString
+immediateModeFrag = $(embedFile "Spear/Render/Shaders/immediate_mode.frag")
+
+immediateModeVert :: ByteString
+immediateModeVert = $(embedFile "Spear/Render/Shaders/immediate_mode.vert")
diff --git a/Spear/Render/Shaders/immediate_mode.frag b/Spear/Render/Shaders/immediate_mode.frag
new file mode 100644
index 0000000..ac23b5c
--- /dev/null
+++ b/Spear/Render/Shaders/immediate_mode.frag
@@ -0,0 +1,10 @@
+precision highp float;
+
+uniform vec4 Colour;
+
+out vec4 FragColour;
+
+void main()
+{
+  FragColour = vec4(pow(Colour.rgb, vec3(1.0/2.2)), Colour.a);
+}
diff --git a/Spear/Render/Shaders/immediate_mode.vert b/Spear/Render/Shaders/immediate_mode.vert
new file mode 100644
index 0000000..65070bb
--- /dev/null
+++ b/Spear/Render/Shaders/immediate_mode.vert
@@ -0,0 +1,11 @@
+precision highp float;
+
+uniform mat4 Model;
+uniform mat4 ViewProjection;
+
+layout (location = 0) in vec3 vPosition;
+
+void main()
+{
+  gl_Position = ViewProjection * Model * vec4(vPosition, 1.0);
+}
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs
index f4cddf8..5168cf2 100644
--- a/Spear/Render/StaticModel.hs
+++ b/Spear/Render/StaticModel.hs
@@ -44,7 +44,7 @@ data StaticModelResource = StaticModelResource
     material  :: Material,

     texture   :: Texture,

     boxes     :: V.Vector Box,

-    rkey      :: Resource

+    rkey      :: ReleaseKey

   }

 

 instance Eq StaticModelResource where

@@ -74,12 +74,12 @@ staticModelResource ::
   Model ->

   Game s StaticModelResource

 staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do

-  RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model

+  RenderModel elements _ numVertices <- liftIO . renderModelFromModel $ model

   elementBuf <- newBuffer

   vao <- newVAO

-  boxes <- gameIO $ modelBoxes model

+  boxes <- liftIO $ modelBoxes model

 

-  gameIO $ do

+  liftIO $ do

     let elemSize = 32::CUInt

         elemSize' = fromIntegral elemSize

         n = numVertices

@@ -98,9 +98,8 @@ staticModelResource (StaticProgramChannels vertChan normChan texChan) material t
     enableVAOAttrib texChan

 

   rkey <- register $ do

-    putStrLn "Releasing static model resource"

-    release' vao

-    release' elementBuf

+    release $ vaoKey vao

+    release $ bufferKey elementBuf

 

   return $

     StaticModelResource

diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs
index 3cd89f3..0593c77 100644
--- a/Spear/Scene/Loader.hs
+++ b/Spear/Scene/Loader.hs
@@ -43,7 +43,7 @@ type Loader = Game SceneResources
 -- | Load the scene specified by the given file.

 loadScene :: FilePath -> Game s (SceneResources, SceneGraph)

 loadScene file = do

-  result <- gameIO $ loadSceneGraphFromFile file

+  result <- liftIO $ loadSceneGraphFromFile file

   case result of

     Left err -> gameError $ show err

     Right g -> case validate g of

@@ -58,7 +58,7 @@ validate _ = Nothing
 

 -- | Load the scene described by the given 'SceneGraph'.

 resourceMap :: SceneGraph -> Game s SceneResources

-resourceMap g = execSubGame (resourceMap' g) emptySceneResources

+resourceMap g = exec runChildGame emptySceneResources (resourceMap' g)

 

 resourceMap' :: SceneGraph -> Loader ()

 resourceMap' node@(SceneLeaf nid props) = do

@@ -85,9 +85,9 @@ loadResource key field modifyResources load = do
   case M.lookup key $ field sceneData of

     Just val -> return val

     Nothing -> do

-      gameIO $ printf "Loading %s..." key

+      liftIO $ printf "Loading %s..." key

       resource <- load

-      gameIO $ printf "done\n"

+      liftIO $ printf "done\n"

       modifyResources key resource

       return resource

 

@@ -139,9 +139,9 @@ newModel (SceneLeaf _ props) = do
   let rotation = asRotation $ value "rotation" props

       scale = asVec3 $ value "scale" props

 

-  gameIO $ printf "Loading model %s..." name

+  liftIO $ printf "Loading model %s..." name

   model <- loadModel' file rotation scale

-  gameIO . putStrLn $ "done"

+  liftIO . putStrLn $ "done"

   texture <- loadTexture tex

   sceneRes <- get

 

@@ -180,7 +180,7 @@ loadModel' file rotation scale = do
                   \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')

             )

 

-  (fmap transform $ Model.loadModel file) >>= gameIO . toGround

+  (fmap transform $ Model.loadModel file) >>= liftIO . toGround

 

 rotateModel :: Rotation -> Model -> Model

 rotateModel (Rotation ax ay az order) model =

@@ -213,7 +213,7 @@ newShaderProgram (SceneLeaf _ props) = do
   stype <- asString $ mandatory' "type" props

   prog <- GL.newProgram [vertShader, fragShader]

 

-  let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name

+  let getUniformLoc name = (liftIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name

 

   case stype of

     "static" -> do

diff --git a/Spear/Sound/Sound.hs b/Spear/Sound/Sound.hs
new file mode 100644
index 0000000..887cf97
--- /dev/null
+++ b/Spear/Sound/Sound.hs
@@ -0,0 +1,104 @@
+module Spear.Sound.Sound
+( LoopMode(..)
+, withSoundContext
+, initSoundSystem
+, destroySoundSystem
+, loadAudioFile
+, deleteSoundBuffer
+, makeSoundSource
+, deleteSoundSource
+, setSoundSourceBuffer
+, setSoundLoopMode
+, playSounds
+)
+where
+
+import           Spear.Game
+import           Spear.Sound.State
+
+import           Control.Monad.IO.Class
+import           Data.Set               as Set
+import           Data.StateVar          (($=))
+import qualified Sound.ALUT             as AL
+
+
+data LoopMode
+  = SingleShot
+  | Loop
+  deriving (Show)
+
+
+-- | Create the sound context and run an IO action within the context.
+withSoundContext :: IO a -> IO a
+withSoundContext action = AL.withProgNameAndArgs AL.runALUT $
+  \name args -> action
+
+-- | Initialize the sound system.
+initSoundSystem :: Game () SoundState
+initSoundSystem = return newSoundState
+
+-- | Destroy the sound system.
+destroySoundSystem :: Game SoundState ()
+destroySoundSystem = do
+  state <- get
+  -- The order here matters; sources before buffers since buffers are attached
+  -- to sources.
+  mapM_ release' (toList $ sources state)
+  mapM_ release' (toList $ buffers state)
+  put newSoundState
+
+-- | Load an audio file.
+loadAudioFile :: FilePath -> Game SoundState SoundBuffer
+loadAudioFile path = do
+  alBuffer <- liftIO $ AL.createBuffer (AL.File path)
+  resourceKey <- register $ AL.deleteObjectName alBuffer
+  let buffer = SoundBuffer alBuffer resourceKey
+  modify (\state -> state {
+    buffers = Set.insert buffer (buffers state)
+  })
+  return buffer
+
+-- | Delete the sound buffer.
+deleteSoundBuffer :: SoundBuffer -> Game SoundState ()
+deleteSoundBuffer buffer = do
+  modify (\state -> state {
+    buffers = Set.delete buffer (buffers state)
+  })
+  release' buffer
+
+-- | Create a sound source.
+--
+-- The new source sounds flat, like background music or sound effects in a 2D
+-- game. Change the source's (and listener's) properties to simulate 3D sound.
+makeSoundSource :: Game SoundState SoundSource
+makeSoundSource = do
+  alSource <- AL.genObjectName
+  resourceKey <- register $ AL.deleteObjectName alSource
+  let source = SoundSource alSource resourceKey
+  modify (\state -> state {
+    sources = Set.insert source (sources state)
+  })
+  return source
+
+-- | Delete the sound source.
+deleteSoundSource :: SoundSource -> Game SoundState ()
+deleteSoundSource source = do
+  modify (\state -> state {
+    sources = Set.delete source (sources state)
+  })
+  release' source
+
+-- | Set the sound that the sound source emits.
+setSoundSourceBuffer :: MonadIO io => SoundSource -> SoundBuffer -> io ()
+setSoundSourceBuffer source buffer =
+  AL.buffer (alSource source) $= Just (alBuffer buffer)
+
+-- | Set the sound's loop mode.
+setSoundLoopMode :: MonadIO io => SoundSource -> LoopMode -> io ()
+setSoundLoopMode source mode = AL.loopingMode (alSource source) $= alMode mode
+  where alMode SingleShot = AL.OneShot
+        alMode Loop       = AL.Looping
+
+-- | Play the sound sources.
+playSounds :: MonadIO io => [SoundSource] -> io ()
+playSounds = AL.play . (alSource <$>)
diff --git a/Spear/Sound/State.hs b/Spear/Sound/State.hs
new file mode 100644
index 0000000..d843de5
--- /dev/null
+++ b/Spear/Sound/State.hs
@@ -0,0 +1,54 @@
+module Spear.Sound.State where
+
+import           Spear.Game
+
+import           Data.Hashable
+import           Data.Set      as Set
+import qualified Sound.ALUT    as AL
+
+
+-- | A sound buffer.
+data SoundBuffer = SoundBuffer
+  { alBuffer       :: AL.Buffer
+  , bufferResource :: ReleaseKey
+  }
+
+-- | A sound source.
+data SoundSource = SoundSource
+  { alSource       :: AL.Source
+  , sourceResource :: ReleaseKey
+  }
+
+-- | Sound state.
+data SoundState = SoundState
+  { buffers :: Set SoundBuffer
+  , sources :: Set SoundSource
+  }
+
+
+instance ResourceClass SoundBuffer where
+  getResource = bufferResource
+
+instance ResourceClass SoundSource where
+  getResource = sourceResource
+
+instance Eq SoundBuffer where
+  a == b = alBuffer a == alBuffer b
+
+instance Eq SoundSource where
+  a == b = alSource a == alSource b
+
+instance Ord SoundBuffer where
+  a <  b = alBuffer a <  alBuffer b
+  a <= b = alBuffer a <= alBuffer b
+
+instance Ord SoundSource where
+  a < b  = alSource a <  alSource b
+  a <= b = alSource a <= alSource b
+
+
+newSoundState :: SoundState
+newSoundState = SoundState
+  { buffers = Set.empty
+  , sources = Set.empty
+  }
diff --git a/Spear/Step.hs b/Spear/Step.hs
index cb4f71c..43c3415 100644
--- a/Spear/Step.hs
+++ b/Spear/Step.hs
@@ -21,6 +21,7 @@ module Spear.Step
     (.>),
     (<.),
     szip,
+    swhen,
     switch,
     multiSwitch,
   )
@@ -36,21 +37,34 @@ type Elapsed = Float
 type Dt = Float
 
 -- | A step function.
-newtype Step state events input a = Step
-  { runStep :: Elapsed -> Dt -> state -> events -> input -> (a, Step state events input a)
+newtype Step state events input output = Step
+  { runStep :: Elapsed -> Dt -> state -> events -> input -> (output, Step state events input output)
   }
 
-instance Functor (Step s e a) where
+instance Functor (Step state events input) where
   fmap f (Step s1) = Step $ \elapsed dt g e x ->
     let (a, s') = s1 elapsed dt g e x
      in (f a, fmap f s')
 
-instance Semigroup (Step s e a a) where
+instance Semigroup (Step state events input input) where
   (<>) = (.>)
 
-instance Monoid (Step s e a a) where
+instance Monoid (Step state events input input) where
   mempty = sid
 
+instance Applicative (Step state events input) where
+  pure = sreturn
+  fStep <*> inputStep = Step $ \t dt state events input ->
+    let (a, inputStep') = runStep inputStep t dt state events input
+        (f, fStep')     = runStep fStep     t dt state events input
+    in (f a, fStep' <*> inputStep')
+
+instance Monad (Step state events input) where
+  return = pure
+  inputStep >>= f = Step $ \t dt state events input ->
+    let (a, inputStep') = runStep inputStep t dt state events input
+    in runStep (f a) t dt state events input
+
 -- | Construct a step from a function.
 step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b
 step = Step
@@ -63,6 +77,10 @@ sid = Step $ \_ _ _ _ a -> (a, sid)
 spure :: (a -> b) -> Step s e a b
 spure f = Step $ \_ _ _ _ x -> (f x, spure f)
 
+-- | Construct a step that returns a constant value.
+sreturn :: b -> Step s e a b
+sreturn b = Step $ \_ _ _ _ _ -> (b, sreturn b)
+
 -- | The step that returns the first component in the tuple.
 sfst :: Step s e (a, b) a
 sfst = spure fst
@@ -73,29 +91,12 @@ ssnd = spure snd
 
 -- | Construct a step that folds a given list of inputs.
 --
--- The step is run N+1 times, where N is the size of the input list.
+-- The step is run once per input, or not at all if the list is empty.
 sfold :: Step s (Maybe e) a a -> Step s [e] a a
 sfold s = Step $ \elapsed dt g es a ->
-  case es of
-    [] ->
-      let (b', s') = runStep s elapsed dt g Nothing a
-       in (b', sfold s')
-    es ->
-      let (b', s') = sfold' elapsed dt g s a es
-       in (b', sfold s')
-
-sfold' ::
-  Elapsed ->
-  Dt ->
-  s ->
-  Step s (Maybe e) a a ->
-  a ->
-  [e] ->
-  (a, Step s (Maybe e) a a)
-sfold' elapsed dt g s a = foldl' f (a', s')
-  where
-    f (a, s) e = runStep s elapsed dt g (Just e) a
-    (a', s') = runStep s elapsed dt g Nothing a
+  let (a', s')   = foldl' f (a, s) es
+      f (a, s) e = runStep s elapsed dt g (Just e) a
+  in (a', sfold s')
 
 -- Combinators
 
@@ -117,9 +118,22 @@ szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d ->
       (b, s2') = s2 elapsed dt g e d
    in (f a b, szip f s1' s2')
 
--- | Construct a step that switches between two steps based on input.
+-- | Construct a step that is executed when the given event occurs.
+swhen :: Eq e => e -> Step s () a a -> Step s (Maybe e) a a
+swhen expectedEvent step = Step $ \elapsed dt state maybeEvent a ->
+  case maybeEvent of
+    Nothing -> (a, swhen expectedEvent step)
+    Just event ->
+      if event == expectedEvent
+      then let (a', step') = runStep step elapsed dt state () a
+             in (a', swhen expectedEvent step')
+      else (a, swhen expectedEvent step)
+
+-- | Construct a step that switches between two steps based on input events.
 --
--- The initial step is the first one.
+-- The current step runs with every 'runStep' even when there are no new events.
+--
+-- The initial step is the identity, 'sid'.
 switch ::
   Eq e =>
   e ->
@@ -127,16 +141,8 @@ switch ::
   e ->
   Step s (Maybe e) a a ->
   Step s (Maybe e) a a
-switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2
+switch = switch' sid
 
-switch' ::
-  Eq e =>
-  Step s (Maybe e) a a ->
-  e ->
-  Step s (Maybe e) a a ->
-  e ->
-  Step s (Maybe e) a a ->
-  Step s (Maybe e) a a
 switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a ->
   case e of
     Nothing ->
@@ -146,11 +152,15 @@ switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a ->
       let next
             | e' == flag1 = s1
             | e' == flag2 = s2
-            | otherwise = cur
+            | otherwise   = cur
           (a', s') = runStep next elapsed dt g e a
        in (a', switch' s' flag1 s1 flag2 s2)
 
--- | Construct a step that switches among multiple steps based on input.
+-- | Construct a step that switches among multiple steps based on input events.
+--
+-- The current step runs with every 'runStep' even when there are no new events.
+--
+-- The initial step is the identity, 'sid'.
 multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a
 multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs)
 
diff --git a/Spear/Sys/Timer.hsc b/Spear/Sys/Timer.hsc
index 98b88d6..46a692d 100644
--- a/Spear/Sys/Timer.hsc
+++ b/Spear/Sys/Timer.hsc
@@ -14,6 +14,7 @@ module Spear.Sys.Timer
 ,   timeDeltaToSec

 ,   secToTimeDelta

 ,   timePointToNs

+,   timeAdd

 ,   sleep

 )

 where

@@ -24,6 +25,7 @@ import Foreign.Marshal.Alloc (alloca)
 import Foreign.Ptr

 import Foreign.Storable

 import Control.Monad

+import Control.Monad.IO.Class

 import System.IO.Unsafe

 

 #include "Timer/timer.h"

@@ -115,6 +117,9 @@ foreign import ccall safe "timer.h sec_to_time_delta"
 foreign import ccall safe "timer.h time_point_to_ns"

      c_time_point_to_ns :: Ptr TimePoint -> Word64

 

+foreign import ccall safe "timer.h time_add"

+     c_time_add :: Ptr TimePoint -> TimeDelta -> Ptr TimePoint -> IO ()

+

 foreign import ccall "timer.h time_sleep"

      c_time_sleep :: TimeDelta -> IO ()

 

@@ -130,22 +135,22 @@ withTimer' c_func timer = alloca $ \ptr -> do
      peek ptr

 

 -- | Construct a  new timer.

-newTimer :: IO Timer

-newTimer = alloca $ \ptr -> do

+newTimer :: MonadIO io => io Timer

+newTimer = liftIO . alloca $ \ptr -> do

      c_timer_make ptr

      peek ptr

 

 -- | Start the timer.

-start :: Timer -> IO ()

-start = withTimer c_timer_start

+start :: MonadIO io => Timer -> io ()

+start = liftIO . withTimer c_timer_start

 

 -- | Update the timer.

-tick :: Timer -> IO Timer

-tick = withTimer' c_timer_tick

+tick :: MonadIO io => Timer -> io Timer

+tick = liftIO . withTimer' c_timer_tick

 

 -- | Get the current time.

-now :: IO TimePoint

-now = alloca $ \ptr -> do

+now :: MonadIO io => io TimePoint

+now = liftIO . alloca $ \ptr -> do

      c_time_now ptr

      peek ptr

 

@@ -172,6 +177,15 @@ timePointToNs t = unsafeDupablePerformIO $ alloca $ \ptr -> do
      poke ptr t

      return $ c_time_point_to_ns ptr

 

+-- | Add a time delta to a timestamp.

+timeAdd :: TimePoint -> TimeDelta -> TimePoint

+timeAdd t dt = unsafeDupablePerformIO $

+     alloca $ \tPtr ->

+     alloca $ \ptr -> do

+          poke tPtr t

+          c_time_add tPtr dt ptr

+          peek ptr

+

 -- | Put the caller thread to sleep for the given amount of time.

-sleep :: TimeDelta -> IO ()

-sleep = c_time_sleep

+sleep :: MonadIO io => TimeDelta -> io ()

+sleep = liftIO . c_time_sleep

diff --git a/Spear/Sys/Timer/timer.c b/Spear/Sys/Timer/timer.c
index 8487f48..4a2fb2b 100644
--- a/Spear/Sys/Timer/timer.c
+++ b/Spear/Sys/Timer/timer.c
@@ -48,7 +48,7 @@ void time_now(time_point* t) {
 #ifdef _WIN32

   QueryPerformanceCounter((LARGE_INTEGER*)t);

 #else

-  clock_gettime(CLOCK_REALTIME, t);

+  clock_gettime(CLOCK_MONOTONIC_RAW, t);

 #endif

 }

 

@@ -87,6 +87,15 @@ uint64_t time_point_to_ns(time_point* t) {
 #endif

 }

 

+void time_add(const time_point* t, time_delta dt, time_point* out) {

+#ifdef _WIN32

+  *out = *t + dt;

+#else

+  out->tv_sec  = t->tv_sec + (dt / nanoseconds);

+  out->tv_nsec = t->tv_nsec + (dt % nanoseconds);

+#endif

+}

+

 void time_sleep(time_delta dt) {

 #ifdef _WIN32

   const int64_t ms = dt / microseconds;

diff --git a/Spear/Sys/Timer/timer.h b/Spear/Sys/Timer/timer.h
index e426135..da4e7c7 100644
--- a/Spear/Sys/Timer/timer.h
+++ b/Spear/Sys/Timer/timer.h
@@ -53,6 +53,9 @@ time_delta sec_to_time_delta(double seconds);
 /// Convert the time point to nanoseconds.
 uint64_t time_point_to_ns(time_point*);
 
+/// Add a time delta to a timestamp.
+void time_add(const time_point*, time_delta, time_point* out);
+
 /// Put the caller thread to sleep for the given amount of time.
 void time_sleep(time_delta dt);
 
diff --git a/Spear/Window.hs b/Spear/Window.hs
index 3cdc5f5..a873362 100644
--- a/Spear/Window.hs
+++ b/Spear/Window.hs
@@ -7,7 +7,6 @@ module Spear.Window
     Window,
     Width,
     Height,
-    Init,
     WindowEvent(..),
     withWindow,
     pollWindowEvents,
@@ -21,10 +20,10 @@ module Spear.Window
     whenKeyUp,
     processKeys,
     processButtons,
-    InputEvent (..),
-    Key (..),
-    MouseButton (..),
-    MouseProp (..),
+    InputEvent(..),
+    Key(..),
+    MouseButton(..),
+    MouseProp(..),
     MousePos,
     MouseDelta,
   )
@@ -35,6 +34,7 @@ import           Spear.Game
 import           Control.Concurrent.MVar
 import           Control.Exception
 import           Control.Monad           (foldM, unless, void, when)
+import           Control.Monad.IO.Class
 import           Data.Functor            ((<&>))
 import           Data.Maybe              (fromJust, fromMaybe, isJust)
 import qualified Graphics.UI.GLFW        as GLFW
@@ -52,12 +52,6 @@ type Dimensions = (Width, Height)
 
 type WindowTitle = String
 
--- | Game initialiser.
-type Init s = Window -> Game () s
-
--- | Game finalizer.
-type End s = Game s ()
-
 -- | Window exception.
 newtype WindowException = WindowException String deriving (Show)
 
@@ -83,32 +77,19 @@ data Window = Window
   }
 
 
-withWindow ::
-  Dimensions ->
-  Maybe WindowTitle ->
-  Init s ->
-  End s ->
-  (Window -> Game s a) ->
-  IO a
-withWindow dim@(w, h) windowTitle init end run = do
-  flip evalGame () $ do
-    window <- gameIO $ do
-      success <- GLFW.init
-      unless success $ throw (WindowException "GLFW.initialize failed")
-      setup dim windowTitle
-    gameState <- init window
-    (result, endGameState) <- runSubGame (run window) gameState
-    runSubGame' end endGameState
-    gameIO $ do
-      GLFW.destroyWindow $ glfwWindow window
-      GLFW.terminate
-    return result
-
-setup ::
-  Dimensions ->
-  Maybe WindowTitle ->
-  IO Window
-setup (w, h) windowTitle = do
+withWindow :: MonadIO io => Dimensions -> WindowTitle -> (Window -> IO a) -> io a
+withWindow dim@(w, h) windowTitle run = liftIO $ do
+  window <- do
+    success <- GLFW.init
+    unless success $ throw (WindowException "GLFW.initialize failed")
+    setup dim windowTitle
+  result <- run window
+  GLFW.destroyWindow $ glfwWindow window
+  GLFW.terminate
+  return result
+
+setup :: MonadIO io => Dimensions -> WindowTitle -> io Window
+setup (w, h) windowTitle = liftIO $ do
   closeRequest <- newEmptyMVar
   windowEvents <- newEmptyMVar
   inputEvents  <- newEmptyMVar
@@ -118,7 +99,7 @@ setup (w, h) windowTitle = do
     GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major
     GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor
     when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
-    GLFW.createWindow w h (fromMaybe "Spear" windowTitle) Nothing Nothing
+    GLFW.createWindow w h windowTitle Nothing Nothing
 
   unless (isJust maybeWindow)
     $ throwIO (WindowException "GLFW.openWindow failed")
@@ -127,24 +108,25 @@ setup (w, h) windowTitle = do
 
   GLFW.makeContextCurrent maybeWindow
 
+  GLFW.swapInterval (-1) -- 1 enable vsync. -1 for adaptive vsync.
+
   GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest
   GLFW.setWindowSizeCallback  window . Just $ onResize      windowEvents
   GLFW.setKeyCallback         window . Just $ onKey         inputEvents
-  GLFW.setCharCallback        window . Just $ onChar        inputEvents
   GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents
   GLFW.setCursorPosCallback   window . Just $ onMouseMove   mousePos inputEvents
 
   return $ Window window closeRequest inputEvents windowEvents
 
 -- | Poll for input events.
-pollInputEvents :: Window -> IO [InputEvent]
-pollInputEvents window = do
+pollInputEvents :: MonadIO io => Window -> io [InputEvent]
+pollInputEvents window = liftIO $ do
   GLFW.pollEvents
-  getEvents (inputEventsMVar  window)
+  getEvents (inputEventsMVar window)
 
 -- | Poll for window events.
-pollWindowEvents :: Window -> IO [WindowEvent]
-pollWindowEvents window = do
+pollWindowEvents :: MonadIO io => Window -> io [WindowEvent]
+pollWindowEvents window = liftIO $ do
   GLFW.pollEvents
   getEvents (windowEventsMVar window)
 
@@ -156,16 +138,16 @@ getEvents mvar = tryTakeMVar mvar >>= \xs -> do
     Just events -> return events
 
 -- | Return true when the user requests to close the window.
-shouldWindowClose :: Window -> IO Bool
-shouldWindowClose = getRequest . closeRequestMVar
+shouldWindowClose :: MonadIO io => Window -> io Bool
+shouldWindowClose = liftIO . getRequest . closeRequestMVar
 
 -- | Swaps buffers.
-swapBuffers :: Window -> IO ()
-swapBuffers = GLFW.swapBuffers . glfwWindow
+swapBuffers :: MonadIO io => Window -> io ()
+swapBuffers = liftIO . GLFW.swapBuffers . glfwWindow
 
 -- | Get the window's size.
-getWindowSize :: Window -> IO (Width, Height)
-getWindowSize = GLFW.getWindowSize . glfwWindow
+getWindowSize :: MonadIO io => Window -> io (Width, Height)
+getWindowSize = liftIO . GLFW.getWindowSize . glfwWindow
 
 getRequest :: MVar Bool -> IO Bool
 getRequest mvar =
@@ -178,19 +160,16 @@ onWindowClose closeRequest window = putMVar closeRequest True
 -- the last in a poll can be ignored, we just replace the contents of the mvar
 -- here instead of adding the event to the list.
 onResize :: MVar [WindowEvent] -> GLFW.WindowSizeCallback
-onResize windowEvents window w h = putMVar windowEvents [ResizeEvent w h]
+onResize windowEvents window w h = modifyMVar_ windowEvents (return <$> const [ResizeEvent w h])
 
 onKey :: MVar [InputEvent] -> GLFW.KeyCallback
 onKey events window key _ GLFW.KeyState'Pressed   _ = addEvent events $ KeyDown (fromGLFWkey key)
-onKey events window key _ GLFW.KeyState'Released  _ = addEvent events $ KeyUp (fromGLFWkey key)
+onKey events window key _ GLFW.KeyState'Released  _ = addEvent events $ KeyUp   (fromGLFWkey key)
 onKey events window key _ GLFW.KeyState'Repeating _ = return ()
 
-onChar :: MVar [InputEvent] -> GLFW.CharCallback
-onChar events window char = addEvent events $ KeyDown . fromGLFWkey . read $ [char]
-
 onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback
-onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button)
-onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button)
+onMouseButton events window button GLFW.MouseButtonState'Pressed _  = addEvent events $ MouseDown (fromGLFWbutton button)
+onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp   (fromGLFWbutton button)
 
 onMouseMove :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback
 onMouseMove oldPos events window x y = do
@@ -214,39 +193,39 @@ addEvent mvar val =
 -- Input
 
 -- | Run the game action when the key is down.
-whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s ()
-whenKeyDown = whenKeyInState (== GLFW.KeyState'Pressed)
+whenKeyDown :: GLFW.Window -> Key -> Game s () -> Game s ()
+whenKeyDown = whenKeyInState GLFW.KeyState'Pressed
 
 -- | Run the game action when the key is up.
-whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s ()
-whenKeyUp = whenKeyInState (== GLFW.KeyState'Released)
+whenKeyUp :: GLFW.Window -> Key -> Game s () -> Game s ()
+whenKeyUp = whenKeyInState GLFW.KeyState'Released
 
-whenKeyInState :: (GLFW.KeyState -> Bool) -> GLFW.Window -> Key -> Game s a -> Game s ()
-whenKeyInState pred window key game = do
-  isDown <- fmap pred $ gameIO . GLFW.getKey window . toGLFWkey $ key
-  when isDown $ void game
+whenKeyInState :: GLFW.KeyState -> GLFW.Window -> Key -> Game s () -> Game s ()
+whenKeyInState state window key game = do
+  isDown <- fmap (==state) $ liftIO . GLFW.getKey window . toGLFWkey $ key
+  when isDown game
 
--- | Process the keyboard keys, returning those values for which their
--- corresponding key is pressed.
-processKeys :: GLFW.Window -> [(Key, a)] -> Game s [a]
+-- | Check whether the given keys are pressed and return the value associated
+-- with each of the pressed keys.
+processKeys :: Window -> [(Key, a)] -> Game s [a]
 processKeys window = foldM f []
   where
     f acc (key, result) = do
       isDown <-
         fmap (== GLFW.KeyState'Pressed) $
-          gameIO . GLFW.getKey window . toGLFWkey $
+          liftIO . GLFW.getKey (glfwWindow window) . toGLFWkey $
             key
       return $ if isDown then result : acc else acc
 
--- | Process the mouse buttons, returning those values for which their
--- corresponding button is pressed.
-processButtons :: GLFW.Window -> [(MouseButton, a)] -> Game s [a]
+-- | Check whether the given buttons are pressed and return the value associated
+-- with each of the pressed buttons.
+processButtons :: Window -> [(MouseButton, a)] -> Game s [a]
 processButtons window = foldM f []
   where
     f acc (button, result) = do
       isDown <-
         fmap (== GLFW.MouseButtonState'Pressed) $
-          gameIO . GLFW.getMouseButton window . toGLFWbutton $
+          liftIO . GLFW.getMouseButton (glfwWindow window) . toGLFWbutton $
             button
       return $ if isDown then result : acc else acc