1 files changed, 176 insertions, 0 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
+    }