aboutsummaryrefslogtreecommitdiff
path: root/demos/pong
diff options
context:
space:
mode:
Diffstat (limited to 'demos/pong')
-rw-r--r--demos/pong/LICENSE30
-rw-r--r--demos/pong/Main.hs86
-rw-r--r--demos/pong/Pong.hs174
-rw-r--r--demos/pong/Setup.hs2
-rw-r--r--demos/pong/pong.cabal21
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 @@
1Copyright (c) 2013, Marc Sunet
2
3All rights reserved.
4
5Redistribution and use in source and binary forms, with or without
6modification, 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
20THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30OF 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 @@
1module Main where
2
3import Pong
4
5import Spear.Math.AABB
6import Spear.Math.Spatial2
7import Spear.Math.Vector
8import Spear.Game
9import Spear.Window
10
11import Data.Maybe (mapMaybe)
12import qualified Graphics.Rendering.OpenGL.GL as GL
13import Graphics.Rendering.OpenGL.GL (($=))
14
15data GameState = GameState
16 { wnd :: Window
17 , elapsed :: Double
18 , world :: [GameObject]
19 }
20
21main = do
22 result <- run
23 case result of
24 Left err -> putStrLn err
25 Right _ -> return ()
26
27run = withWindow (640,480) [] Window (2,0) (Just "Pong") initGame
28 $ loop (Just 30) step
29
30initGame 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
37step :: Dt -> Game GameState Bool
38step 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
49render world = do
50 GL.clear [GL.ColorBuffer]
51 mapM_ renderGO world
52 swapBuffers
53
54renderGO :: GameObject -> IO ()
55renderGO 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
67process = mapM_ procEvent
68procEvent (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
74procEvent _ = return ()
75
76translate = mapMaybe translate'
77translate' (KeyDown KEY_LEFT) = Just MoveLeft
78translate' (KeyDown KEY_RIGHT) = Just MoveRight
79translate' (KeyUp KEY_LEFT) = Just StopLeft
80translate' (KeyUp KEY_RIGHT) = Just StopRight
81translate' _ = Nothing
82
83exitRequested = any (==(KeyDown KEY_ESC))
84
85f2d :: Float -> GL.GLdouble
86f2d = 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 @@
1module Pong
2(
3 GameEvent(..)
4, GameObject
5, newWorld
6, stepWorld
7, aabb
8)
9where
10
11import Spear.Math.AABB
12import Spear.Math.Spatial2
13import Spear.Math.Vector
14
15import Data.List (foldl')
16import Data.Monoid
17import GHC.Float (double2Float)
18
19type Elapsed = Double
20type Dt = Float
21
22-- Step function
23
24data Step a b = Step { step :: Elapsed -> Dt -> a -> (b, Step a b) }
25
26sid :: Step a a
27sid = Step $ \_ _ a -> (a, sid)
28
29spure :: (a -> b) -> Step a b
30spure f = Step $ \_ _ x -> (f x, spure f)
31
32smap :: (a -> b) -> Step c a -> Step c b
33smap 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
46sfst :: Step (a,b) a
47sfst = spure $ \(a,_) -> a
48
49ssnd :: Step (a,b) b
50ssnd = spure $ \(_,b) -> b
51
52-- Game events
53
54data GameEvent
55 = MoveLeft
56 | MoveRight
57 | StopLeft
58 | StopRight
59 deriving Eq
60
61-- Game objects
62
63data GameObject = GameObject
64 { aabb :: AABB2
65 , obj :: Obj2
66 , gostep :: Step ([GameEvent], [GameObject], GameObject) GameObject
67 }
68
69instance Spatial2 GameObject where
70 getObj2 = obj
71 setObj2 s o = s { obj = o }
72
73stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
74stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
75
76update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
77update elapsed dt evts gos go =
78 let (go', s') = step (gostep go) elapsed dt (evts, gos, go)
79 in go' { gostep = s' }
80
81ballBox :: AABB2
82ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01
83
84padSize = vec2 0.05 0.02
85
86padBox = AABB2 (-padSize) padSize
87
88obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y)
89
90ballVelocity = Vector2 0.3 0.3
91
92newWorld =
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
100ignore :: Step ([GameEvent], [GameObject], GameObject) GameObject
101ignore = spure $ \(_,_,go) -> go
102
103ignoreEvts :: Step ([GameEvent], [GameObject], GameObject) ([GameObject], GameObject)
104ignoreEvts = spure $ \(_, world, go) -> (world, go)
105
106ignoreGOs :: Step ([GameEvent], [GameObject], GameObject) ([GameEvent], GameObject)
107ignoreGOs = spure $ \(evts, _, go) -> (evts, go)
108
109-- Ball steppers
110
111stepBall vel = ignoreEvts .> collideBall vel .> moveBall
112
113collideBall :: Vector2 -> Step ([GameObject], GameObject) (Vector2, GameObject)
114collideBall 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
124collide 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
132aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax)
133
134moveBall :: Step (Vector2, GameObject) GameObject
135moveBall = Step $ \_ dt (vel,ball) -> (move (scale dt vel) ball, moveBall)
136
137-- Enemy stepper
138
139stepEnemy = ignore .> movePad
140
141movePad :: Step GameObject GameObject
142movePad = 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
151stepPlayer = ignoreGOs
152 .> moveGO False MoveLeft StopLeft
153 .> moveGO False MoveRight StopRight
154 .> ssnd
155 .> clamp
156
157moveGO :: Bool -> GameEvent -> GameEvent
158 -> Step ([GameEvent], GameObject) ([GameEvent], GameObject)
159moveGO 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
164clamp :: Step GameObject GameObject
165clamp = 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
172toDir True MoveLeft = vec2 (-1) 0
173toDir True MoveRight = vec2 1 0
174toDir _ _ = 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 @@
1import Distribution.Simple
2main = 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
4name: pong
5version: 0.1.0.0
6synopsis: A pong clone
7-- description:
8license: BSD3
9license-file: LICENSE
10author: Marc Sunet
11-- maintainer:
12-- copyright:
13category: Game
14build-type: Simple
15cabal-version: >=1.8
16
17executable pong
18 -- hs-source-dirs: src
19 main-is: Main.hs
20 -- other-modules:
21 build-depends: base ==4.6.*, Spear, OpenGL