-
Notifications
You must be signed in to change notification settings - Fork 2
/
Playground.hs
606 lines (514 loc) · 18.7 KB
/
Playground.hs
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
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
module Main (main) where
import qualified Data.Map as M
import Control.Monad
import Control.Monad.IO.Class
import Data.IORef
import Data.List (unzip4)
import Data.StateVar as SV
import System.Exit
import Graphics.UI.GLFW
import Graphics.Rendering.OpenGL.GL.CoordTrans
import Graphics.Rendering.OpenGL as GL
import qualified Physics.Hipmunk as H
type Time = Double
------------------------------------------------------------
-- Some constants and utils
------------------------------------------------------------
-- | Desired (and maximum) frames per second.
desiredFPS :: Int
desiredFPS = 60
-- | How much seconds a frame lasts.
framePeriod :: Time
framePeriod = 1 / toEnum desiredFPS
-- | How many steps should be done per frame.
frameSteps :: Double
frameSteps = 6
-- | Maximum number of steps per frame (e.g. if lots of frames get
-- dropped because the window was minimized)
maxSteps :: Int
maxSteps = 20
-- | How much time should pass in each step.
frameDelta :: H.Time
frameDelta = 3.33e-3
-- | How much slower should the slow mode be.
slowdown :: Double
slowdown = 10
-- | 0 :: GLfloat
zero :: GLfloat
zero = 0
-- | Asserts that an @IO@ action returns @True@, otherwise
-- fails with the given message.
assertTrue :: IO Bool -> String -> IO ()
assertTrue act msg = do {b <- act; when (not b) (fail msg)}
-- | Constructs a Vector.
(+:) :: H.CpFloat -> H.CpFloat -> H.Vector
(+:) = H.Vector
infix 4 +:
------------------------------------------------------------
-- State
------------------------------------------------------------
-- | Our current program state that will be passed around.
data State = State {
stSpace :: H.Space,
stCarState :: CarState,
stControls :: CarControls,
stShapes :: M.Map H.Shape (IO () {- Drawing -}
,IO () {- Removal -}),
stCollisionsVar :: IORef [H.Position]
}
data CarState = Stopped | GoingLeft | GoingRight deriving (Eq, Ord, Enum)
type Object = (H.Shape, (IO (), IO ()))
type CarControls = (CarState -> IO ())
-- | Our initial state.
initialState :: IO State
initialState = do
-- The (empty) space
space <- H.newSpace
H.gravity space SV.$= 0 +: -230
-- Default objects
seesaw <- buildSeesaw space
ground <- buildGround space
(car,c) <- buildCar space
-- Add a callback to Hipmunk to draw collisions
collisionsVar <- newIORef []
let handler = do ps <- H.points
liftIO $ modifyIORef collisionsVar (ps ++)
H.setDefaultCollisionHandler space $
H.Handler {H.beginHandler = Nothing
,H.preSolveHandler = Nothing
,H.postSolveHandler = Just handler
,H.separateHandler = Nothing}
-- Our state
return $ State {stSpace = space
,stCarState = Stopped
,stControls = c
,stShapes = M.fromList [seesaw, ground, car]
,stCollisionsVar = collisionsVar}
-- | Builds the ground
buildGround :: H.Space -> IO Object
buildGround space = do
static <- H.newBody H.infinity H.infinity
H.position static SV.$= -330 +: 0
let seg1type = H.LineSegment (50 +: -230) (610 +: -230) 1
seg1 <- H.newShape static seg1type 0
H.friction seg1 SV.$= 1.0
H.elasticity seg1 SV.$= 0.6
H.spaceAdd space (H.Static seg1)
return (seg1, (drawMyShape seg1 seg1type, return ()))
-- | Builds the seesaw.
buildSeesaw :: H.Space -> IO Object
buildSeesaw space = do
---- Support
let supportV = [-15 +: -20, -5 +: 20, 5 +: 20, 15 +: -20]
supportT = H.Polygon supportV
supportM = 500
supportI = H.momentForPoly supportM supportV 0
supportB <- H.newBody supportM supportI
H.position supportB SV.$= 0 +: 20-230
supportS <- H.newShape supportB supportT 0
H.friction supportS SV.$= 2.0
H.elasticity supportS SV.$= 0.1
H.spaceAdd space supportB
H.spaceAdd space supportS
----- Board
let boardV = [-100 +: 1, 100 +: 1, 100 +: -1, -100 +: -1]
boardT = H.Polygon boardV
boardM = 10
boardI = H.momentForPoly boardM boardV 0
boardB <- H.newBody boardM boardI
H.position boardB SV.$= 0 +: 40-230
boardS <- H.newShape boardB boardT 0
let setBoardProps shape = do
H.friction shape SV.$= 2.0
H.elasticity shape SV.$= 0.1
setBoardProps boardS
H.spaceAdd space boardB
H.spaceAdd space boardS
boardS2 <- forM (zip boardV $ tail $ cycle boardV) $ \(v1,v2) -> do
seg <- H.newShape boardB (H.LineSegment v1 v2 0.1) 0
setBoardProps seg
H.spaceAdd space seg
return seg
----- Constraint
seesawJoint <- H.newConstraint supportB boardB (H.Pin (0 +: 20) 0)
H.spaceAdd space seesawJoint
----- Avoiding self-collisions
forM_ (supportS : boardS : boardS2) $ \s -> do
H.group s SV.$= 1
----- Removing and drawing
let drawSeeSaw = do
drawMyShape supportS supportT
drawMyShape boardS boardT
let removeSeeSaw = do
H.spaceRemove space supportB
H.spaceRemove space supportS
H.spaceRemove space boardB
H.spaceRemove space boardS
forM_ boardS2 (H.spaceRemove space)
H.spaceRemove space seesawJoint
return (supportS, (drawSeeSaw, removeSeeSaw))
-- | Build a small car.
buildCar :: H.Space -> IO (Object, CarControls)
buildCar space = do
---- Bodywork
let bodyworkV = [-25 +: -9, -17 +: 10, 17 +: 10, 25 +: -9]
bodyworkT = H.Polygon bodyworkV
bodyworkP = (-150 +: -90)
bodyworkM = 40
bodyworkI = H.momentForPoly bodyworkM bodyworkV 0
bodyworkB <- H.newBody bodyworkM bodyworkI
H.position bodyworkB SV.$= bodyworkP
bodyworkS <- H.newShape bodyworkB bodyworkT 0
H.friction bodyworkS SV.$= 1.5
H.elasticity bodyworkS SV.$= 0.1
H.spaceAdd space bodyworkB
H.spaceAdd space bodyworkS
---- Wheels
let wheelR = 12 -- radius
wheelM = 200 -- mass
wheelT = H.Circle wheelR
wheelI = H.momentForCircle wheelM (0, wheelR) 0
wheelJ1 x = H.DampedSpring (x +: 0) (0 +: 0) 23 0 10 -- spring
wheelJ2 x = H.Groove (x +: -23.5, x +: -27) (0 +: 0) -- groove
(wheelBs, wheelSs, wheelCs, wheelMs) <-
fmap unzip4 $ forM [-25, 25] $ \x -> do
-- Basic
wheelB <- H.newBody wheelM wheelI
H.position wheelB SV.$= (x +: -24) + bodyworkP
wheelS <- H.newShape wheelB wheelT 0
H.friction wheelS SV.$= 2.0
H.elasticity wheelS SV.$= 0.25
-- Constraints
wheelC1 <- H.newConstraint bodyworkB wheelB (wheelJ1 x)
wheelC2 <- H.newConstraint bodyworkB wheelB (wheelJ2 x)
H.spaceAdd space wheelB
H.spaceAdd space wheelS
H.spaceAdd space wheelC1
H.spaceAdd space wheelC2
-- Motor
motor <- H.newConstraint bodyworkB wheelB (H.SimpleMotor 0)
H.spaceAdd space motor
let motorControls = map turn [0, -1, 1]
turn = H.redefineC motor . H.SimpleMotor . (*4)
-- Return
let constrs = [H.forgetC wheelC1, H.forgetC wheelC2, H.forgetC motor]
return (wheelB, wheelS, constrs, motorControls)
---- Removing and drawing
let drawCar = do
drawMyShape bodyworkS bodyworkT
mapM_ (flip drawMyShape wheelT) wheelSs
let removeCar = do
mapM_ (H.spaceRemove space) (bodyworkB : wheelBs)
mapM_ (H.spaceRemove space) (bodyworkS : wheelSs)
mapM_ (H.spaceRemove space) (concat wheelCs)
---- Motor controls
let control w = mapM_ (!!n) wheelMs where n = fromEnum w
return ((bodyworkS, (drawCar, removeCar)), control)
-- | Destroy a state.
destroyState :: State -> IO ()
destroyState (State {stSpace = space}) = do
H.freeSpace space
------------------------------------------------------------
-- Main function and main loop
------------------------------------------------------------
-- | Entry point.
main :: IO ()
main = do
-- Initialize Chipmunk, GLFW and our state
H.initChipmunk
assertTrue initialize "Failed to init GLFW"
stateVar <- initialState >>= newIORef
-- Create a window
assertTrue (openWindow (GL.Size 1200 900) [] Window) "Failed to open a window"
windowTitle GL.$= "Hipmunk Playground"
-- Define some GL parameters for the whole program
clearColor GL.$= Color4 1 1 1 1
pointSmooth GL.$= Enabled
pointSize GL.$= 3
lineSmooth GL.$= Enabled
lineWidth GL.$= 2.5
blend GL.$= Enabled
blendFunc GL.$= (SrcAlpha, OneMinusSrcAlpha)
matrixMode GL.$= Projection
loadIdentity
ortho (-320) 320 (-240) 240 (-1) 1
translate (Vector3 0.5 0.5 zero)
-- Add some callbacks to GLFW
windowCloseCallback GL.$= exitWith ExitSuccess
windowSizeCallback GL.$= (\size -> viewport GL.$= (Position 0 0, size))
mouseButtonCallback GL.$= processMouseInput stateVar
-- Let's go!
now <- GL.get time
loop stateVar now
-- | The simulation loop.
loop :: IORef State -> Time -> IO ()
loop stateVar oldTime = do
-- Some key states
slowKey <- getKey (SpecialKey ENTER)
quitKey <- getKey (SpecialKey ESC)
clearKey <- getKey (SpecialKey DEL)
leftKey <- getKey (SpecialKey LEFT)
rightKey <- getKey (SpecialKey RIGHT)
-- Quit?
when (quitKey == Press) (terminate >> exitWith ExitSuccess)
-- Clear?
when (clearKey == Press) $ do
destroyState =<< readIORef stateVar
H.resetShapeCounter
initialState >>= writeIORef stateVar
-- Update display and time
updateCar stateVar leftKey rightKey
updateDisplay stateVar slowKey
newTime <- advanceTime stateVar oldTime slowKey
loop stateVar newTime
-- | Updates the car state
updateCar :: IORef State -> KeyButtonState -> KeyButtonState -> IO ()
updateCar stateVar leftKey rightKey = do
let wantsToBe = case (leftKey, rightKey) of
(Press, _) -> GoingLeft
(_, Press) -> GoingRight
_ -> Stopped
state <- readIORef stateVar
when (stCarState state /= wantsToBe) $ do
stControls state wantsToBe
writeIORef stateVar (state {stCarState = wantsToBe})
-- | Advances the time.
advanceTime :: IORef State -> Time -> KeyButtonState -> IO Time
advanceTime stateVar oldTime slowKey = do
newTime <- GL.get time
-- Advance simulation
let slower = if slowKey == Press then slowdown else 1
mult = frameSteps / (framePeriod * slower)
framesPassed = truncate $ mult * (newTime - oldTime)
simulNewTime = oldTime + toEnum framesPassed / mult
advanceSimulTime stateVar $ min maxSteps framesPassed
-- Correlate with reality
newTime' <- GL.get time
let diff = newTime' - simulNewTime
sleepTime = ((framePeriod * slower) - diff) / slower
when (sleepTime > 0) $ sleep sleepTime
return simulNewTime
------------------------------------------------------------
-- Display related functions
------------------------------------------------------------
-- | Renders the current state.
updateDisplay :: IORef State -> KeyButtonState -> IO ()
updateDisplay stateVar slowKey = do
state <- SV.get stateVar
clear [ColorBuffer]
drawInstructions
when (slowKey == Press) drawSlowMotion
forM_ (M.assocs $ stShapes state) (fst . snd) -- Draw each one
readIORef (stCollisionsVar state) >>= mapM_ (drawPoint CollisionPoint)
swapBuffers
drawInstructions :: IO ()
drawInstructions = preservingMatrix $ do
translate (Vector3 (-320) 240 zero)
scale 0.75 0.75 (1 `asTypeOf` zero)
let render str = do
translate (Vector3 zero (-16) zero)
renderString Fixed8x16 str
color $ Color3 zero zero 1
render "Press the left mouse button to create a ball."
render "Press the right mouse button to create a square."
render "Press the middle mouse button to create a triangle on a pendulum."
color $ Color3 1 zero zero
render "Hold LEFT SHIFT to create counterclockwise rotating objects."
render "Hold RIGHT SHIFT to create clockwise rotating objects."
render "Hold LEFT or RIGHT to move the car."
render "Hold ENTER to see in slow motion."
color $ Color3 zero zero zero
render "Press DEL to clear the screen."
drawSlowMotion :: IO ()
drawSlowMotion = preservingMatrix $ do
scale 2 2 (1 `asTypeOf` zero)
translate (Vector3 (-40) zero zero)
color $ Color3 zero 1 zero
renderString Fixed8x16 "Slowwww..."
-- | Draws a shape (assuming zero offset)
drawMyShape :: H.Shape -> H.ShapeType -> IO ()
drawMyShape shape (H.Circle radius) = do
H.Vector px py <- SV.get $ H.position $ H.body shape
angle <- SV.get $ H.angle $ H.body shape
color $ Color3 zero zero zero
renderPrimitive LineStrip $ do
let segs = 20; coef = 2*pi/toEnum segs
forM_ [0..segs] $ \i -> do
let r = toEnum i * coef
x = radius * cos (r + angle) + px
y = radius * sin (r + angle) + py
vertex' x y
vertex' px py
drawPoint PositionPoint (px +: py)
drawMyShape shape (H.LineSegment p1 p2 _) = do
let v (H.Vector x y) = vertex' x y
pos <- SV.get $ H.position $ H.body shape
color $ Color3 zero zero zero
renderPrimitive Lines $ v (p1 + pos) >> v (p2 + pos)
drawPoint PositionPoint pos
drawMyShape shape (H.Polygon verts) = do
pos <- SV.get $ H.position $ H.body shape
angle <- SV.get $ H.angle $ H.body shape
let rot = H.rotate $ H.fromAngle angle
verts' = map ((+pos) . rot) verts
color $ Color3 zero zero zero
renderPrimitive LineStrip $ do
forM_ (verts' ++ [head verts']) $ \(H.Vector x y) -> do
vertex' x y
drawPoint PositionPoint pos
-- | Draws a red point.
drawPoint :: PointType -> H.Vector -> IO ()
drawPoint pt (H.Vector px py) = do
color $ case pt of
PositionPoint -> Color3 zero zero 1
CollisionPoint -> Color3 1 zero zero
renderPrimitive Points $ do
vertex' px py
data PointType = PositionPoint | CollisionPoint
deriving (Eq, Ord, Show, Enum)
------------------------------------------------------------
-- Input processing
------------------------------------------------------------
-- | Returns the current mouse position in our space's coordinates.
getMousePos :: IO H.Position
getMousePos = do
Position cx cy <- GL.get mousePos
Size _ h <- GL.get $ windowSize
model <- GL.get $ matrix (Just $ Modelview 0)
proj <- GL.get $ matrix (Just Projection)
view <- GL.get $ viewport
let src = Vertex3 (fromIntegral cx) (fromIntegral h - fromIntegral cy) 0
Vertex3 mx my _ <- unProject src (model :: GLmatrix GLdouble) proj view
return (realToFrac mx +: realToFrac my)
-- | Process a user mouse button press.
processMouseInput :: IORef State -> MouseButton -> KeyButtonState -> IO ()
processMouseInput _ _ Press = return ()
processMouseInput stateVar btn Release = do
rotateKeyCCW <- getKey (SpecialKey LSHIFT)
rotateKeyCW <- getKey (SpecialKey RSHIFT)
let angVel = case (rotateKeyCCW, rotateKeyCW) of
(Press, Release) -> 50
(Release, Press) -> (-50)
_ -> 0
(shape,add,draw,remove) <- (case btn of
ButtonLeft -> createCircle
ButtonRight -> createSquare
_ -> createTriPendulum) angVel
state <- SV.get stateVar
let space = stSpace state
add space >> stateVar SV.$= state {
stShapes = M.insert shape (draw, remove space) $ stShapes state}
------------------------------------------------------------
-- Object creation
------------------------------------------------------------
-- | The return of functions that create objects.
type Creation = (H.Shape, -- ^ A representative shape
H.Space -> IO (), -- ^ Function that add the entities
IO (), -- ^ Function that draws the entity
H.Space -> IO () -- ^ Function that removes the entities
)
-- | The type of the functions that create objects.
type Creator = H.CpFloat -> IO Creation
createCircle :: Creator
createCircle angVel = do
let mass = 20
radius = 20
t = H.Circle radius
b <- H.newBody mass $ H.momentForCircle mass (0, radius) 0
s <- H.newShape b t 0
(H.position b SV.$=) =<< getMousePos
H.angVel b SV.$= angVel
H.friction s SV.$= 0.5
H.elasticity s SV.$= 0.9
let add space = do
H.spaceAdd space b
H.spaceAdd space s
let draw = do
drawMyShape s t
let remove space = do
H.spaceRemove space b
H.spaceRemove space s
return (s,add,draw,remove)
createSquare :: Creator
createSquare angVel = do
let mass = 18
verts = [-15 +: -15, -15 +: 15, 15 +: 15, 15 +: -15]
t = H.Polygon verts
b <- H.newBody mass $ H.momentForPoly mass verts 0
s <- H.newShape b t 0
(H.position b SV.$=) =<< getMousePos
H.angVel b SV.$= angVel
H.friction s SV.$= 0.5
H.elasticity s SV.$= 0.6
let add space = do
H.spaceAdd space b
H.spaceAdd space s
let draw = do
drawMyShape s t
let remove space = do
H.spaceRemove space b
H.spaceRemove space s
return (s,add,draw,remove)
createTriPendulum :: Creator
createTriPendulum angVel = do
let mass = 100
verts = [-30 +: -30, 0 +: 37, 30 +: -30]
t = H.Polygon verts
b <- H.newBody mass $ H.momentForPoly mass verts 0
s <- H.newShape b t 0
(H.position b SV.$=) =<< getMousePos
H.angVel b SV.$= angVel
H.friction s SV.$= 0.8
H.elasticity s SV.$= 0.3
let staticPos = 0 +: 240
static <- H.newBody H.infinity H.infinity
H.position static SV.$= staticPos
j <- H.newConstraint static b (H.Pin 0 0)
let add space = do
H.spaceAdd space b
H.spaceAdd space s
H.spaceAdd space j
let remove space = do
H.spaceRemove space b
H.spaceRemove space s
H.spaceRemove space j
let draw = do
H.Vector x1 y1 <- SV.get $ H.position b
let H.Vector x2 y2 = staticPos
color $ Color3 (0.7 `asTypeOf` zero) 0.7 0.7
renderPrimitive LineStrip $ do
let
vertex' x1 y1
vertex' x2 y2
drawMyShape s t
return (s,add,draw,remove)
vertex' :: Double -> Double -> IO ()
vertex' x y = let f p = realToFrac p :: GLdouble
in vertex (Vertex2 (f x) (f y))
------------------------------------------------------------
-- Simulation bookkeeping
------------------------------------------------------------
-- | Advances the time in a certain number of steps.
advanceSimulTime :: IORef State -> Int -> IO ()
advanceSimulTime _ 0 = return ()
advanceSimulTime stateVar steps = do
removeOutOfSight stateVar
state <- SV.get stateVar
-- Do (steps-1) steps that clear the collisions variable.
let clearCollisions = writeIORef (stCollisionsVar state) []
step = H.step (stSpace state) frameDelta
replicateM_ (steps-1) $ step >> clearCollisions
-- Do a final step that will leave the collisions variable filled.
step
-- | Removes all shapes that may be out of sight forever.
removeOutOfSight :: IORef State -> IO ()
removeOutOfSight stateVar = do
state <- SV.get stateVar
shapes' <- foldM f (stShapes state) $ M.assocs (stShapes state)
stateVar SV.$= state {stShapes = shapes'}
where
f shapes (shape, (_,remove)) = do
H.Vector x y <- SV.get $ H.position $ H.body shape
if y < (-350) || abs x > 800
then remove >> return (M.delete shape shapes)
else return shapes