aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
author3gg <3gg@shellblade.net>2024-12-24 12:07:05 -0800
committer3gg <3gg@shellblade.net>2024-12-24 12:07:05 -0800
commit92e7a93d8c1475bdc802d10a1722bcf8a295449d (patch)
treefc4ada902fec59e461aceff1cafddf87eaeb938c
parent0e62e481f56e7085856a4650268c04ac9d05fb9c (diff)
New physics module.
Diffstat
-rw-r--r--Demos/Pong/Pong.hs101
-rw-r--r--Spear.cabal2
-rw-r--r--Spear/Math/Physics/Rigid.hs125
-rw-r--r--Spear/Math/Physics/Types.hs11
-rw-r--r--Spear/Physics/Collision.hs63
-rw-r--r--Spear/Physics/RigidBody.hs77
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
16import Spear.Math.Spatial 16import Spear.Math.Spatial
17import Spear.Math.Spatial2 17import Spear.Math.Spatial2
18import Spear.Math.Vector 18import Spear.Math.Vector
19import Spear.Physics.Collision
19import Spear.Prelude 20import Spear.Prelude
20import Spear.Step 21import Spear.Step
21 22
22import Data.Monoid (mconcat) 23import Data.Monoid (mconcat)
23 24
24 25
25-- Configuration 26-- Configuration
@@ -41,14 +42,22 @@ initialBallPos = vec2 0.5 0.5
41data GameEvent 42data 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
50data GameObjectId
51 = Ball
52 | Enemy
53 | Player
54 deriving (Eq, Show)
55
48data GameObject = GameObject 56data 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
90instance Bounded2 GameObject where
91 boundingVolume obj = aabb2Volume $ translate (position obj) (aabb obj)
92
93
81ballBox, padBox :: AABB2 94ballBox, padBox :: AABB2
82ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize 95ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
83padBox = AABB2 (-padSize) padSize 96padBox = AABB2 (-padSize) padSize
84 97
85newWorld = 98newWorld =
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.
93stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] 110stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
94stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos 111stepWorld 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
96update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject 120update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
97update elapsed dt evts gos go = 121update 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
103stepBall vel = collideBall vel .> moveBall 128stepBall vel = bounceBall vel .> moveBall
104 129
105collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) 130bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
106collideBall vel = step $ \_ dt gos _ ball -> 131bounceBall 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
118paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 148paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2
119paddleBounce ball v paddle = 149paddleBounce 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
133collide :: GameObject -> GameObject -> Bool
134collide 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
145moveBall :: Step s e (Vector2, GameObject) GameObject 164moveBall :: Step s e (Vector2, GameObject) GameObject
146moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) 165moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
147 166
167
148-- Enemy stepper 168-- Enemy stepper
149 169
150stepEnemy = movePad 0 .> clamp 170stepEnemy = movePad 0 .> clamp
@@ -161,17 +181,18 @@ movePad previousMomentumVector = step $ \_ dt gos _ pad ->
161sign :: Float -> Float 181sign :: Float -> Float
162sign x = if x >= 0 then 1 else -1 182sign x = if x >= 0 then 1 else -1
163 183
184
164-- Player stepper 185-- Player stepper
165 186
166stepPlayer = sfold moveGO .> clamp 187stepPlayer = sfold movePlayer .> clamp
167 188
168moveGO = mconcat 189movePlayer = 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
173moveGO' :: Vector2 -> Step s e GameObject GameObject 194movePlayer' :: Vector2 -> Step s e GameObject GameObject
174moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) 195movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir)
175 196
176clamp :: Step s e GameObject GameObject 197clamp :: Step s e GameObject GameObject
177clamp = spure $ \go -> 198clamp = 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 @@
1module Spear.Math.Physics.Rigid
2(
3 module Spear.Math.Physics.Types
4, RigidBody(..)
5, rigidBody
6, update
7, setVelocity
8, setAcceleration
9)
10where
11
12import qualified Spear.Math.Matrix3 as M3
13import Spear.Math.Spatial2
14import Spear.Math.Vector
15import Spear.Physics.Types
16
17import Data.List (foldl')
18import Control.Monad.State
19
20data RigidBody = RigidBody
21 { mass :: {-# UNPACK #-} !Float
22 , position :: {-# UNPACK #-} !Position
23 , velocity :: {-# UNPACK #-} !Velocity
24 , acceleration :: {-# UNPACK #-} !Acceleration
25 }
26
27instance 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'.
58rigidBody :: Mass -> Position -> RigidBody
59rigidBody m x = RigidBody m x zero2 zero2
60
61-- | Update the given 'RigidBody'.
62update :: [Force] -> Dt -> RigidBody -> RigidBody
63update 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.
77setVelocity :: Velocity -> RigidBody -> RigidBody
78setVelocity v body = body { velocity = v }
79
80-- | Set the body's acceleration.
81setAcceleration :: Acceleration -> RigidBody -> RigidBody
82setAcceleration a body = body { acceleration = a }
83
84
85-- test
86{-gravity = vec2 0 (-10)
87b0 = rigidBody 50 $ vec2 0 1000
88
89
90debug :: IO ()
91debug = evalStateT debug' b0
92
93
94
95debug' :: StateT RigidBody IO ()
96debug' = 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
111step :: (RigidBody -> RigidBody) -> StateT RigidBody IO ()
112step update = do
113 modify update
114 body <- get
115 lift . putStrLn . show' $ body
116
117
118show' body =
119 "mass " ++ (show $ mass body) ++
120 ", position " ++ (showVec $ position body) ++
121 ", velocity " ++ (showVec $ velocity body) ++
122 ", acceleration " ++ (showVec $ acceleration body)
123
124
125showVec 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 @@
1module Spear.Math.Physics.Types
2where
3
4import Spear.Math.Vector
5
6type Dt = Float
7type Force = Vector2
8type Mass = Float
9type Position = Vector2
10type Velocity = Vector2
11type 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
6module Spear.Physics.Collision
7(
8 BoundingVolume2(..)
9, Bounded2(..)
10, aabb2Volume
11, collide
12)
13where
14
15import Spear.Math.AABB
16import Spear.Math.Spatial
17import Spear.Math.Spatial2
18import Spear.Math.Vector
19import Spear.Prelude
20
21import Data.Maybe (mapMaybe)
22
23
24-- Currently supporting AABB2. Add circles later when needed.
25data BoundingVolume2
26 = AABB2Volume { box2 :: {-# UNPACK #-} !AABB2 }
27
28
29class Bounded2 a where
30 boundingVolume :: a -> BoundingVolume2
31
32
33-- | Construct a new bounding volume from a 2D axis-aligned box.
34aabb2Volume :: AABB2 -> BoundingVolume2
35aabb2Volume = AABB2Volume
36
37
38-- | Find collisions between the objects in the first list and the objects in
39-- the second list.
40collide :: Bounded2 a => [a] -> [a] -> [(a,a)]
41collide 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.
49objectsCollide :: Bounded2 a => a -> a -> Bool
50objectsCollide o1 o2 =
51 collideAABB2 (box2 . boundingVolume $ o1) (box2 . boundingVolume $ o2)
52
53
54-- | Test two 2D axis-aligned bounding boxes for collision.
55collideAABB2 :: AABB2 -> AABB2 -> Bool
56collideAABB2 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
6module Spear.Physics.RigidBody
7(
8 RigidBody2
9, rigidBody
10, setVelocity
11, setAcceleration
12, update
13)
14where
15
16import Spear.Math.Spatial
17import Spear.Math.Spatial2
18import Spear.Math.Vector
19import Spear.Prelude
20
21import Control.Monad.State
22import Data.List (foldl')
23
24
25type Dt = Float
26type Force = Vector2
27type Mass = Float
28type Position = Vector2
29type Velocity = Vector2
30type 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
40data RigidBody2 = RigidBody2
41 { bodyMass :: {-# UNPACK #-} !Float
42 , bodyPosition :: {-# UNPACK #-} !Position
43 , bodyVelocity :: {-# UNPACK #-} !Velocity
44 , bodyAcceleration :: {-# UNPACK #-} !Acceleration
45 }
46
47
48instance 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'.
55rigidBody :: Mass -> Position -> RigidBody2
56rigidBody mass position = RigidBody2 mass position zero2 zero2
57
58
59-- | Set the body's velocity.
60setVelocity :: Velocity -> RigidBody2 -> RigidBody2
61setVelocity velocity body = body { bodyVelocity = velocity }
62
63
64-- | Set the body's acceleration.
65setAcceleration :: Acceleration -> RigidBody2 -> RigidBody2
66setAcceleration acceleration body = body { bodyAcceleration = acceleration }
67
68
69-- | Update the given 'RigidBody'.
70update :: [Force] -> Dt -> RigidBody2 -> RigidBody2
71update 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'
generated by cgit v1.2.3 (git 2.25.1) at 2025-11-03 12:21:23 +0000