From e15a9cc51e31b5deb973d8583298aa130dd82b17 Mon Sep 17 00:00:00 2001 From: Jeanne-Kamikaze 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/pong') 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