aboutsummaryrefslogtreecommitdiff
path: root/demos/pong/Pong.hs
diff options
context:
space:
mode:
authorJeanne-Kamikaze <jeannekamikaze@gmail.com>2013-08-10 17:24:17 +0200
committerJeanne-Kamikaze <jeannekamikaze@gmail.com>2013-08-10 17:24:17 +0200
commite15a9cc51e31b5deb973d8583298aa130dd82b17 (patch)
treec7eca5402b85ccb9cb7de3928991f1b3a9d4e253 /demos/pong/Pong.hs
parent04313774991dc503844ddd2c47529aca8280aa6c (diff)
Added pong
Diffstat (limited to 'demos/pong/Pong.hs')
-rw-r--r--demos/pong/Pong.hs174
1 files changed, 174 insertions, 0 deletions
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