aboutsummaryrefslogtreecommitdiff
path: root/demos/pong/Pong.hs
diff options
context:
space:
mode:
Diffstat (limited to 'demos/pong/Pong.hs')
-rw-r--r--demos/pong/Pong.hs125
1 files changed, 64 insertions, 61 deletions
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs
index 1761823..232c69a 100644
--- a/demos/pong/Pong.hs
+++ b/demos/pong/Pong.hs
@@ -1,66 +1,64 @@
1module Pong 1module Pong
2( 2 ( GameEvent (..),
3 GameEvent(..) 3 GameObject,
4, GameObject 4 newWorld,
5, newWorld 5 stepWorld,
6, stepWorld 6 aabb,
7, aabb 7 )
8)
9where 8where
10 9
10import Data.Monoid (mconcat)
11import GHC.Float (double2Float)
11import Spear.Math.AABB 12import Spear.Math.AABB
12import Spear.Math.Spatial2 13import Spear.Math.Spatial2
13import Spear.Math.Vector 14import Spear.Math.Vector
14import Spear.Step 15import Spear.Step
15 16
16import Data.Monoid (mconcat)
17import GHC.Float (double2Float)
18
19-- Game events 17-- Game events
20 18
21data GameEvent 19data GameEvent
22 = MoveLeft 20 = MoveLeft
23 | MoveRight 21 | MoveRight
24 | StopLeft 22 | StopLeft
25 | StopRight 23 | StopRight
26 deriving (Eq, Ord) 24 deriving (Eq, Ord)
27 25
28-- Game objects 26-- Game objects
29 27
30data GameObject = GameObject 28data GameObject = GameObject
31 { aabb :: AABB2 29 { aabb :: AABB2,
32 , obj :: Obj2 30 obj :: Obj2,
33 , gostep :: Step [GameObject] [GameEvent] GameObject GameObject 31 gostep :: Step [GameObject] [GameEvent] GameObject GameObject
34 } 32 }
35 33
36instance Spatial2 GameObject where 34instance Spatial2 GameObject where
37 getObj2 = obj 35 getObj2 = obj
38 setObj2 s o = s { obj = o } 36 setObj2 s o = s {obj = o}
39 37
40stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] 38stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
41stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos 39stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
42 40
43update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject 41update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
44update elapsed dt evts gos go = 42update elapsed dt evts gos go =
45 let (go', s') = runStep (gostep go) elapsed dt gos evts go 43 let (go', s') = runStep (gostep go) elapsed dt gos evts go
46 in go' { gostep = s' } 44 in go' {gostep = s'}
47 45
48ballBox :: AABB2 46ballBox :: AABB2
49ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 47ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01
50 48
51padSize = vec2 0.05 0.02 49padSize = vec2 0.05 0.02
52 50
53padBox = AABB2 (-padSize) padSize 51padBox = AABB2 (- padSize) padSize
54 52
55obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) 53obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y)
56 54
57ballVelocity = Vector2 0.3 0.3 55ballVelocity = Vector2 0.3 0.3
58 56
59newWorld = 57newWorld =
60 [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity 58 [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity,
61 , GameObject padBox (obj2 0.5 0.9) stepEnemy 59 GameObject padBox (obj2 0.5 0.9) stepEnemy,
62 , GameObject padBox (obj2 0.5 0.1) stepPlayer 60 GameObject padBox (obj2 0.5 0.1) stepPlayer
63 ] 61 ]
64 62
65-- Ball steppers 63-- Ball steppers
66 64
@@ -68,27 +66,30 @@ stepBall vel = collideBall vel .> moveBall
68 66
69collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) 67collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
70collideBall vel = step $ \_ _ gos _ ball -> 68collideBall vel = step $ \_ _ gos _ ball ->
71 let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball 69 let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball
72 collideCol = x pmin < 0 || x pmax > 1 70 collideCol = x pmin < 0 || x pmax > 1
73 collideRow = y pmin < 0 || y pmax > 1 71 collideRow =
74 || any (collide ball) (tail gos) 72 y pmin < 0 || y pmax > 1
75 negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v 73 || any (collide ball) (tail gos)
76 negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v 74 negx v@(Vector2 x y) = if collideCol then vec2 (- x) y else v
77 vel' = negx . negy $ vel 75 negy v@(Vector2 x y) = if collideRow then vec2 x (- y) else v
78 in ((vel', ball), collideBall vel') 76 vel' = negx . negy $ vel
77 in ((vel', ball), collideBall vel')
79 78
80collide go1 go2 = 79collide go1 go2 =
81 let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) 80 let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
82 = aabb go1 `aabbAdd` pos go1 81 aabb go1 `aabbAdd` pos go1
83 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) 82 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
84 = aabb go2 `aabbAdd` pos go2 83 aabb go2 `aabbAdd` pos go2
85 in not $ xmax1 < xmin2 || xmin1 > xmax2 84 in not $
86 || ymax1 < ymin2 || ymin1 > ymax2 85 xmax1 < xmin2 || xmin1 > xmax2
86 || ymax1 < ymin2
87 || ymin1 > ymax2
87 88
88aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) 89aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax)
89 90
90moveBall :: Step s e (Vector2, GameObject) GameObject 91moveBall :: Step s e (Vector2, GameObject) GameObject
91moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall) 92moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall)
92 93
93-- Enemy stepper 94-- Enemy stepper
94 95
@@ -96,32 +97,34 @@ stepEnemy = movePad
96 97
97movePad :: Step s e GameObject GameObject 98movePad :: Step s e GameObject GameObject
98movePad = step $ \elapsed _ _ _ pad -> 99movePad = step $ \elapsed _ _ _ pad ->
99 let p = vec2 px 0.9 100 let p = vec2 px 0.9
100 px = double2Float (sin elapsed * 0.5 + 0.5) 101 px =
101 * (1 - 2 * x padSize) 102 double2Float (sin elapsed * 0.5 + 0.5)
102 + x padSize 103 * (1 - 2 * x padSize)
103 in (setPos p pad, movePad) 104 + x padSize
105 in (setPos p pad, movePad)
104 106
105-- Player stepper 107-- Player stepper
106 108
107stepPlayer = sfold moveGO .> clamp 109stepPlayer = sfold moveGO .> clamp
108 110
109moveGO = mconcat 111moveGO =
110 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0) 112 mconcat
111 , switch StopRight sid MoveRight (moveGO' $ vec2 1 0) 113 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0),
112 ] 114 switch StopRight sid MoveRight (moveGO' $ vec2 1 0)
115 ]
113 116
114moveGO' :: Vector2 -> Step s e GameObject GameObject 117moveGO' :: Vector2 -> Step s e GameObject GameObject
115moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) 118moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir)
116 119
117clamp :: Step s e GameObject GameObject 120clamp :: Step s e GameObject GameObject
118clamp = spure $ \go -> 121clamp = spure $ \go ->
119 let p' = vec2 (clamp' x s (1 - s)) y 122 let p' = vec2 (clamp' x s (1 - s)) y
120 (Vector2 x y) = pos go 123 (Vector2 x y) = pos go
121 clamp' x a b = if x < a then a else if x > b then b else x 124 clamp' x a b = if x < a then a else if x > b then b else x
122 (Vector2 s _) = padSize 125 (Vector2 s _) = padSize
123 in setPos p' go 126 in setPos p' go
124 127
125toDir True MoveLeft = vec2 (-1) 0 128toDir True MoveLeft = vec2 (-1) 0
126toDir True MoveRight = vec2 1 0 129toDir True MoveRight = vec2 1 0
127toDir _ _ = vec2 0 0 \ No newline at end of file 130toDir _ _ = vec2 0 0