1 files changed, 99 insertions, 87 deletions

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