2 files changed, 55 insertions, 56 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)