5 files changed, 313 insertions, 0 deletions

diff --git a/demos/pong/LICENSE b/demos/pong/LICENSE
new file mode 100644
index 0000000..2ad9c8d
--- /dev/null
+++ b/demos/pong/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2013, Marc Sunet
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Marc Sunet nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs
new file mode 100644
index 0000000..8c379ec
--- /dev/null
+++ b/demos/pong/Main.hs
@@ -0,0 +1,86 @@
+module Main where
+
+import Pong
+
+import Spear.Math.AABB
+import Spear.Math.Spatial2
+import Spear.Math.Vector
+import Spear.Game
+import Spear.Window
+
+import Data.Maybe (mapMaybe)
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import Graphics.Rendering.OpenGL.GL (($=))
+
+data GameState = GameState
+     { wnd     :: Window
+     , elapsed :: Double
+     , world   :: [GameObject]
+     }
+
+main = do
+     result <- run
+     case result of
+          Left err -> putStrLn err
+          Right _  -> return ()
+
+run = withWindow (640,480) [] Window (2,0) (Just "Pong") initGame
+    $ loop (Just 30) step
+
+initGame wnd = do
+         gameIO $ do
+                GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0
+                GL.matrixMode $= GL.Modelview 0
+                GL.loadIdentity
+         return $ GameState wnd 0 newWorld
+
+step :: Dt -> Game GameState Bool
+step dt = do
+     gs <- getGameState
+     evts <- events (wnd gs)
+     gameIO . process $ evts
+     let evts' = translate evts
+     modifyGameState $ \ gs -> gs
+                     { world = stepWorld (elapsed gs) dt evts' (world gs)
+                     , elapsed = elapsed gs + realToFrac dt }
+     getGameState >>= \gs -> gameIO . render $ world gs
+     return (not $ exitRequested evts)
+
+render world = do
+       GL.clear [GL.ColorBuffer]
+       mapM_ renderGO world
+       swapBuffers
+
+renderGO :: GameObject -> IO ()
+renderGO go = do
+         let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go
+             (Vector2 xcenter ycenter) = pos go
+             (xmin,ymin,xmax,ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax')
+         GL.preservingMatrix $ do
+            GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0)
+            GL.renderPrimitive (GL.TriangleStrip) $ do
+               GL.vertex (GL.Vertex2 xmin ymax)
+               GL.vertex (GL.Vertex2 xmin ymin)
+               GL.vertex (GL.Vertex2 xmax ymax)
+               GL.vertex (GL.Vertex2 xmax ymin)
+
+process = mapM_ procEvent
+procEvent (Resize w h) = do
+          GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
+          GL.matrixMode $= GL.Projection
+          GL.loadIdentity
+          GL.ortho 0 1 0 1 (-1) 1
+          GL.matrixMode $= GL.Modelview 0
+procEvent _ = return ()
+
+translate = mapMaybe translate'
+translate' (KeyDown KEY_LEFT)  = Just MoveLeft
+translate' (KeyDown KEY_RIGHT) = Just MoveRight
+translate' (KeyUp   KEY_LEFT)  = Just StopLeft
+translate' (KeyUp   KEY_RIGHT) = Just StopRight
+translate' _ = Nothing
+
+exitRequested = any (==(KeyDown KEY_ESC))
+
+f2d :: Float -> GL.GLdouble
+f2d = realToFrac
\ No newline at end of file
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
diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/demos/pong/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal
new file mode 100644
index 0000000..bebedb9
--- /dev/null
+++ b/demos/pong/pong.cabal
@@ -0,0 +1,21 @@
+-- Initial pong.cabal generated by cabal init.  For further documentation, 
+-- see http://haskell.org/cabal/users-guide/
+
+name:                pong
+version:             0.1.0.0
+synopsis:            A pong clone
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              Marc Sunet
+-- maintainer:          
+-- copyright:           
+category:            Game
+build-type:          Simple
+cabal-version:       >=1.8
+
+executable pong
+  -- hs-source-dirs:      src
+  main-is:             Main.hs
+  -- other-modules:       
+  build-depends:       base ==4.6.*, Spear, OpenGL