1 files changed, 73 insertions, 60 deletions

diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs
index b9661ee..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,16 +15,17 @@ 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.015
-ballSize            = 0.012 :: 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)
@@ -41,14 +41,22 @@ initialBallPos      = vec2 0.5 0.5
 data GameEvent
   = MoveLeft
   | MoveRight
-  deriving (Eq, Ord, Show)
+  | 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
   }
 
 
@@ -78,76 +86,83 @@ instance Spatial GameObject Vector2 Angle Transform2 where
   transform = basis
 
 
-ballBox, padBox :: AABB2
-ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
-padBox  = AABB2 (-padSize) padSize
+instance Bounded2 GameObject where
+  boundingVolume obj = aabb2Volume $ translate (position obj) (AABB2 (-size) size)
+    where size = gameObjectSize obj
+
 
 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 evts gos = map (update elapsed dt evts gos) gos
+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 evts gos go =
-  let (go', s') = runStep (gostep go) elapsed dt gos evts go
-   in go' {gostep = s'}
+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
+stepBall vel = bounceBall vel .> moveBall -- .> clamp
 
-collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
-collideBall vel = step $ \_ dt gos _ ball ->
-  let (AABB2 pmin pmax) = translate (position ball) (aabb ball)
+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
-      vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel
+      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), collideBall vel')
+   in ((ballSpeed * delta * vel', ball), bounceBall vel')
 
-paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2
-paddleBounce ball v paddle =
-  if collide ball paddle
+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 0 .> clamp
+stepEnemy = movePad 0 .> spure clamp
 
 movePad :: Float -> Step [GameObject] e GameObject GameObject
 movePad previousMomentumVector = step $ \_ dt gos _ pad ->
@@ -158,28 +173,26 @@ movePad previousMomentumVector = step $ \_ dt gos _ pad ->
       vx             = chaseVector * dt + momentumVector
    in (translate (vec2 vx 0) pad, movePad momentumVector)
 
-sign :: Float -> Float
-sign x = if x >= 0 then 1 else -1
 
 -- Player stepper
 
-stepPlayer = sfold moveGO .> clamp
+stepPlayer = sfold movePlayer .> spure clamp
 
-moveGO = mconcat
-  [ swhen MoveLeft  $ moveGO' (vec2 (-playerSpeed) 0)
-  , swhen 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