From e15a9cc51e31b5deb973d8583298aa130dd82b17 Mon Sep 17 00:00:00 2001
From: Jeanne-Kamikaze <jeannekamikaze@gmail.com>
Date: Sat, 10 Aug 2013 17:24:17 +0200
Subject: Added pong
---
demos/pong/LICENSE | 30 +++++++++
demos/pong/Main.hs | 86 +++++++++++++++++++++++++
demos/pong/Pong.hs | 174 ++++++++++++++++++++++++++++++++++++++++++++++++++
demos/pong/Setup.hs | 2 +
demos/pong/pong.cabal | 21 ++++++
5 files changed, 313 insertions(+)
create mode 100644 demos/pong/LICENSE
create mode 100644 demos/pong/Main.hs
create mode 100644 demos/pong/Pong.hs
create mode 100644 demos/pong/Setup.hs
create mode 100644 demos/pong/pong.cabal
(limited to 'demos')
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
--
cgit v1.2.3