7 files changed, 120 insertions, 125 deletions

diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index 0237a26..21fcb0c 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -14,6 +14,7 @@ import           Spear.Render.Core.State
 import           Spear.Render.Immediate
 import           Spear.Window
 
+import           Control.Monad              (when)
 import           Data.Maybe                 (mapMaybe)
 
 
@@ -28,7 +29,7 @@ data GameState = GameState
 app = App step render resize
 
 main =
-  withWindow (900, 600) (Just "Pong") initGame endGame $
+  withWindow (1920, 1200) (Just "Pong") initGame endGame $
     loop app
 
 initGame :: Window -> Game () GameState
@@ -44,13 +45,22 @@ endGame = do
 step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
 step elapsed dt inputEvents = do
   gs <- getGameState
-  let events = translateEvents inputEvents
+  events <- processInput (window gs)
+  --when (events /= []) $ gameIO . putStrLn $ show events
   modifyGameState $ \gs ->
     gs
       { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
       }
   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
@@ -79,7 +89,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
@@ -98,7 +108,6 @@ renderGO go = do
       ,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
@@ -112,12 +121,3 @@ resize (ResizeEvent w h) =
     modifyGameState $ \state -> state {
       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..dd8855b 100644
--- a/Demos/Pong/Pong.hs
+++ b/Demos/Pong/Pong.hs
@@ -24,13 +24,14 @@ import           Data.Monoid         (mconcat)
 
 -- Configuration
 
-padSize             = vec2 0.07 0.02
+padSize             = vec2 0.07 0.015
 ballSize            = 0.012 :: Float
-ballSpeed           = 0.6 :: Float
+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       = 0.1 :: Float
 initialEnemyPos     = vec2 0.5 0.9
 initialPlayerPos    = vec2 0.5 0.1
 initialBallPos      = vec2 0.5 0.5
@@ -40,9 +41,7 @@ initialBallPos      = vec2 0.5 0.5
 data GameEvent
   = MoveLeft
   | MoveRight
-  | StopLeft
-  | StopRight
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Show)
 
 -- Game objects
 
@@ -79,17 +78,9 @@ 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'}
-
 ballBox, padBox :: AABB2
 ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
-padBox = AABB2 (-padSize) padSize
+padBox  = AABB2 (-padSize) padSize
 
 newWorld =
   [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
@@ -98,23 +89,30 @@ newWorld =
   ]
   where makeAt = newTransform2 unitx2 unity2
 
+
+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'}
+
 -- 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
+      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
       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)
+      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), collideBall vel')
 
 paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2
@@ -139,37 +137,38 @@ collide go1 go2 =
       (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
         translate (position go2) (aabb go2)
    in not $
-        xmax1 < xmin2
-          || xmin1 > xmax2
-          || ymax1 < ymin2
-          || ymin1 > ymax2
+       xmax1 < xmin2 ||
+       xmin1 > xmax2 ||
+       ymax1 < ymin2 ||
+       ymin1 > ymax2
 
 moveBall :: Step s e (Vector2, GameObject) GameObject
 moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
 
 -- Enemy stepper
 
-stepEnemy = movePad
+stepEnemy = movePad 0 .> clamp
 
-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)
+movePad :: Float -> Step [GameObject] e GameObject GameObject
+movePad previousMomentum = step $ \_ dt gos _ pad ->
+  let ball        = head gos
+      offset      = (x . position $ ball) - (x . position $ pad)
+      chaseVector = enemySpeed * offset
+      momentum    = previousMomentum + enemyMomentum * chaseVector
+      vx          = chaseVector + momentum
+   in (translate (vec2 (vx * dt) 0) pad, movePad momentum)
+
+sign :: Float -> Float
+sign x = if x >= 0 then 1 else -1
 
 -- Player stepper
 
 stepPlayer = sfold moveGO .> clamp
 
-moveGO =
-  mconcat
-    [ switch StopLeft  sid MoveLeft  (moveGO' $ vec2 (-playerSpeed) 0),
-      switch StopRight sid MoveRight (moveGO' $ vec2   playerSpeed  0)
-    ]
+moveGO = mconcat
+  [ swhen MoveLeft  $ moveGO' (vec2 (-playerSpeed) 0)
+  , swhen MoveRight $ moveGO' (vec2   playerSpeed  0)
+  ]
 
 moveGO' :: Vector2 -> Step s e GameObject GameObject
 moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir)
diff --git a/Spear.cabal b/Spear.cabal
index b044ae2..c327cf9 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -129,12 +129,14 @@ library
 

     hs-source-dirs: .

 

-    ghc-options: -O2

+    ghc-options: -O2 -g

 

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

+    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

+  ghc-options:         -O2 -g

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

diff --git a/Spear/App.hs b/Spear/App.hs
index f70dd06..b0c7141 100644
--- a/Spear/App.hs
+++ b/Spear/App.hs
@@ -57,16 +57,19 @@ loop' ::
 loop' window ddt inputTimer elapsed timeBudget app = do
   timer <- gameIO $ tick inputTimer
 
+  inputEvents <- gameIO $ pollInputEvents window
+
   let timeBudgetThisFrame = timeBudget + deltaTime timer
   let steps = timeBudgetThisFrame `div` ddt
 
+  --gameIO . putStrLn $ "Steps: " ++ show steps
+
   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 elapsed'    = elapsed + steps * ddt
   let timeBudget' = timeBudgetThisFrame `mod` ddt
 
   when continue $ do
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/Step.hs b/Spear/Step.hs
index cb4f71c..a860247 100644
--- a/Spear/Step.hs
+++ b/Spear/Step.hs
@@ -21,6 +21,7 @@ module Spear.Step
     (.>),
     (<.),
     szip,
+    swhen,
     switch,
     multiSwitch,
   )
@@ -36,8 +37,8 @@ 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 a b = Step
+  { runStep :: Elapsed -> Dt -> state -> events -> a -> (b, Step state events a b)
   }
 
 instance Functor (Step s e a) where
@@ -73,29 +74,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 +101,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 current step runs with every 'runStep' even when there are no new events.
 --
--- The initial step is the first one.
+-- The initial step is the identity, 'sid'.
 switch ::
   Eq e =>
   e ->
@@ -127,16 +124,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 +135,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/Window.hs b/Spear/Window.hs
index 3cdc5f5..be52080 100644
--- a/Spear/Window.hs
+++ b/Spear/Window.hs
@@ -127,10 +127,11 @@ setup (w, h) windowTitle = do
 
   GLFW.makeContextCurrent maybeWindow
 
+  GLFW.swapInterval 1 -- Enable 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
 
@@ -178,19 +179,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
@@ -208,45 +206,45 @@ replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val
 addEvent :: MVar [a] -> a -> IO ()
 addEvent mvar val =
   tryTakeMVar mvar >>= \xs -> case xs of
-    Nothing     -> putMVar mvar [val]
-    Just events -> putMVar mvar (val : events)
+    Nothing     -> putMVar mvar [val] -- >> (putStrLn $ show val)
+    Just events -> putMVar mvar (val : events) -- >> (putStrLn $ show (val:events))
 
 -- 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 = 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 = 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
+whenKeyInState :: GLFW.KeyState -> GLFW.Window -> Key -> Game s a -> Game s ()
+whenKeyInState state window key game = do
+  isDown <- fmap (==state) $ gameIO . GLFW.getKey window . toGLFWkey $ key
   when isDown $ void 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 $
+          gameIO . 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 $
+          gameIO . GLFW.getMouseButton (glfwWindow window) . toGLFWbutton $
             button
       return $ if isDown then result : acc else acc