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
|
{-# LANGUAGE MultiParamTypeClasses #-}
--{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Main where
import Spear.App
import Spear.Game
import Spear.Math.AABB
import qualified Spear.Math.Matrix3 as Matrix3
import qualified Spear.Math.Matrix4 as Matrix4
import Spear.Math.Spatial
import Spear.Math.Spatial2
import Spear.Math.Vector
import Spear.Physics.Collision
--import Spear.Prelude
import Spear.Render.Core.Pipeline
import Spear.Render.Core.State
import Spear.Render.Immediate
import Spear.Sound.Sound
import Spear.Sound.State
import Spear.Window
import Control.Monad (when)
ballSize = 0.01
numBalls = 1000
data Ball = Ball
{ ballPosition :: {-# UNPACK #-} !Vector2
, ballVelocity :: {-# UNPACK #-} !Vector2
}
instance Positional Ball Vector2 where
setPosition p ball = ball { ballPosition = p }
position = ballPosition
translate v ball = ball { ballPosition = v + ballPosition ball }
instance Bounded2 Ball where
boundingVolume ball = aabb2Volume $ translate (ballPosition ball) (AABB2 (-size) size)
where size = vec2 s s
s = ballSize / (2::Float)
data World = World
{ viewProjection :: Matrix4.Matrix4
, balls :: [Ball]
}
type GameState = AppState World
options = defaultAppOptions { title = "Balls" }
app = App options initGame endGame step render resize
main :: IO ()
main = runApp app
initGame :: Game AppContext World
initGame =
let
world = zipWith Ball positions velocities
positions = (+vec2 0.5 0.5) . makePosition <$> numbers
makePosition i = radius * vec2 (sin (f*i)) (cos (f*i))
velocities = makeVelocity <$> numbers
makeVelocity i = scale speed $ vec2 (sin (f*i)) (cos (f*i))
numbers = [1..numBalls]
f = 2*pi / numBalls
radius = 0.05
speed = 0.4
in
return $ World Matrix4.id world
endGame :: Game GameState ()
endGame = return ()
step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
step elapsed dt inputEvents = do
modifyGameState $ \world -> world
{ balls = moveBalls dt $ balls world
}
return (not $ exitRequested inputEvents)
exitRequested = elem (KeyDown KEY_ESC)
moveBalls :: Elapsed -> [Ball] -> [Ball]
moveBalls dt = (bounceBall dt . moveBall dt <$>)
moveBall :: Elapsed -> Ball -> Ball
moveBall dt ball = translate (scale (realToFrac dt) $ ballVelocity ball) ball
bounceBall :: Elapsed -> Ball -> Ball
bounceBall dt 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
velocity = ballVelocity ball
velocity'
= flipX
. flipY
$ velocity
collision = velocity' /= velocity
-- Apply offset when collision occurs to avoid sticky collisions.
delta = if collision then 1 else 0
dt' = realToFrac dt
in
ball
{ ballPosition = ballPosition ball + scale (delta * dt') velocity'
, ballVelocity = velocity'
}
render :: Game GameState ()
render = do
gameState <- getGameState
siblingGame $ do
immStart
immSetViewProjectionMatrix (viewProjection gameState)
-- Clear the background to a different colour than the playable area to make
-- the latter distinguishable.
setClearColour (0.2, 0.2, 0.2, 0.0)
clearBuffers [ColourBuffer]
render' $ balls gameState
immEnd
render' :: [Ball] -> Game ImmRenderState ()
render' balls = do
immLoadIdentity
renderBackground
-- Draw objects.
immSetColour (vec4 1.0 1.0 1.0 1.0)
mapM_ renderBall balls
renderBackground :: Game ImmRenderState ()
renderBackground =
let pmin = 0 :: Float
pmax = 1 :: Float
in do
immSetColour (vec4 0.0 0.25 0.41 1.0)
immDrawQuads2d [
(vec2 pmin pmin
,vec2 pmax pmin
,vec2 pmax pmax
,vec2 pmin pmax)]
renderBall :: Ball -> Game ImmRenderState ()
renderBall ball =
let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume ball
in
immDrawQuads2d [
(vec2 xmin ymin
,vec2 xmax ymin
,vec2 xmax ymax
,vec2 xmin ymax)]
resize :: WindowEvent -> Game GameState ()
resize (ResizeEvent w h) =
let r = fromIntegral w / fromIntegral h
pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
left = if r > 1 then -pad else 0
right = if r > 1 then 1 + pad else 1
bottom = if r > 1 then 0 else -pad
top = if r > 1 then 1 else 1 + pad
in do
setViewport 0 0 w h
modifyGameState $ \pong -> pong {
viewProjection = Matrix4.ortho left right bottom top (-1) 1
}
|
