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
|
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Pong
( GameEvent (..)
, GameObject
, newWorld
, stepWorld
)
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.070 0.015
ballSize = vec2 0.012 0.012
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
, gameObjectSize :: {-# UNPACK #-} !Vector2
, 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) (AABB2 (-size) size)
where size = gameObjectSize obj
newWorld =
[ GameObject Ball ballSize (makeAt initialBallPos) $ stepBall initialBallVelocity,
GameObject Enemy padSize (makeAt initialEnemyPos) stepEnemy,
GameObject Player padSize (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
in
map (update elapsed dt events' gos) 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 -- .> clamp
bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
bounceBall vel = step $ \_ dt gos events ball ->
let (AABB2Volume (AABB2 pmin pmax)) = boundingVolume 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 (AABB2Volume (AABB2 pmin pmax)) = boundingVolume 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 .> spure 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)
-- Player stepper
stepPlayer = sfold movePlayer .> spure 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 :: GameObject -> GameObject
clamp go =
let p' = vec2 (clamp' x sx (1 - sx)) y
(Vector2 x y) = position go
clamp' x a b
| x < a = a
| x > b = b
| otherwise = x
(Vector2 sx _) = gameObjectSize go
in setPosition p' go
|
