3 files changed, 296 insertions, 97 deletions

diff --git a/Demos/Balls/Main.hs b/Demos/Balls/Main.hs
new file mode 100644
index 0000000..d266d85
--- /dev/null
+++ b/Demos/Balls/Main.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+--{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+
+module Main where
+
+import           Spear.App
+import           Spear.Game
+import           Spear.Math.AABB
+import qualified Spear.Math.Matrix3         as Matrix3
+import qualified Spear.Math.Matrix4         as Matrix4
+import           Spear.Math.Spatial
+import           Spear.Math.Spatial2
+import           Spear.Math.Vector
+import           Spear.Physics.Collision
+--import           Spear.Prelude
+import           Spear.Render.Core.Pipeline
+import           Spear.Render.Core.State
+import           Spear.Render.Immediate
+import           Spear.Sound.Sound
+import           Spear.Sound.State
+import           Spear.Window
+
+import           Control.Monad              (when)
+
+
+ballSize = 0.01
+numBalls = 1000
+
+data Ball = Ball
+  { ballPosition :: {-# UNPACK #-} !Vector2
+  , ballVelocity :: {-# UNPACK #-} !Vector2
+  }
+
+instance Positional Ball Vector2 where
+  setPosition p ball = ball { ballPosition = p }
+  position = ballPosition
+  translate v ball = ball { ballPosition = v + ballPosition ball }
+
+instance Bounded2 Ball where
+  boundingVolume ball = aabb2Volume $ translate (ballPosition ball) (AABB2 (-size) size)
+    where size = vec2 s s
+          s    = ballSize / (2::Float)
+
+data World = World
+  { viewProjection :: Matrix4.Matrix4
+  , balls          :: [Ball]
+  }
+
+type GameState = AppState World
+
+
+options = defaultAppOptions { title = "Balls" }
+
+app = App options initGame endGame step render resize
+
+
+main :: IO ()
+main = runApp app
+
+initGame :: Game AppContext World
+initGame =
+  let
+    world          = zipWith Ball positions velocities
+    positions      = (+vec2 0.5 0.5) . makePosition <$> numbers
+    makePosition i = radius * vec2 (sin (f*i)) (cos (f*i))
+    velocities     = makeVelocity <$> numbers
+    makeVelocity i = scale speed $ vec2 (sin (f*i)) (cos (f*i))
+    numbers        = [1..numBalls]
+    f              = 2*pi / numBalls
+    radius         = 0.05
+    speed          = 0.4
+  in
+    return $ World Matrix4.id world
+
+endGame :: Game GameState ()
+endGame = return ()
+
+
+step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
+step elapsed dt inputEvents = do
+  modifyGameState $ \world -> world
+    { balls = moveBalls dt $ balls world
+    }
+  return (not $ exitRequested inputEvents)
+
+exitRequested = elem (KeyDown KEY_ESC)
+
+moveBalls :: Elapsed -> [Ball] -> [Ball]
+moveBalls dt = (bounceBall dt . moveBall dt <$>)
+
+moveBall :: Elapsed -> Ball -> Ball
+moveBall dt ball = translate (scale (realToFrac dt) $ ballVelocity ball) ball
+
+bounceBall :: Elapsed -> Ball -> Ball
+bounceBall dt 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
+    velocity = ballVelocity ball
+    velocity'
+      = flipX
+      . flipY
+      $ velocity
+    collision = velocity' /= velocity
+    -- Apply offset when collision occurs to avoid sticky collisions.
+    delta = if collision then 1 else 0
+    dt' = realToFrac dt
+   in
+    ball
+    { ballPosition = ballPosition ball + scale (delta * dt') velocity'
+    , ballVelocity = velocity'
+    }
+
+
+render :: Game GameState ()
+render = do
+  gameState <- getGameState
+  siblingGame $ do
+    immStart
+    immSetViewProjectionMatrix (viewProjection gameState)
+    -- Clear the background to a different colour than the playable area to make
+    -- the latter distinguishable.
+    setClearColour (0.2, 0.2, 0.2, 0.0)
+    clearBuffers [ColourBuffer]
+    render' $ balls gameState
+    immEnd
+
+render' :: [Ball] -> Game ImmRenderState ()
+render' balls = do
+  immLoadIdentity
+  renderBackground
+  -- Draw objects.
+  immSetColour (vec4 1.0 1.0 1.0 1.0)
+  mapM_ renderBall balls
+
+renderBackground :: Game ImmRenderState ()
+renderBackground =
+  let pmin = 0 :: Float
+      pmax = 1 :: Float
+  in do
+    immSetColour (vec4 0.0 0.25 0.41 1.0)
+    immDrawQuads2d [
+      (vec2 pmin pmin
+      ,vec2 pmax pmin
+      ,vec2 pmax pmax
+      ,vec2 pmin pmax)]
+
+renderBall :: Ball -> Game ImmRenderState ()
+renderBall ball =
+  let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume ball
+  in
+    immDrawQuads2d [
+      (vec2 xmin ymin
+      ,vec2 xmax ymin
+      ,vec2 xmax ymax
+      ,vec2 xmin ymax)]
+
+
+resize :: WindowEvent -> Game GameState ()
+resize (ResizeEvent w h) =
+  let r = fromIntegral w / fromIntegral h
+      pad    = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
+      left   = if r > 1 then -pad else 0
+      right  = if r > 1 then 1 + pad else 1
+      bottom = if r > 1 then 0 else -pad
+      top    = if r > 1 then 1 else 1 + pad
+  in do
+    setViewport 0 0 w h
+    modifyGameState $ \pong -> pong {
+      viewProjection = Matrix4.ortho left right bottom top (-1) 1
+    }
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index d51a324..22b1021 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module Main where
 
 import           Pong
@@ -5,52 +7,62 @@ import           Pong
 import           Spear.App
 import           Spear.Game
 import           Spear.Math.AABB
-import           Spear.Math.Matrix4         as Matrix4 hiding (position)
+import           Spear.Math.Matrix4         as Matrix4
 import           Spear.Math.Spatial
 import           Spear.Math.Spatial2
 import           Spear.Math.Vector
+import           Spear.Physics.Collision
 import           Spear.Render.Core.Pipeline
 import           Spear.Render.Core.State
 import           Spear.Render.Immediate
+import           Spear.Sound.Sound
+import           Spear.Sound.State
 import           Spear.Window
 
 import           Control.Monad              (when)
-import           Data.Maybe                 (mapMaybe)
 
 
-data GameState = GameState
-  { window          :: Window
-  , renderCoreState :: RenderCoreState
-  , immRenderState  :: ImmRenderState
-  , viewProjection  :: Matrix4
+data Pong = Pong
+  { viewProjection  :: Matrix4
+  , backgroundMusic :: SoundSource
   , world           :: [GameObject]
   }
 
-app = App defaultAppOptions step render resize
+type GameState = AppState Pong
+
+
+options = defaultAppOptions { title = "Pong" }
+
+app = App options initGame endGame step render resize
+
 
-main =
-  withWindow (1920, 1200) (Just "Pong") initGame endGame $
-    loop app
+main :: IO ()
+main = runApp app
 
-initGame :: Window -> Game () GameState
-initGame window = do
-  (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState
-  return $ GameState window renderCoreState immRenderState Matrix4.id newWorld
+initGame :: Game AppContext Pong
+initGame = do
+  music <- siblingGame $ do
+    musicBuffer <- loadAudioFile "/home/jeanne/Casual Tiki Party Main.wav"
+    music <- makeSoundSource
+    setSoundSourceBuffer music musicBuffer
+    setSoundLoopMode music Loop
+    playSounds [music]
+    return music
+  return $ Pong Matrix4.id music newWorld
 
 endGame :: Game GameState ()
-endGame = do
-  game <- getGameState
-  runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)
+endGame = return ()
+
 
 step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
 step elapsed dt inputEvents = do
-  gs <- getGameState
-  events <- processInput (window gs)
-  --when (events /= []) $ gameIO . putStrLn $ show events
-  modifyGameState $ \gs ->
-    gs
-      { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
-      }
+  appState  <- get
+  gameState <- getGameState
+  events    <- processInput (appWindow appState)
+  --when (events /= []) $ liftIO . putStrLn $ show events
+  modifyGameState $ \pong -> pong
+    { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gameState)
+    }
   return (not $ exitRequested inputEvents)
 
 processInput :: Window -> Game GameState [GameEvent]
@@ -61,20 +73,19 @@ processInput window = processKeys window
 
 exitRequested = elem (KeyDown KEY_ESC)
 
+
 render :: Game GameState ()
 render = do
   gameState <- getGameState
-  immRenderState' <- flip execSubGame (immRenderState gameState) $ do
+  siblingGame $ do
     immStart
     immSetViewProjectionMatrix (viewProjection gameState)
     -- Clear the background to a different colour than the playable area to make
     -- the latter distinguishable.
-    gameIO $ do
-      setClearColour (0.2, 0.2, 0.2, 0.0)
-      clearBuffers [ColourBuffer]
+    setClearColour (0.2, 0.2, 0.2, 0.0)
+    clearBuffers [ColourBuffer]
     render' $ world gameState
     immEnd
-  saveGameState $ gameState { immRenderState = immRenderState' }
 
 render' :: [GameObject] -> Game ImmRenderState ()
 render' world = do
@@ -97,17 +108,16 @@ renderBackground =
       ,vec2 pmin pmax)]
 
 renderGO :: GameObject -> Game ImmRenderState ()
-renderGO go = do
-  let (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax)) = aabb go
-      (Vector2 xcenter ycenter) = position go
-  immPreservingMatrix $ do
-    immTranslate (vec3 xcenter ycenter 0)
+renderGO go =
+  let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume go
+  in
     immDrawQuads2d [
       (vec2 xmin ymin
       ,vec2 xmax ymin
       ,vec2 xmax ymax
       ,vec2 xmin ymax)]
 
+
 resize :: WindowEvent -> Game GameState ()
 resize (ResizeEvent w h) =
   let r = fromIntegral w / fromIntegral h
@@ -117,7 +127,7 @@ resize (ResizeEvent w h) =
       bottom = if r > 1 then 0 else -pad
       top    = if r > 1 then 1 else 1 + pad
   in do
-    gameIO $ setViewport 0 0 w h
-    modifyGameState $ \state -> state {
+    setViewport 0 0 w h
+    modifyGameState $ \pong -> pong {
       viewProjection = Matrix4.ortho left right bottom top (-1) 1
     }
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