diff options
Diffstat (limited to 'demos')
-rw-r--r-- | demos/pong/LICENSE | 30 | ||||
-rw-r--r-- | demos/pong/Main.hs | 86 | ||||
-rw-r--r-- | demos/pong/Pong.hs | 174 | ||||
-rw-r--r-- | demos/pong/Setup.hs | 2 | ||||
-rw-r--r-- | demos/pong/pong.cabal | 21 |
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 @@ | |||
1 | Copyright (c) 2013, Marc Sunet | ||
2 | |||
3 | All rights reserved. | ||
4 | |||
5 | Redistribution and use in source and binary forms, with or without | ||
6 | modification, are permitted provided that the following conditions are met: | ||
7 | |||
8 | * Redistributions of source code must retain the above copyright | ||
9 | notice, this list of conditions and the following disclaimer. | ||
10 | |||
11 | * Redistributions in binary form must reproduce the above | ||
12 | copyright notice, this list of conditions and the following | ||
13 | disclaimer in the documentation and/or other materials provided | ||
14 | with the distribution. | ||
15 | |||
16 | * Neither the name of Marc Sunet nor the names of other | ||
17 | contributors may be used to endorse or promote products derived | ||
18 | from this software without specific prior written permission. | ||
19 | |||
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT | ||
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||
30 | 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 @@ | |||
1 | module Main where | ||
2 | |||
3 | import Pong | ||
4 | |||
5 | import Spear.Math.AABB | ||
6 | import Spear.Math.Spatial2 | ||
7 | import Spear.Math.Vector | ||
8 | import Spear.Game | ||
9 | import Spear.Window | ||
10 | |||
11 | import Data.Maybe (mapMaybe) | ||
12 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
13 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
14 | |||
15 | data GameState = GameState | ||
16 | { wnd :: Window | ||
17 | , elapsed :: Double | ||
18 | , world :: [GameObject] | ||
19 | } | ||
20 | |||
21 | main = do | ||
22 | result <- run | ||
23 | case result of | ||
24 | Left err -> putStrLn err | ||
25 | Right _ -> return () | ||
26 | |||
27 | run = withWindow (640,480) [] Window (2,0) (Just "Pong") initGame | ||
28 | $ loop (Just 30) step | ||
29 | |||
30 | initGame wnd = do | ||
31 | gameIO $ do | ||
32 | GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 | ||
33 | GL.matrixMode $= GL.Modelview 0 | ||
34 | GL.loadIdentity | ||
35 | return $ GameState wnd 0 newWorld | ||
36 | |||
37 | step :: Dt -> Game GameState Bool | ||
38 | step dt = do | ||
39 | gs <- getGameState | ||
40 | evts <- events (wnd gs) | ||
41 | gameIO . process $ evts | ||
42 | let evts' = translate evts | ||
43 | modifyGameState $ \ gs -> gs | ||
44 | { world = stepWorld (elapsed gs) dt evts' (world gs) | ||
45 | , elapsed = elapsed gs + realToFrac dt } | ||
46 | getGameState >>= \gs -> gameIO . render $ world gs | ||
47 | return (not $ exitRequested evts) | ||
48 | |||
49 | render world = do | ||
50 | GL.clear [GL.ColorBuffer] | ||
51 | mapM_ renderGO world | ||
52 | swapBuffers | ||
53 | |||
54 | renderGO :: GameObject -> IO () | ||
55 | renderGO go = do | ||
56 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go | ||
57 | (Vector2 xcenter ycenter) = pos go | ||
58 | (xmin,ymin,xmax,ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') | ||
59 | GL.preservingMatrix $ do | ||
60 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) | ||
61 | GL.renderPrimitive (GL.TriangleStrip) $ do | ||
62 | GL.vertex (GL.Vertex2 xmin ymax) | ||
63 | GL.vertex (GL.Vertex2 xmin ymin) | ||
64 | GL.vertex (GL.Vertex2 xmax ymax) | ||
65 | GL.vertex (GL.Vertex2 xmax ymin) | ||
66 | |||
67 | process = mapM_ procEvent | ||
68 | procEvent (Resize w h) = do | ||
69 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) | ||
70 | GL.matrixMode $= GL.Projection | ||
71 | GL.loadIdentity | ||
72 | GL.ortho 0 1 0 1 (-1) 1 | ||
73 | GL.matrixMode $= GL.Modelview 0 | ||
74 | procEvent _ = return () | ||
75 | |||
76 | translate = mapMaybe translate' | ||
77 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | ||
78 | translate' (KeyDown KEY_RIGHT) = Just MoveRight | ||
79 | translate' (KeyUp KEY_LEFT) = Just StopLeft | ||
80 | translate' (KeyUp KEY_RIGHT) = Just StopRight | ||
81 | translate' _ = Nothing | ||
82 | |||
83 | exitRequested = any (==(KeyDown KEY_ESC)) | ||
84 | |||
85 | f2d :: Float -> GL.GLdouble | ||
86 | 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 @@ | |||
1 | module Pong | ||
2 | ( | ||
3 | GameEvent(..) | ||
4 | , GameObject | ||
5 | , newWorld | ||
6 | , stepWorld | ||
7 | , aabb | ||
8 | ) | ||
9 | where | ||
10 | |||
11 | import Spear.Math.AABB | ||
12 | import Spear.Math.Spatial2 | ||
13 | import Spear.Math.Vector | ||
14 | |||
15 | import Data.List (foldl') | ||
16 | import Data.Monoid | ||
17 | import GHC.Float (double2Float) | ||
18 | |||
19 | type Elapsed = Double | ||
20 | type Dt = Float | ||
21 | |||
22 | -- Step function | ||
23 | |||
24 | data Step a b = Step { step :: Elapsed -> Dt -> a -> (b, Step a b) } | ||
25 | |||
26 | sid :: Step a a | ||
27 | sid = Step $ \_ _ a -> (a, sid) | ||
28 | |||
29 | spure :: (a -> b) -> Step a b | ||
30 | spure f = Step $ \_ _ x -> (f x, spure f) | ||
31 | |||
32 | smap :: (a -> b) -> Step c a -> Step c b | ||
33 | smap f (Step s1) = Step $ \elapsed dt x -> | ||
34 | let (a, s') = s1 elapsed dt x | ||
35 | in (f a, smap f s') | ||
36 | |||
37 | (.>) :: Step a b -> Step b c -> Step a c | ||
38 | (Step s1) .> (Step s2) = Step $ \elapsed dt a -> | ||
39 | let (b, s1') = s1 elapsed dt a | ||
40 | (c, s2') = s2 elapsed dt b | ||
41 | in (c, s1' .> s2') | ||
42 | |||
43 | (.<) :: Step a b -> Step c a -> Step c b | ||
44 | (.<) = flip (.>) | ||
45 | |||
46 | sfst :: Step (a,b) a | ||
47 | sfst = spure $ \(a,_) -> a | ||
48 | |||
49 | ssnd :: Step (a,b) b | ||
50 | ssnd = spure $ \(_,b) -> b | ||
51 | |||
52 | -- Game events | ||
53 | |||
54 | data GameEvent | ||
55 | = MoveLeft | ||
56 | | MoveRight | ||
57 | | StopLeft | ||
58 | | StopRight | ||
59 | deriving Eq | ||
60 | |||
61 | -- Game objects | ||
62 | |||
63 | data GameObject = GameObject | ||
64 | { aabb :: AABB2 | ||
65 | , obj :: Obj2 | ||
66 | , gostep :: Step ([GameEvent], [GameObject], GameObject) GameObject | ||
67 | } | ||
68 | |||
69 | instance Spatial2 GameObject where | ||
70 | getObj2 = obj | ||
71 | setObj2 s o = s { obj = o } | ||
72 | |||
73 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | ||
74 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | ||
75 | |||
76 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | ||
77 | update elapsed dt evts gos go = | ||
78 | let (go', s') = step (gostep go) elapsed dt (evts, gos, go) | ||
79 | in go' { gostep = s' } | ||
80 | |||
81 | ballBox :: AABB2 | ||
82 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 | ||
83 | |||
84 | padSize = vec2 0.05 0.02 | ||
85 | |||
86 | padBox = AABB2 (-padSize) padSize | ||
87 | |||
88 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) | ||
89 | |||
90 | ballVelocity = Vector2 0.3 0.3 | ||
91 | |||
92 | newWorld = | ||
93 | [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity | ||
94 | , GameObject padBox (obj2 0.5 0.9) stepEnemy | ||
95 | , GameObject padBox (obj2 0.5 0.1) stepPlayer | ||
96 | ] | ||
97 | |||
98 | -- Generic steppers | ||
99 | |||
100 | ignore :: Step ([GameEvent], [GameObject], GameObject) GameObject | ||
101 | ignore = spure $ \(_,_,go) -> go | ||
102 | |||
103 | ignoreEvts :: Step ([GameEvent], [GameObject], GameObject) ([GameObject], GameObject) | ||
104 | ignoreEvts = spure $ \(_, world, go) -> (world, go) | ||
105 | |||
106 | ignoreGOs :: Step ([GameEvent], [GameObject], GameObject) ([GameEvent], GameObject) | ||
107 | ignoreGOs = spure $ \(evts, _, go) -> (evts, go) | ||
108 | |||
109 | -- Ball steppers | ||
110 | |||
111 | stepBall vel = ignoreEvts .> collideBall vel .> moveBall | ||
112 | |||
113 | collideBall :: Vector2 -> Step ([GameObject], GameObject) (Vector2, GameObject) | ||
114 | collideBall vel = Step $ \_ _ (gos, ball) -> | ||
115 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball | ||
116 | collideCol = x pmin < 0 || x pmax > 1 | ||
117 | collideRow = y pmin < 0 || y pmax > 1 | ||
118 | || any (collide ball) (tail gos) | ||
119 | negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v | ||
120 | negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v | ||
121 | vel' = negx . negy $ vel | ||
122 | in ((vel', ball), collideBall vel') | ||
123 | |||
124 | collide go1 go2 = | ||
125 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) | ||
126 | = aabb go1 `aabbAdd` pos go1 | ||
127 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) | ||
128 | = aabb go2 `aabbAdd` pos go2 | ||
129 | in not $ xmax1 < xmin2 || xmin1 > xmax2 | ||
130 | || ymax1 < ymin2 || ymin1 > ymax2 | ||
131 | |||
132 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) | ||
133 | |||
134 | moveBall :: Step (Vector2, GameObject) GameObject | ||
135 | moveBall = Step $ \_ dt (vel,ball) -> (move (scale dt vel) ball, moveBall) | ||
136 | |||
137 | -- Enemy stepper | ||
138 | |||
139 | stepEnemy = ignore .> movePad | ||
140 | |||
141 | movePad :: Step GameObject GameObject | ||
142 | movePad = Step $ \elapsed _ pad -> | ||
143 | let p = vec2 px 0.9 | ||
144 | px = double2Float (sin elapsed * 0.5 + 0.5) | ||
145 | * (1 - 2 * x padSize) | ||
146 | + x padSize | ||
147 | in (setPos p pad, movePad) | ||
148 | |||
149 | -- Player stepper | ||
150 | |||
151 | stepPlayer = ignoreGOs | ||
152 | .> moveGO False MoveLeft StopLeft | ||
153 | .> moveGO False MoveRight StopRight | ||
154 | .> ssnd | ||
155 | .> clamp | ||
156 | |||
157 | moveGO :: Bool -> GameEvent -> GameEvent | ||
158 | -> Step ([GameEvent], GameObject) ([GameEvent], GameObject) | ||
159 | moveGO moving start stop = Step $ \_ dt (evts, go) -> | ||
160 | let moving' = (moving || any (==start) evts) && not (any (==stop) evts) | ||
161 | dir = scale dt $ toDir moving' start | ||
162 | in ((evts, move dir go), moveGO moving' start stop) | ||
163 | |||
164 | clamp :: Step GameObject GameObject | ||
165 | clamp = spure $ \go -> | ||
166 | let p' = vec2 (clamp' x s (1 - s)) y | ||
167 | (Vector2 x y) = pos go | ||
168 | clamp' x a b = if x < a then a else if x > b then b else x | ||
169 | (Vector2 s _) = padSize | ||
170 | in setPos p' go | ||
171 | |||
172 | toDir True MoveLeft = vec2 (-1) 0 | ||
173 | toDir True MoveRight = vec2 1 0 | ||
174 | 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 @@ | |||
1 | import Distribution.Simple | ||
2 | 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 @@ | |||
1 | -- Initial pong.cabal generated by cabal init. For further documentation, | ||
2 | -- see http://haskell.org/cabal/users-guide/ | ||
3 | |||
4 | name: pong | ||
5 | version: 0.1.0.0 | ||
6 | synopsis: A pong clone | ||
7 | -- description: | ||
8 | license: BSD3 | ||
9 | license-file: LICENSE | ||
10 | author: Marc Sunet | ||
11 | -- maintainer: | ||
12 | -- copyright: | ||
13 | category: Game | ||
14 | build-type: Simple | ||
15 | cabal-version: >=1.8 | ||
16 | |||
17 | executable pong | ||
18 | -- hs-source-dirs: src | ||
19 | main-is: Main.hs | ||
20 | -- other-modules: | ||
21 | build-depends: base ==4.6.*, Spear, OpenGL | ||