Added pong

1 files changed, 174 insertions, 0 deletions

diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs
new file mode 100644
index 0000000..9a3138b
--- /dev/null
+++ b/demos/pong/Pong.hs
@@ -0,0 +1,174 @@
+module Pong
+(
+    GameEvent(..)
+,   GameObject
+,   newWorld
+,   stepWorld
+,   aabb
+)
+where
+
+import Spear.Math.AABB
+import Spear.Math.Spatial2
+import Spear.Math.Vector
+
+import Data.List (foldl')
+import Data.Monoid
+import GHC.Float (double2Float)
+
+type Elapsed = Double
+type Dt = Float
+
+-- Step function
+
+data Step a b = Step { step :: Elapsed -> Dt -> a -> (b, Step a b) }
+
+sid :: Step a a
+sid = Step $ \_ _ a -> (a, sid)
+
+spure :: (a -> b) -> Step a b
+spure f = Step $ \_ _ x -> (f x, spure f)
+
+smap :: (a -> b) -> Step c a -> Step c b
+smap f (Step s1) = Step $ \elapsed dt x ->
+     let (a, s') = s1 elapsed dt x
+     in (f a, smap f s')
+
+(.>) :: Step a b -> Step b c -> Step a c
+(Step s1) .> (Step s2) = Step $ \elapsed dt a ->
+      let (b, s1') = s1 elapsed dt a
+          (c, s2') = s2 elapsed dt b
+      in (c, s1' .> s2')
+
+(.<) :: Step a b -> Step c a -> Step c b
+(.<) = flip (.>)
+
+sfst :: Step (a,b) a
+sfst = spure $ \(a,_) -> a
+
+ssnd :: Step (a,b) b
+ssnd = spure $ \(_,b) -> b
+
+-- Game events
+
+data GameEvent
+     = MoveLeft
+     | MoveRight
+     | StopLeft
+     | StopRight
+     deriving Eq
+
+-- Game objects
+
+data GameObject = GameObject
+     { aabb   :: AABB2
+     , obj    :: Obj2
+     , gostep :: Step ([GameEvent], [GameObject], GameObject) GameObject
+     }
+
+instance Spatial2 GameObject where
+         getObj2 = obj
+         setObj2 s o = s { obj = o }
+
+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') = step (gostep go) elapsed dt (evts, gos, go)
+       in go' { gostep = s' }
+
+ballBox :: AABB2
+ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01
+
+padSize = vec2 0.05 0.02
+
+padBox = AABB2 (-padSize) padSize
+
+obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y)
+
+ballVelocity = Vector2 0.3 0.3
+
+newWorld =
+         [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity
+         , GameObject padBox  (obj2 0.5 0.9) stepEnemy
+         , GameObject padBox  (obj2 0.5 0.1) stepPlayer
+         ]
+
+-- Generic steppers
+
+ignore :: Step ([GameEvent], [GameObject], GameObject) GameObject
+ignore = spure $ \(_,_,go) -> go
+
+ignoreEvts :: Step ([GameEvent], [GameObject], GameObject) ([GameObject], GameObject)
+ignoreEvts = spure $ \(_, world, go) -> (world, go)
+
+ignoreGOs :: Step ([GameEvent], [GameObject], GameObject) ([GameEvent], GameObject)
+ignoreGOs = spure $ \(evts, _, go) -> (evts, go)
+
+-- Ball steppers
+
+stepBall vel = ignoreEvts .> collideBall vel .> moveBall
+
+collideBall :: Vector2 -> Step ([GameObject], GameObject) (Vector2, GameObject)
+collideBall vel = Step $ \_ _ (gos, ball) ->
+            let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball
+                collideCol = x pmin < 0 || x pmax > 1
+                collideRow = y pmin < 0 || y pmax > 1
+                           || any (collide ball) (tail gos)
+                negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v
+                negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v
+                vel' = negx . negy $ vel
+            in ((vel', ball), collideBall vel')
+
+collide go1 go2 =
+        let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1))
+                   = aabb go1 `aabbAdd` pos go1
+            (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2))
+                   = aabb go2 `aabbAdd` pos go2
+        in not $  xmax1 < xmin2 || xmin1 > xmax2
+               || ymax1 < ymin2 || ymin1 > ymax2
+
+aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax)
+
+moveBall :: Step (Vector2, GameObject) GameObject
+moveBall = Step $ \_ dt (vel,ball) -> (move (scale dt vel) ball, moveBall)
+
+-- Enemy stepper
+
+stepEnemy = ignore .> movePad
+
+movePad :: Step GameObject GameObject
+movePad = Step $ \elapsed _ pad ->
+        let p  = vec2 px 0.9
+            px = double2Float (sin elapsed * 0.5 + 0.5)
+               * (1 - 2 * x padSize)
+               + x padSize
+        in (setPos p pad, movePad)
+
+-- Player stepper
+
+stepPlayer = ignoreGOs
+           .> moveGO False MoveLeft StopLeft
+           .> moveGO False MoveRight StopRight
+           .> ssnd
+           .> clamp
+
+moveGO :: Bool -> GameEvent -> GameEvent
+       -> Step ([GameEvent], GameObject) ([GameEvent], GameObject)
+moveGO moving start stop = Step $ \_ dt (evts, go) ->
+       let moving' = (moving || any (==start) evts) && not (any (==stop) evts)
+           dir = scale dt $ toDir moving' start
+       in ((evts, move dir go), moveGO moving' start stop)
+
+clamp :: Step GameObject GameObject
+clamp = spure $ \go ->
+      let p' = vec2 (clamp' x s (1 - s)) y
+          (Vector2 x y) = pos go
+          clamp' x a b = if x < a then a else if x > b then b else x
+          (Vector2 s _) = padSize
+      in setPos p' go
+
+toDir True MoveLeft  = vec2 (-1) 0
+toDir True MoveRight = vec2 1 0
+toDir _ _ = vec2 0 0
\ No newline at end of file