/
Physics.hs
134 lines (112 loc) · 4.16 KB
/
Physics.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
module Physics where
import Physics.Hipmunk
import Control.Concurrent.STM
import Types
import Control.Monad.SFML
import Control.Monad
import Control.Monad.Trans.State
import Control.Lens
import Data.Default
import Data.IORef
import Linear.V2
import Data.StateVar
instance Default PhysicsConfig where
def = PhysicsConfig {
_defGravity = V2 0.0 0.01
, _defMass = 1.0
, _defFriction = 1.0
, _defElasticity = 0.0
, _defMoment = momentForShape
}
--------------------------------------------------------------------------------
defaultCollisionHandler :: IORef [(Shape, Shape)] -> CollisionHandler
defaultCollisionHandler collPool = Handler Nothing Nothing (Just postSolveHldr) Nothing
where
postSolveHldr = do
shapesInvolved <- shapes
liftIO $ modifyIORef collPool (shapesInvolved :)
fmap length (liftIO $ readIORef collPool)
return ()
--------------------------------------------------------------------------------
createPhysicsManager :: IO PhysicsManager
createPhysicsManager = do
initChipmunk
newWorld <- newSpace
queue <- newTQueueIO
collPool <- newIORef []
let cfg = def
gravity newWorld $= toHipmunkVector (cfg ^. defGravity)
--setDefaultCollisionHandler newWorld (defaultCollisionHandler collPool)
return PhysicsManager {
_world = newWorld
, _bodies = 0
, _collisionPool = collPool
, _bodyPool = queue
, _physicsCfg = def
}
--------------------------------------------------------------------------------
destroyPhysicManager :: GameMonad ()
destroyPhysicManager = do
mgr <- gets . view $ managers . physicsMgr
liftIO $ freeSpace (mgr ^. world)
--------------------------------------------------------------------------------
toHipmunkVector :: V2 Double -> Vector
toHipmunkVector (V2 x y) = Vector x y
--------------------------------------------------------------------------------
toHipmunkVectorI :: V2 Int -> Vector
toHipmunkVectorI (V2 x y) = Vector (fromIntegral x) (fromIntegral y)
--------------------------------------------------------------------------------
fromHipmunkVector :: Vector -> V2 Double
fromHipmunkVector (Vector x y) = V2 x y
--------------------------------------------------------------------------------
-- Add a new dynamic body to the Physic Manager
addDynamicShape :: ShapeType -> V2 Double -> GameMonad Shape
addDynamicShape shpTyp pos = do
pMgr <- gets . view $ managers . physicsMgr
let cfg = pMgr ^. physicsCfg
let defaultMass = cfg ^. defMass
let momentFn = cfg ^. defMoment
let defaultMoment = momentFn defaultMass shpTyp 0
addShape' defaultMass defaultMoment False shpTyp pos
--------------------------------------------------------------------------------
-- Add a new static body to the Physic Manager
addStaticShape :: ShapeType -> V2 Double -> GameMonad Shape
addStaticShape = addShape' infinity infinity True
--------------------------------------------------------------------------------
bodyFromPool :: Mass -> Moment -> GameMonad Body
bodyFromPool mss mom = do
pMgr <- gets $ view $ managers . physicsMgr
pool <- gets $ view $ managers . physicsMgr . bodyPool
bod <- liftIO $ atomically $ tryReadTQueue pool
case bod of
Nothing -> do
body' <- liftIO $ newBody mss mom
managers . physicsMgr .= (bodies +~ 1 $ pMgr)
initBody body'
Just b -> initBody b
where
initBody bod = do
liftIO $ moment bod $= mom
liftIO $ mass bod $= mss
return bod
--------------------------------------------------------------------------------
addShape' :: Double
-> Double
-> Bool
-> ShapeType
-> V2 Double
-> GameMonad Shape
addShape' mss momt isStatic shpTyp pos = do
pMgr <- gets $ view $ managers . physicsMgr
let defaultFriction = pMgr ^. physicsCfg . defFriction
let defaultElasticity = pMgr ^. physicsCfg . defElasticity
let wrld = pMgr ^. world
bd <- bodyFromPool mss momt
liftIO $ position bd $= toHipmunkVector pos
sh <- liftIO $ newShape bd shpTyp 0
liftIO $ do
friction sh $= defaultFriction
elasticity sh $= defaultElasticity
unless isStatic $ liftIO $ spaceAdd wrld bd
liftIO $ spaceAdd wrld sh
return sh