1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Pong
( GameEvent (..),
GameObject,
newWorld,
stepWorld,
aabb,
)
where
import Spear.Math.AABB
import Spear.Math.Algebra
import Spear.Math.Spatial
import Spear.Math.Spatial2
import Spear.Math.Vector
import Spear.Physics.Collision
import Spear.Prelude
import Spear.Step
import Data.Monoid (mconcat)
-- Configuration
padSize = vec2 0.07 0.015
ballSize = 0.012 :: Float
ballSpeed = 0.7 :: Float
initialBallVelocity = vec2 1 1
maxBounceAngle = (65::Float) * (pi::Float)/(180::Float)
playerSpeed = 1.0 :: Float
enemySpeed = 7.0 :: Float
enemyMomentum = 1.0 :: Float
initialEnemyPos = vec2 0.5 0.9
initialPlayerPos = vec2 0.5 0.1
initialBallPos = vec2 0.5 0.5
-- Game events
data GameEvent
= MoveLeft
| MoveRight
| Collision GameObjectId GameObjectId
deriving (Eq, Show)
-- Game objects
data GameObjectId
= Ball
| Enemy
| Player
deriving (Eq, Show)
data GameObject = GameObject
{ gameObjectId :: !GameObjectId
, aabb :: {-# UNPACK #-} !AABB2
, basis :: {-# UNPACK #-} !Transform2
, gostep :: Step [GameObject] [GameEvent] GameObject GameObject
}
instance Has2dTransform GameObject where
set2dTransform transform object = object { basis = transform }
transform2 = basis
instance Positional GameObject Vector2 where
setPosition p = with2dTransform (setPosition p)
position = position . basis
translate v = with2dTransform (translate v)
instance Rotational GameObject Vector2 Angle where
setRotation r = with2dTransform (setRotation r)
rotation = rotation . basis
rotate angle = with2dTransform (rotate angle)
right = right . basis
up = up . basis
forward = forward . basis
setForward v = with2dTransform (setForward v)
instance Spatial GameObject Vector2 Angle Transform2 where
setTransform t obj = obj { basis = t }
transform = basis
instance Bounded2 GameObject where
boundingVolume obj = aabb2Volume $ translate (position obj) (aabb obj)
ballBox, padBox :: AABB2
ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
padBox = AABB2 (-padSize) padSize
newWorld =
[ GameObject Ball ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
GameObject Enemy padBox (makeAt initialEnemyPos) stepEnemy,
GameObject Player padBox (makeAt initialPlayerPos) stepPlayer
]
where makeAt = newTransform2 unitx2 unity2
-- Step the game world:
-- 1. Simulate physics.
-- 2. Collide objects and clip -> produce collision events.
-- 3. Update game objects <- input collision events.
stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
stepWorld elapsed dt events gos@[ball, enemy, player] =
let
collisions = collide [ball] [enemy, player]
collisionEvents = (\(x,y) -> Collision (gameObjectId x) (gameObjectId y)) <$> collisions
events' = events ++ collisionEvents
gos' = map (update elapsed dt events' gos) gos
in
gos'
update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
update elapsed dt events gos go =
let (go', s') = runStep (gostep go) elapsed dt gos events go
in go' { gostep = s' }
-- Ball steppers
stepBall vel = bounceBall vel .> moveBall
bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
bounceBall vel = step $ \_ dt gos events ball ->
let (AABB2 pmin pmax) = translate (position ball) (aabb ball)
sideCollision = x pmin < 0 || x pmax > 1
backCollision = y pmin < 0 || y pmax > 1
flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v
flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v
collideWithPaddles vel = foldl (paddleBounce ball events) vel (tail gos)
vel' = normalise
. collideWithPaddles
. flipX
. flipY
$ vel
collision = vel' /= vel
-- Apply offset when collision occurs to avoid sticky collisions.
delta = (1::Float) + if collision then (3::Float)*dt else (0::Float)
in ((ballSpeed * delta * vel', ball), bounceBall vel')
paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2
paddleBounce ball events vel paddle =
let collision = Collision Ball (gameObjectId paddle) `elem` events
in if collision
then
let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle)
center = (x pmin + x pmax) / (2::Float)
-- Normalized offset of the ball from the paddle's center, [-1, +1].
-- It's outside the [-1, +1] range if there is no collision.
offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float))
angle = offset * maxBounceAngle
-- When it bounces off of a paddle, y vel is flipped.
ysign = -(signum (y vel))
in vec2 (sin angle) (ysign * cos angle)
else vel
moveBall :: Step s e (Vector2, GameObject) GameObject
moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
-- Enemy stepper
stepEnemy = movePad 0 .> clamp
movePad :: Float -> Step [GameObject] e GameObject GameObject
movePad previousMomentumVector = step $ \_ dt gos _ pad ->
let ball = head gos
heading = (x . position $ ball) - (x . position $ pad)
chaseVector = enemySpeed * heading
momentumVector = previousMomentumVector + enemyMomentum * heading * dt
vx = chaseVector * dt + momentumVector
in (translate (vec2 vx 0) pad, movePad momentumVector)
sign :: Float -> Float
sign x = if x >= 0 then 1 else -1
-- Player stepper
stepPlayer = sfold movePlayer .> clamp
movePlayer = mconcat
[ swhen MoveLeft $ movePlayer' (vec2 (-playerSpeed) 0)
, swhen MoveRight $ movePlayer' (vec2 playerSpeed 0)
]
movePlayer' :: Vector2 -> Step s e GameObject GameObject
movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir)
clamp :: Step s e GameObject GameObject
clamp = spure $ \go ->
let p' = vec2 (clamp' x s (1 - s)) y
(Vector2 x y) = position go
clamp' x a b
| x < a = a
| x > b = b
| otherwise = x
(Vector2 s _) = padSize
in setPosition p' go
|
