diff options
author | 3gg <3gg@shellblade.net> | 2024-12-24 12:07:05 -0800 |
---|---|---|
committer | 3gg <3gg@shellblade.net> | 2024-12-24 12:07:05 -0800 |
commit | 92e7a93d8c1475bdc802d10a1722bcf8a295449d (patch) | |
tree | fc4ada902fec59e461aceff1cafddf87eaeb938c | |
parent | 0e62e481f56e7085856a4650268c04ac9d05fb9c (diff) |
-rw-r--r-- | Demos/Pong/Pong.hs | 101 | ||||
-rw-r--r-- | Spear.cabal | 2 | ||||
-rw-r--r-- | Spear/Math/Physics/Rigid.hs | 125 | ||||
-rw-r--r-- | Spear/Math/Physics/Types.hs | 11 | ||||
-rw-r--r-- | Spear/Physics/Collision.hs | 63 | ||||
-rw-r--r-- | Spear/Physics/RigidBody.hs | 77 |
6 files changed, 203 insertions, 176 deletions
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs index b9661ee..b12f792 100644 --- a/Demos/Pong/Pong.hs +++ b/Demos/Pong/Pong.hs | |||
@@ -16,10 +16,11 @@ import Spear.Math.Algebra | |||
16 | import Spear.Math.Spatial | 16 | import Spear.Math.Spatial |
17 | import Spear.Math.Spatial2 | 17 | import Spear.Math.Spatial2 |
18 | import Spear.Math.Vector | 18 | import Spear.Math.Vector |
19 | import Spear.Physics.Collision | ||
19 | import Spear.Prelude | 20 | import Spear.Prelude |
20 | import Spear.Step | 21 | import Spear.Step |
21 | 22 | ||
22 | import Data.Monoid (mconcat) | 23 | import Data.Monoid (mconcat) |
23 | 24 | ||
24 | 25 | ||
25 | -- Configuration | 26 | -- Configuration |
@@ -41,14 +42,22 @@ initialBallPos = vec2 0.5 0.5 | |||
41 | data GameEvent | 42 | data GameEvent |
42 | = MoveLeft | 43 | = MoveLeft |
43 | | MoveRight | 44 | | MoveRight |
44 | deriving (Eq, Ord, Show) | 45 | | Collision GameObjectId GameObjectId |
46 | deriving (Eq, Show) | ||
45 | 47 | ||
46 | -- Game objects | 48 | -- Game objects |
47 | 49 | ||
50 | data GameObjectId | ||
51 | = Ball | ||
52 | | Enemy | ||
53 | | Player | ||
54 | deriving (Eq, Show) | ||
55 | |||
48 | data GameObject = GameObject | 56 | data GameObject = GameObject |
49 | { aabb :: AABB2, | 57 | { gameObjectId :: !GameObjectId |
50 | basis :: Transform2, | 58 | , aabb :: {-# UNPACK #-} !AABB2 |
51 | gostep :: Step [GameObject] [GameEvent] GameObject GameObject | 59 | , basis :: {-# UNPACK #-} !Transform2 |
60 | , gostep :: Step [GameObject] [GameEvent] GameObject GameObject | ||
52 | } | 61 | } |
53 | 62 | ||
54 | 63 | ||
@@ -78,46 +87,68 @@ instance Spatial GameObject Vector2 Angle Transform2 where | |||
78 | transform = basis | 87 | transform = basis |
79 | 88 | ||
80 | 89 | ||
90 | instance Bounded2 GameObject where | ||
91 | boundingVolume obj = aabb2Volume $ translate (position obj) (aabb obj) | ||
92 | |||
93 | |||
81 | ballBox, padBox :: AABB2 | 94 | ballBox, padBox :: AABB2 |
82 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize | 95 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize |
83 | padBox = AABB2 (-padSize) padSize | 96 | padBox = AABB2 (-padSize) padSize |
84 | 97 | ||
85 | newWorld = | 98 | newWorld = |
86 | [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity, | 99 | [ GameObject Ball ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity, |
87 | GameObject padBox (makeAt initialEnemyPos) stepEnemy, | 100 | GameObject Enemy padBox (makeAt initialEnemyPos) stepEnemy, |
88 | GameObject padBox (makeAt initialPlayerPos) stepPlayer | 101 | GameObject Player padBox (makeAt initialPlayerPos) stepPlayer |
89 | ] | 102 | ] |
90 | where makeAt = newTransform2 unitx2 unity2 | 103 | where makeAt = newTransform2 unitx2 unity2 |
91 | 104 | ||
92 | 105 | ||
106 | -- Step the game world: | ||
107 | -- 1. Simulate physics. | ||
108 | -- 2. Collide objects and clip -> produce collision events. | ||
109 | -- 3. Update game objects <- input collision events. | ||
93 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | 110 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] |
94 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | 111 | stepWorld elapsed dt events gos@[ball, enemy, player] = |
112 | let | ||
113 | collisions = collide [ball] [enemy, player] | ||
114 | collisionEvents = (\(x,y) -> Collision (gameObjectId x) (gameObjectId y)) <$> collisions | ||
115 | events' = events ++ collisionEvents | ||
116 | gos' = map (update elapsed dt events' gos) gos | ||
117 | in | ||
118 | gos' | ||
95 | 119 | ||
96 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | 120 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject |
97 | update elapsed dt evts gos go = | 121 | update elapsed dt events gos go = |
98 | let (go', s') = runStep (gostep go) elapsed dt gos evts go | 122 | let (go', s') = runStep (gostep go) elapsed dt gos events go |
99 | in go' {gostep = s'} | 123 | in go' { gostep = s' } |
124 | |||
100 | 125 | ||
101 | -- Ball steppers | 126 | -- Ball steppers |
102 | 127 | ||
103 | stepBall vel = collideBall vel .> moveBall | 128 | stepBall vel = bounceBall vel .> moveBall |
104 | 129 | ||
105 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | 130 | bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject) |
106 | collideBall vel = step $ \_ dt gos _ ball -> | 131 | bounceBall vel = step $ \_ dt gos events ball -> |
107 | let (AABB2 pmin pmax) = translate (position ball) (aabb ball) | 132 | let (AABB2 pmin pmax) = translate (position ball) (aabb ball) |
108 | sideCollision = x pmin < 0 || x pmax > 1 | 133 | sideCollision = x pmin < 0 || x pmax > 1 |
109 | backCollision = y pmin < 0 || y pmax > 1 | 134 | backCollision = y pmin < 0 || y pmax > 1 |
110 | flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v | 135 | flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v |
111 | flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v | 136 | flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v |
112 | vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel | 137 | collideWithPaddles vel = foldl (paddleBounce ball events) vel (tail gos) |
138 | vel' = normalise | ||
139 | . collideWithPaddles | ||
140 | . flipX | ||
141 | . flipY | ||
142 | $ vel | ||
113 | collision = vel' /= vel | 143 | collision = vel' /= vel |
114 | -- Apply offset when collision occurs to avoid sticky collisions. | 144 | -- Apply offset when collision occurs to avoid sticky collisions. |
115 | delta = (1::Float) + if collision then (3::Float)*dt else (0::Float) | 145 | delta = (1::Float) + if collision then (3::Float)*dt else (0::Float) |
116 | in ((ballSpeed * delta * vel', ball), collideBall vel') | 146 | in ((ballSpeed * delta * vel', ball), bounceBall vel') |
117 | 147 | ||
118 | paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 | 148 | paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2 |
119 | paddleBounce ball v paddle = | 149 | paddleBounce ball events vel paddle = |
120 | if collide ball paddle | 150 | let collision = Collision Ball (gameObjectId paddle) `elem` events |
151 | in if collision | ||
121 | then | 152 | then |
122 | let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle) | 153 | let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle) |
123 | center = (x pmin + x pmax) / (2::Float) | 154 | center = (x pmin + x pmax) / (2::Float) |
@@ -126,25 +157,14 @@ paddleBounce ball v paddle = | |||
126 | offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float)) | 157 | offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float)) |
127 | angle = offset * maxBounceAngle | 158 | angle = offset * maxBounceAngle |
128 | -- When it bounces off of a paddle, y vel is flipped. | 159 | -- When it bounces off of a paddle, y vel is flipped. |
129 | ysign = -(signum (y v)) | 160 | ysign = -(signum (y vel)) |
130 | in vec2 (sin angle) (ysign * cos angle) | 161 | in vec2 (sin angle) (ysign * cos angle) |
131 | else v | 162 | else vel |
132 | |||
133 | collide :: GameObject -> GameObject -> Bool | ||
134 | collide go1 go2 = | ||
135 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = | ||
136 | translate (position go1) (aabb go1) | ||
137 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = | ||
138 | translate (position go2) (aabb go2) | ||
139 | in not $ | ||
140 | xmax1 < xmin2 || | ||
141 | xmin1 > xmax2 || | ||
142 | ymax1 < ymin2 || | ||
143 | ymin1 > ymax2 | ||
144 | 163 | ||
145 | moveBall :: Step s e (Vector2, GameObject) GameObject | 164 | moveBall :: Step s e (Vector2, GameObject) GameObject |
146 | moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) | 165 | moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) |
147 | 166 | ||
167 | |||
148 | -- Enemy stepper | 168 | -- Enemy stepper |
149 | 169 | ||
150 | stepEnemy = movePad 0 .> clamp | 170 | stepEnemy = movePad 0 .> clamp |
@@ -161,17 +181,18 @@ movePad previousMomentumVector = step $ \_ dt gos _ pad -> | |||
161 | sign :: Float -> Float | 181 | sign :: Float -> Float |
162 | sign x = if x >= 0 then 1 else -1 | 182 | sign x = if x >= 0 then 1 else -1 |
163 | 183 | ||
184 | |||
164 | -- Player stepper | 185 | -- Player stepper |
165 | 186 | ||
166 | stepPlayer = sfold moveGO .> clamp | 187 | stepPlayer = sfold movePlayer .> clamp |
167 | 188 | ||
168 | moveGO = mconcat | 189 | movePlayer = mconcat |
169 | [ swhen MoveLeft $ moveGO' (vec2 (-playerSpeed) 0) | 190 | [ swhen MoveLeft $ movePlayer' (vec2 (-playerSpeed) 0) |
170 | , swhen MoveRight $ moveGO' (vec2 playerSpeed 0) | 191 | , swhen MoveRight $ movePlayer' (vec2 playerSpeed 0) |
171 | ] | 192 | ] |
172 | 193 | ||
173 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 194 | movePlayer' :: Vector2 -> Step s e GameObject GameObject |
174 | moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) | 195 | movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir) |
175 | 196 | ||
176 | clamp :: Step s e GameObject GameObject | 197 | clamp :: Step s e GameObject GameObject |
177 | clamp = spure $ \go -> | 198 | clamp = spure $ \go -> |
diff --git a/Spear.cabal b/Spear.cabal index 8ccc628..306ef6a 100644 --- a/Spear.cabal +++ b/Spear.cabal | |||
@@ -62,6 +62,8 @@ library | |||
62 | Spear.Math.Vector.Vector2 | 62 | Spear.Math.Vector.Vector2 |
63 | Spear.Math.Vector.Vector3 | 63 | Spear.Math.Vector.Vector3 |
64 | Spear.Math.Vector.Vector4 | 64 | Spear.Math.Vector.Vector4 |
65 | Spear.Physics.Collision | ||
66 | Spear.Physics.RigidBody | ||
65 | Spear.Prelude | 67 | Spear.Prelude |
66 | Spear.Render.AnimatedModel | 68 | Spear.Render.AnimatedModel |
67 | Spear.Render.Core | 69 | Spear.Render.Core |
diff --git a/Spear/Math/Physics/Rigid.hs b/Spear/Math/Physics/Rigid.hs deleted file mode 100644 index 28995bd..0000000 --- a/Spear/Math/Physics/Rigid.hs +++ /dev/null | |||
@@ -1,125 +0,0 @@ | |||
1 | module Spear.Math.Physics.Rigid | ||
2 | ( | ||
3 | module Spear.Math.Physics.Types | ||
4 | , RigidBody(..) | ||
5 | , rigidBody | ||
6 | , update | ||
7 | , setVelocity | ||
8 | , setAcceleration | ||
9 | ) | ||
10 | where | ||
11 | |||
12 | import qualified Spear.Math.Matrix3 as M3 | ||
13 | import Spear.Math.Spatial2 | ||
14 | import Spear.Math.Vector | ||
15 | import Spear.Physics.Types | ||
16 | |||
17 | import Data.List (foldl') | ||
18 | import Control.Monad.State | ||
19 | |||
20 | data RigidBody = RigidBody | ||
21 | { mass :: {-# UNPACK #-} !Float | ||
22 | , position :: {-# UNPACK #-} !Position | ||
23 | , velocity :: {-# UNPACK #-} !Velocity | ||
24 | , acceleration :: {-# UNPACK #-} !Acceleration | ||
25 | } | ||
26 | |||
27 | instance Spatial2 RigidBody where | ||
28 | |||
29 | move v body = body { position = v + position body } | ||
30 | |||
31 | moveFwd speed body = body { position = position body + scale speed unity2 } | ||
32 | |||
33 | moveBack speed body = body { position = position body + scale (-speed) unity2 } | ||
34 | |||
35 | strafeLeft speed body = body { position = position body + scale (-speed) unitx2 } | ||
36 | |||
37 | strafeRight speed body = body { position = position body + scale speed unitx2 } | ||
38 | |||
39 | rotate angle = id | ||
40 | |||
41 | setRotation angle = id | ||
42 | |||
43 | pos = position | ||
44 | |||
45 | fwd _ = unity2 | ||
46 | |||
47 | up _ = unity2 | ||
48 | |||
49 | right _ = unitx2 | ||
50 | |||
51 | transform body = M3.transform unitx2 unity2 $ position body | ||
52 | |||
53 | setTransform transf body = body { position = M3.position transf } | ||
54 | |||
55 | setPos p body = body { position = p } | ||
56 | |||
57 | -- | Build a 'RigidBody'. | ||
58 | rigidBody :: Mass -> Position -> RigidBody | ||
59 | rigidBody m x = RigidBody m x zero2 zero2 | ||
60 | |||
61 | -- | Update the given 'RigidBody'. | ||
62 | update :: [Force] -> Dt -> RigidBody -> RigidBody | ||
63 | update forces dt body = | ||
64 | let netforce = foldl' (+) zero2 forces | ||
65 | m = mass body | ||
66 | r1 = position body | ||
67 | v1 = velocity body | ||
68 | a1 = acceleration body | ||
69 | r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1 | ||
70 | v' = v1 + scale (0.5*dt) a1 | ||
71 | a2 = a1 + scale (1/m) netforce | ||
72 | v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2 | ||
73 | in | ||
74 | RigidBody m r2 v2 a2 | ||
75 | |||
76 | -- | Set the body's velocity. | ||
77 | setVelocity :: Velocity -> RigidBody -> RigidBody | ||
78 | setVelocity v body = body { velocity = v } | ||
79 | |||
80 | -- | Set the body's acceleration. | ||
81 | setAcceleration :: Acceleration -> RigidBody -> RigidBody | ||
82 | setAcceleration a body = body { acceleration = a } | ||
83 | |||
84 | |||
85 | -- test | ||
86 | {-gravity = vec2 0 (-10) | ||
87 | b0 = rigidBody 50 $ vec2 0 1000 | ||
88 | |||
89 | |||
90 | debug :: IO () | ||
91 | debug = evalStateT debug' b0 | ||
92 | |||
93 | |||
94 | |||
95 | debug' :: StateT RigidBody IO () | ||
96 | debug' = do | ||
97 | lift . putStrLn $ "Initial body:" | ||
98 | lift . putStrLn . show' $ b0 | ||
99 | lift . putStrLn $ "Falling..." | ||
100 | step $ update [gravity*50] 1 | ||
101 | step $ update [gravity*50] 1 | ||
102 | step $ update [gravity*50] 1 | ||
103 | lift . putStrLn $ "Jumping" | ||
104 | step $ update [gravity*50, vec2 0 9000] 1 | ||
105 | lift . putStrLn $ "Falling..." | ||
106 | step $ update [gravity*50] 1 | ||
107 | step $ update [gravity*50] 1 | ||
108 | step $ update [gravity*50] 1 | ||
109 | |||
110 | |||
111 | step :: (RigidBody -> RigidBody) -> StateT RigidBody IO () | ||
112 | step update = do | ||
113 | modify update | ||
114 | body <- get | ||
115 | lift . putStrLn . show' $ body | ||
116 | |||
117 | |||
118 | show' body = | ||
119 | "mass " ++ (show $ mass body) ++ | ||
120 | ", position " ++ (showVec $ position body) ++ | ||
121 | ", velocity " ++ (showVec $ velocity body) ++ | ||
122 | ", acceleration " ++ (showVec $ acceleration body) | ||
123 | |||
124 | |||
125 | showVec v = (show $ x v) ++ ", " ++ (show $ y v)-} | ||
diff --git a/Spear/Math/Physics/Types.hs b/Spear/Math/Physics/Types.hs deleted file mode 100644 index 59e6c74..0000000 --- a/Spear/Math/Physics/Types.hs +++ /dev/null | |||
@@ -1,11 +0,0 @@ | |||
1 | module Spear.Math.Physics.Types | ||
2 | where | ||
3 | |||
4 | import Spear.Math.Vector | ||
5 | |||
6 | type Dt = Float | ||
7 | type Force = Vector2 | ||
8 | type Mass = Float | ||
9 | type Position = Vector2 | ||
10 | type Velocity = Vector2 | ||
11 | type Acceleration = Vector2 | ||
diff --git a/Spear/Physics/Collision.hs b/Spear/Physics/Collision.hs new file mode 100644 index 0000000..9ade9ca --- /dev/null +++ b/Spear/Physics/Collision.hs | |||
@@ -0,0 +1,63 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
3 | {-# LANGUAGE NoImplicitPrelude #-} | ||
4 | {-# LANGUAGE TypeSynonymInstances #-} | ||
5 | |||
6 | module Spear.Physics.Collision | ||
7 | ( | ||
8 | BoundingVolume2(..) | ||
9 | , Bounded2(..) | ||
10 | , aabb2Volume | ||
11 | , collide | ||
12 | ) | ||
13 | where | ||
14 | |||
15 | import Spear.Math.AABB | ||
16 | import Spear.Math.Spatial | ||
17 | import Spear.Math.Spatial2 | ||
18 | import Spear.Math.Vector | ||
19 | import Spear.Prelude | ||
20 | |||
21 | import Data.Maybe (mapMaybe) | ||
22 | |||
23 | |||
24 | -- Currently supporting AABB2. Add circles later when needed. | ||
25 | data BoundingVolume2 | ||
26 | = AABB2Volume { box2 :: {-# UNPACK #-} !AABB2 } | ||
27 | |||
28 | |||
29 | class Bounded2 a where | ||
30 | boundingVolume :: a -> BoundingVolume2 | ||
31 | |||
32 | |||
33 | -- | Construct a new bounding volume from a 2D axis-aligned box. | ||
34 | aabb2Volume :: AABB2 -> BoundingVolume2 | ||
35 | aabb2Volume = AABB2Volume | ||
36 | |||
37 | |||
38 | -- | Find collisions between the objects in the first list and the objects in | ||
39 | -- the second list. | ||
40 | collide :: Bounded2 a => [a] -> [a] -> [(a,a)] | ||
41 | collide xs ys = | ||
42 | mapMaybe testCollision pairs | ||
43 | where | ||
44 | testCollision [o1, o2] = if objectsCollide o1 o2 then Just (o1, o2) else Nothing | ||
45 | pairs = sequence [xs, ys] | ||
46 | |||
47 | |||
48 | -- | Test two objects for collision. | ||
49 | objectsCollide :: Bounded2 a => a -> a -> Bool | ||
50 | objectsCollide o1 o2 = | ||
51 | collideAABB2 (box2 . boundingVolume $ o1) (box2 . boundingVolume $ o2) | ||
52 | |||
53 | |||
54 | -- | Test two 2D axis-aligned bounding boxes for collision. | ||
55 | collideAABB2 :: AABB2 -> AABB2 -> Bool | ||
56 | collideAABB2 box1 box2 = | ||
57 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = box1 | ||
58 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = box2 | ||
59 | in not $ | ||
60 | xmax1 < xmin2 || | ||
61 | xmin1 > xmax2 || | ||
62 | ymax1 < ymin2 || | ||
63 | ymin1 > ymax2 | ||
diff --git a/Spear/Physics/RigidBody.hs b/Spear/Physics/RigidBody.hs new file mode 100644 index 0000000..1a8fe0a --- /dev/null +++ b/Spear/Physics/RigidBody.hs | |||
@@ -0,0 +1,77 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
3 | {-# LANGUAGE NoImplicitPrelude #-} | ||
4 | {-# LANGUAGE TypeSynonymInstances #-} | ||
5 | |||
6 | module Spear.Physics.RigidBody | ||
7 | ( | ||
8 | RigidBody2 | ||
9 | , rigidBody | ||
10 | , setVelocity | ||
11 | , setAcceleration | ||
12 | , update | ||
13 | ) | ||
14 | where | ||
15 | |||
16 | import Spear.Math.Spatial | ||
17 | import Spear.Math.Spatial2 | ||
18 | import Spear.Math.Vector | ||
19 | import Spear.Prelude | ||
20 | |||
21 | import Control.Monad.State | ||
22 | import Data.List (foldl') | ||
23 | |||
24 | |||
25 | type Dt = Float | ||
26 | type Force = Vector2 | ||
27 | type Mass = Float | ||
28 | type Position = Vector2 | ||
29 | type Velocity = Vector2 | ||
30 | type Acceleration = Vector2 | ||
31 | |||
32 | |||
33 | {- class RigidBody2 a where | ||
34 | bodyMass :: a -> Float | ||
35 | bodyPosition :: a -> Vector2 | ||
36 | bodyVelocity :: a -> Vector2 | ||
37 | bodyAcceleration :: a -> Vector2 -} | ||
38 | |||
39 | |||
40 | data RigidBody2 = RigidBody2 | ||
41 | { bodyMass :: {-# UNPACK #-} !Float | ||
42 | , bodyPosition :: {-# UNPACK #-} !Position | ||
43 | , bodyVelocity :: {-# UNPACK #-} !Velocity | ||
44 | , bodyAcceleration :: {-# UNPACK #-} !Acceleration | ||
45 | } | ||
46 | |||
47 | |||
48 | instance Positional RigidBody2 Vector2 where | ||
49 | setPosition p body = body { bodyPosition = p } | ||
50 | position = bodyPosition | ||
51 | translate v body = body { bodyPosition = bodyPosition body + v } | ||
52 | |||
53 | |||
54 | -- | Build a 'RigidBody'. | ||
55 | rigidBody :: Mass -> Position -> RigidBody2 | ||
56 | rigidBody mass position = RigidBody2 mass position zero2 zero2 | ||
57 | |||
58 | |||
59 | -- | Set the body's velocity. | ||
60 | setVelocity :: Velocity -> RigidBody2 -> RigidBody2 | ||
61 | setVelocity velocity body = body { bodyVelocity = velocity } | ||
62 | |||
63 | |||
64 | -- | Set the body's acceleration. | ||
65 | setAcceleration :: Acceleration -> RigidBody2 -> RigidBody2 | ||
66 | setAcceleration acceleration body = body { bodyAcceleration = acceleration } | ||
67 | |||
68 | |||
69 | -- | Update the given 'RigidBody'. | ||
70 | update :: [Force] -> Dt -> RigidBody2 -> RigidBody2 | ||
71 | update forces dt body@(RigidBody2 m p v a) = | ||
72 | let f = foldl' (+) zero2 forces | ||
73 | a' = a + (f / m) | ||
74 | v' = v + (a' * dt) | ||
75 | p' = p + (v' * dt) | ||
76 | in | ||
77 | RigidBody2 m p' v' a' | ||