New physics module.

1 files changed, 61 insertions, 40 deletions

diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs
index b9661ee..b12f792 100644
--- a/Demos/Pong/Pong.hs
+++ b/Demos/Pong/Pong.hs
@@ -16,10 +16,11 @@ 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
@@ -41,14 +42,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
+  , aabb         :: {-# UNPACK #-} !AABB2
+  , basis        :: {-# UNPACK #-} !Transform2
+  , gostep       :: Step [GameObject] [GameEvent] GameObject GameObject
   }
 
 
@@ -78,46 +87,68 @@ instance Spatial GameObject Vector2 Angle Transform2 where
   transform = basis
 
 
+instance Bounded2 GameObject where
+  boundingVolume obj = aabb2Volume $ translate (position obj) (aabb 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   ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
+    GameObject Enemy  padBox  (makeAt initialEnemyPos)  stepEnemy,
+    GameObject Player padBox  (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
+    gos' = map (update elapsed dt events' gos) gos
+  in
+    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
 
-collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
-collideBall vel = step $ \_ dt gos _ ball ->
+bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
+bounceBall vel = step $ \_ dt gos events ball ->
   let (AABB2 pmin pmax) = translate (position ball) (aabb 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)
         center = (x pmin + x pmax) / (2::Float)
@@ -126,25 +157,14 @@ paddleBounce ball v paddle =
         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
@@ -161,17 +181,18 @@ movePad previousMomentumVector = step $ \_ dt gos _ pad ->
 sign :: Float -> Float
 sign x = if x >= 0 then 1 else -1
 
+
 -- Player stepper
 
-stepPlayer = sfold moveGO .> clamp
+stepPlayer = sfold movePlayer .> 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 ->