diff options
Diffstat (limited to 'demos/pong/Pong.hs')
-rw-r--r-- | demos/pong/Pong.hs | 125 |
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 @@ | |||
1 | module Pong | 1 | module Pong |
2 | ( | 2 | ( GameEvent (..), |
3 | GameEvent(..) | 3 | GameObject, |
4 | , GameObject | 4 | newWorld, |
5 | , newWorld | 5 | stepWorld, |
6 | , stepWorld | 6 | aabb, |
7 | , aabb | 7 | ) |
8 | ) | ||
9 | where | 8 | where |
10 | 9 | ||
10 | import Data.Monoid (mconcat) | ||
11 | import GHC.Float (double2Float) | ||
11 | import Spear.Math.AABB | 12 | import Spear.Math.AABB |
12 | import Spear.Math.Spatial2 | 13 | import Spear.Math.Spatial2 |
13 | import Spear.Math.Vector | 14 | import Spear.Math.Vector |
14 | import Spear.Step | 15 | import Spear.Step |
15 | 16 | ||
16 | import Data.Monoid (mconcat) | ||
17 | import GHC.Float (double2Float) | ||
18 | |||
19 | -- Game events | 17 | -- Game events |
20 | 18 | ||
21 | data GameEvent | 19 | data 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 | ||
30 | data GameObject = GameObject | 28 | data 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 | ||
36 | instance Spatial2 GameObject where | 34 | instance 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 | ||
40 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | 38 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] |
41 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | 39 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos |
42 | 40 | ||
43 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | 41 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject |
44 | update elapsed dt evts gos go = | 42 | update 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 | ||
48 | ballBox :: AABB2 | 46 | ballBox :: AABB2 |
49 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 | 47 | ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01 |
50 | 48 | ||
51 | padSize = vec2 0.05 0.02 | 49 | padSize = vec2 0.05 0.02 |
52 | 50 | ||
53 | padBox = AABB2 (-padSize) padSize | 51 | padBox = AABB2 (- padSize) padSize |
54 | 52 | ||
55 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) | 53 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) |
56 | 54 | ||
57 | ballVelocity = Vector2 0.3 0.3 | 55 | ballVelocity = Vector2 0.3 0.3 |
58 | 56 | ||
59 | newWorld = | 57 | newWorld = |
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 | ||
69 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | 67 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) |
70 | collideBall vel = step $ \_ _ gos _ ball -> | 68 | collideBall 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 | ||
80 | collide go1 go2 = | 79 | collide 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 | ||
88 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) | 89 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax) |
89 | 90 | ||
90 | moveBall :: Step s e (Vector2, GameObject) GameObject | 91 | moveBall :: Step s e (Vector2, GameObject) GameObject |
91 | moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall) | 92 | moveBall = 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 | ||
97 | movePad :: Step s e GameObject GameObject | 98 | movePad :: Step s e GameObject GameObject |
98 | movePad = step $ \elapsed _ _ _ pad -> | 99 | movePad = 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 | ||
107 | stepPlayer = sfold moveGO .> clamp | 109 | stepPlayer = sfold moveGO .> clamp |
108 | 110 | ||
109 | moveGO = mconcat | 111 | moveGO = |
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 | ||
114 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 117 | moveGO' :: Vector2 -> Step s e GameObject GameObject |
115 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) | 118 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) |
116 | 119 | ||
117 | clamp :: Step s e GameObject GameObject | 120 | clamp :: Step s e GameObject GameObject |
118 | clamp = spure $ \go -> | 121 | clamp = 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 | ||
125 | toDir True MoveLeft = vec2 (-1) 0 | 128 | toDir True MoveLeft = vec2 (-1) 0 |
126 | toDir True MoveRight = vec2 1 0 | 129 | toDir True MoveRight = vec2 1 0 |
127 | toDir _ _ = vec2 0 0 \ No newline at end of file | 130 | toDir _ _ = vec2 0 0 |