diff options
Diffstat (limited to 'Demos')
-rw-r--r-- | Demos/Pong/Main.hs | 22 | ||||
-rw-r--r-- | Demos/Pong/Pong.hs | 109 |
2 files changed, 80 insertions, 51 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs index 0644f9d..a49efec 100644 --- a/Demos/Pong/Main.hs +++ b/Demos/Pong/Main.hs | |||
@@ -8,6 +8,7 @@ import Pong | |||
8 | import Spear.App | 8 | import Spear.App |
9 | import Spear.Game | 9 | import Spear.Game |
10 | import Spear.Math.AABB | 10 | import Spear.Math.AABB |
11 | import Spear.Math.Spatial | ||
11 | import Spear.Math.Spatial2 | 12 | import Spear.Math.Spatial2 |
12 | import Spear.Math.Vector | 13 | import Spear.Math.Vector |
13 | import Spear.Window | 14 | import Spear.Window |
@@ -28,10 +29,10 @@ step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool | |||
28 | step elapsed dt inputEvents = do | 29 | step elapsed dt inputEvents = do |
29 | gs <- getGameState | 30 | gs <- getGameState |
30 | gameIO . process $ inputEvents | 31 | gameIO . process $ inputEvents |
31 | let events = translate inputEvents | 32 | let events = translateEvents inputEvents |
32 | modifyGameState $ \gs -> | 33 | modifyGameState $ \gs -> |
33 | gs | 34 | gs |
34 | { world = stepWorld elapsed dt events (world gs) | 35 | { world = stepWorld (realToFrac elapsed) dt events (world gs) |
35 | } | 36 | } |
36 | getGameState >>= \gs -> gameIO . render $ world gs | 37 | getGameState >>= \gs -> gameIO . render $ world gs |
37 | return (not $ exitRequested inputEvents) | 38 | return (not $ exitRequested inputEvents) |
@@ -63,7 +64,7 @@ renderBackground = | |||
63 | renderGO :: GameObject -> IO () | 64 | renderGO :: GameObject -> IO () |
64 | renderGO go = do | 65 | renderGO go = do |
65 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go | 66 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go |
66 | (Vector2 xcenter ycenter) = pos go | 67 | (Vector2 xcenter ycenter) = position go |
67 | (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') | 68 | (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') |
68 | GL.preservingMatrix $ do | 69 | GL.preservingMatrix $ do |
69 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) | 70 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) |
@@ -76,7 +77,7 @@ renderGO go = do | |||
76 | process = mapM_ procEvent | 77 | process = mapM_ procEvent |
77 | 78 | ||
78 | procEvent (Resize w h) = | 79 | procEvent (Resize w h) = |
79 | let r = (fromIntegral w) / (fromIntegral h) | 80 | let r = fromIntegral w / fromIntegral h |
80 | pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 | 81 | pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 |
81 | left = if r > 1 then -pad else 0 | 82 | left = if r > 1 then -pad else 0 |
82 | right = if r > 1 then 1 + pad else 1 | 83 | right = if r > 1 then 1 + pad else 1 |
@@ -90,13 +91,12 @@ procEvent (Resize w h) = | |||
90 | GL.matrixMode $= GL.Modelview 0 | 91 | GL.matrixMode $= GL.Modelview 0 |
91 | procEvent _ = return () | 92 | procEvent _ = return () |
92 | 93 | ||
93 | translate = mapMaybe translate' | 94 | translateEvents = mapMaybe translateEvents' |
94 | 95 | where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft | |
95 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | 96 | translateEvents' (KeyDown KEY_RIGHT) = Just MoveRight |
96 | translate' (KeyDown KEY_RIGHT) = Just MoveRight | 97 | translateEvents' (KeyUp KEY_LEFT) = Just StopLeft |
97 | translate' (KeyUp KEY_LEFT) = Just StopLeft | 98 | translateEvents' (KeyUp KEY_RIGHT) = Just StopRight |
98 | translate' (KeyUp KEY_RIGHT) = Just StopRight | 99 | translateEvents' _ = Nothing |
99 | translate' _ = Nothing | ||
100 | 100 | ||
101 | exitRequested = elem (KeyDown KEY_ESC) | 101 | exitRequested = elem (KeyDown KEY_ESC) |
102 | 102 | ||
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs index 0e24a42..104a92e 100644 --- a/Demos/Pong/Pong.hs +++ b/Demos/Pong/Pong.hs | |||
@@ -1,3 +1,7 @@ | |||
1 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
2 | {-# LANGUAGE NoImplicitPrelude #-} | ||
3 | {-# LANGUAGE TypeSynonymInstances #-} | ||
4 | |||
1 | module Pong | 5 | module Pong |
2 | ( GameEvent (..), | 6 | ( GameEvent (..), |
3 | GameObject, | 7 | GameObject, |
@@ -7,25 +11,29 @@ module Pong | |||
7 | ) | 11 | ) |
8 | where | 12 | where |
9 | 13 | ||
10 | import Data.Monoid (mconcat) | ||
11 | import GHC.Float (double2Float) | ||
12 | import Spear.Math.AABB | 14 | import Spear.Math.AABB |
15 | import Spear.Math.Algebra | ||
16 | import Spear.Math.Spatial | ||
13 | import Spear.Math.Spatial2 | 17 | import Spear.Math.Spatial2 |
14 | import Spear.Math.Vector | 18 | import Spear.Math.Vector |
19 | import Spear.Prelude | ||
15 | import Spear.Step | 20 | import Spear.Step |
16 | 21 | ||
22 | import Data.Monoid (mconcat) | ||
23 | |||
24 | |||
17 | -- Configuration | 25 | -- Configuration |
18 | 26 | ||
19 | padSize = vec2 0.07 0.02 | 27 | padSize = vec2 0.07 0.02 |
20 | ballSize = 0.012 | 28 | ballSize = 0.012 :: Float |
21 | ballSpeed = 0.6 | 29 | ballSpeed = 0.6 :: Float |
22 | initialBallVelocity = vec2 1 1 | 30 | initialBallVelocity = vec2 1 1 |
23 | maxBounceAngle = 65 * pi/180 | 31 | maxBounceAngle = (65::Float) * (pi::Float)/(180::Float) |
24 | playerSpeed = 1.0 | 32 | playerSpeed = 1.0 :: Float |
25 | enemySpeed = 1.5 | 33 | enemySpeed = 3.0 :: Float |
26 | initialEnemyPos = vec2 0.5 0.9 | 34 | initialEnemyPos = vec2 0.5 0.9 |
27 | initialPlayerPos = vec2 0.5 0.1 | 35 | initialPlayerPos = vec2 0.5 0.1 |
28 | initialBallPos = vec2 0.5 0.5 | 36 | initialBallPos = vec2 0.5 0.5 |
29 | 37 | ||
30 | -- Game events | 38 | -- Game events |
31 | 39 | ||
@@ -40,13 +48,36 @@ data GameEvent | |||
40 | 48 | ||
41 | data GameObject = GameObject | 49 | data GameObject = GameObject |
42 | { aabb :: AABB2, | 50 | { aabb :: AABB2, |
43 | obj :: Obj2, | 51 | basis :: Transform2, |
44 | gostep :: Step [GameObject] [GameEvent] GameObject GameObject | 52 | gostep :: Step [GameObject] [GameEvent] GameObject GameObject |
45 | } | 53 | } |
46 | 54 | ||
47 | instance Spatial2 GameObject where | 55 | |
48 | getObj2 = obj | 56 | instance Has2dTransform GameObject where |
49 | setObj2 s o = s {obj = o} | 57 | set2dTransform transform object = object { basis = transform } |
58 | transform2 = basis | ||
59 | |||
60 | |||
61 | instance Positional GameObject Vector2 where | ||
62 | setPosition p = with2dTransform (setPosition p) | ||
63 | position = position . basis | ||
64 | translate v = with2dTransform (translate v) | ||
65 | |||
66 | |||
67 | instance Rotational GameObject Vector2 Angle where | ||
68 | setRotation r = with2dTransform (setRotation r) | ||
69 | rotation = rotation . basis | ||
70 | rotate angle = with2dTransform (rotate angle) | ||
71 | right = right . basis | ||
72 | up = up . basis | ||
73 | forward = forward . basis | ||
74 | setForward v = with2dTransform (setForward v) | ||
75 | |||
76 | |||
77 | instance Spatial GameObject Vector2 Angle Transform2 where | ||
78 | setTransform t obj = obj { basis = t } | ||
79 | transform = basis | ||
80 | |||
50 | 81 | ||
51 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | 82 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] |
52 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | 83 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos |
@@ -60,13 +91,12 @@ ballBox, padBox :: AABB2 | |||
60 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize | 91 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize |
61 | padBox = AABB2 (-padSize) padSize | 92 | padBox = AABB2 (-padSize) padSize |
62 | 93 | ||
63 | obj2 = obj2FromVectors unitx2 unity2 | ||
64 | |||
65 | newWorld = | 94 | newWorld = |
66 | [ GameObject ballBox (obj2 initialBallPos) $ stepBall initialBallVelocity, | 95 | [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity, |
67 | GameObject padBox (obj2 initialEnemyPos) stepEnemy, | 96 | GameObject padBox (makeAt initialEnemyPos) stepEnemy, |
68 | GameObject padBox (obj2 initialPlayerPos) stepPlayer | 97 | GameObject padBox (makeAt initialPlayerPos) stepPlayer |
69 | ] | 98 | ] |
99 | where makeAt = newTransform2 unitx2 unity2 | ||
70 | 100 | ||
71 | -- Ball steppers | 101 | -- Ball steppers |
72 | 102 | ||
@@ -76,7 +106,7 @@ stepBall vel = collideBall vel .> moveBall | |||
76 | -- ball when collision is detected. | 106 | -- ball when collision is detected. |
77 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | 107 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) |
78 | collideBall vel = step $ \_ dt gos _ ball -> | 108 | collideBall vel = step $ \_ dt gos _ ball -> |
79 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball | 109 | let (AABB2 pmin pmax) = translate (position ball) (aabb ball) |
80 | collideSide = x pmin < 0 || x pmax > 1 | 110 | collideSide = x pmin < 0 || x pmax > 1 |
81 | collideBack = y pmin < 0 || y pmax > 1 | 111 | collideBack = y pmin < 0 || y pmax > 1 |
82 | collidePaddle = any (collide ball) (tail gos) | 112 | collidePaddle = any (collide ball) (tail gos) |
@@ -84,18 +114,18 @@ collideBall vel = step $ \_ dt gos _ ball -> | |||
84 | flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v | 114 | flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v |
85 | vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel | 115 | vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel |
86 | -- A small delta to apply when collision occurs. | 116 | -- A small delta to apply when collision occurs. |
87 | delta = 1 + if collideSide || collideBack || collidePaddle then 2*dt else 0 | 117 | delta = (1::Float) + if collideSide || collideBack || collidePaddle then (2::Float)*dt else (0::Float) |
88 | in ((scale ballSpeed (scale delta vel'), ball), collideBall vel') | 118 | in ((ballSpeed * delta * vel', ball), collideBall vel') |
89 | 119 | ||
90 | paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 | 120 | paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 |
91 | paddleBounce ball v paddle = | 121 | paddleBounce ball v paddle = |
92 | if collide ball paddle | 122 | if collide ball paddle |
93 | then | 123 | then |
94 | let (AABB2 pmin pmax) = aabb paddle `aabbAdd` pos paddle | 124 | let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle) |
95 | center = (x pmin + x pmax) / 2 | 125 | center = (x pmin + x pmax) / (2::Float) |
96 | -- Normalized offset of the ball from the paddle's center, [-1, +1]. | 126 | -- Normalized offset of the ball from the paddle's center, [-1, +1]. |
97 | -- It's outside the [-1, +1] range if there is no collision. | 127 | -- It's outside the [-1, +1] range if there is no collision. |
98 | offset = (x (pos ball) - center) / ((x pmax - x pmin) / 2) | 128 | offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float)) |
99 | angle = offset * maxBounceAngle | 129 | angle = offset * maxBounceAngle |
100 | -- When it bounces off of a paddle, y vel is flipped. | 130 | -- When it bounces off of a paddle, y vel is flipped. |
101 | ysign = -(signum (y v)) | 131 | ysign = -(signum (y v)) |
@@ -105,19 +135,17 @@ paddleBounce ball v paddle = | |||
105 | collide :: GameObject -> GameObject -> Bool | 135 | collide :: GameObject -> GameObject -> Bool |
106 | collide go1 go2 = | 136 | collide go1 go2 = |
107 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = | 137 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = |
108 | aabb go1 `aabbAdd` pos go1 | 138 | translate (position go1) (aabb go1) |
109 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = | 139 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = |
110 | aabb go2 `aabbAdd` pos go2 | 140 | translate (position go2) (aabb go2) |
111 | in not $ | 141 | in not $ |
112 | xmax1 < xmin2 | 142 | xmax1 < xmin2 |
113 | || xmin1 > xmax2 | 143 | || xmin1 > xmax2 |
114 | || ymax1 < ymin2 | 144 | || ymax1 < ymin2 |
115 | || ymin1 > ymax2 | 145 | || ymin1 > ymax2 |
116 | 146 | ||
117 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax) | ||
118 | |||
119 | moveBall :: Step s e (Vector2, GameObject) GameObject | 147 | moveBall :: Step s e (Vector2, GameObject) GameObject |
120 | moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall) | 148 | moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) |
121 | 149 | ||
122 | -- Enemy stepper | 150 | -- Enemy stepper |
123 | 151 | ||
@@ -125,12 +153,13 @@ stepEnemy = movePad | |||
125 | 153 | ||
126 | movePad :: Step s e GameObject GameObject | 154 | movePad :: Step s e GameObject GameObject |
127 | movePad = step $ \elapsed _ _ _ pad -> | 155 | movePad = step $ \elapsed _ _ _ pad -> |
128 | let p = vec2 px 0.9 | 156 | let enemyY = 0.9 |
157 | p = vec2 px enemyY | ||
129 | px = | 158 | px = |
130 | double2Float (sin (elapsed * enemySpeed) * 0.5 + 0.5) | 159 | (sin (enemySpeed * elapsed) * (0.5::Float) + (0.5::Float)) |
131 | * (1 - 2 * x padSize) | 160 | * ((1::Float) - (2::Float) * x padSize) |
132 | + x padSize | 161 | + x padSize |
133 | in (setPos p pad, movePad) | 162 | in (setPosition p pad, movePad) |
134 | 163 | ||
135 | -- Player stepper | 164 | -- Player stepper |
136 | 165 | ||
@@ -138,20 +167,20 @@ stepPlayer = sfold moveGO .> clamp | |||
138 | 167 | ||
139 | moveGO = | 168 | moveGO = |
140 | mconcat | 169 | mconcat |
141 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0), | 170 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0), |
142 | switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) | 171 | switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) |
143 | ] | 172 | ] |
144 | 173 | ||
145 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 174 | moveGO' :: Vector2 -> Step s e GameObject GameObject |
146 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) | 175 | moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) |
147 | 176 | ||
148 | clamp :: Step s e GameObject GameObject | 177 | clamp :: Step s e GameObject GameObject |
149 | clamp = spure $ \go -> | 178 | clamp = spure $ \go -> |
150 | let p' = vec2 (clamp' x s (1 - s)) y | 179 | let p' = vec2 (clamp' x s (1 - s)) y |
151 | (Vector2 x y) = pos go | 180 | (Vector2 x y) = position go |
152 | clamp' x a b | 181 | clamp' x a b |
153 | | x < a = a | 182 | | x < a = a |
154 | | x > b = b | 183 | | x > b = b |
155 | | otherwise = x | 184 | | otherwise = x |
156 | (Vector2 s _) = padSize | 185 | (Vector2 s _) = padSize |
157 | in setPos p' go | 186 | in setPosition p' go |