From 92e7a93d8c1475bdc802d10a1722bcf8a295449d Mon Sep 17 00:00:00 2001
From: 3gg <3gg@shellblade.net>
Date: Tue, 24 Dec 2024 12:07:05 -0800
Subject: New physics module.
---
Demos/Pong/Pong.hs | 101 +++++++++++++++++++++--------------
Spear.cabal | 2 +
Spear/Math/Physics/Rigid.hs | 125 --------------------------------------------
Spear/Math/Physics/Types.hs | 11 ----
Spear/Physics/Collision.hs | 63 ++++++++++++++++++++++
Spear/Physics/RigidBody.hs | 77 +++++++++++++++++++++++++++
6 files changed, 203 insertions(+), 176 deletions(-)
delete mode 100644 Spear/Math/Physics/Rigid.hs
delete mode 100644 Spear/Math/Physics/Types.hs
create mode 100644 Spear/Physics/Collision.hs
create mode 100644 Spear/Physics/RigidBody.hs
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
import Spear.Math.Spatial
import Spear.Math.Spatial2
import Spear.Math.Vector
+import Spear.Physics.Collision
import Spear.Prelude
import Spear.Step
-import Data.Monoid (mconcat)
+import Data.Monoid (mconcat)
-- Configuration
@@ -41,14 +42,22 @@ initialBallPos = vec2 0.5 0.5
data GameEvent
= MoveLeft
| MoveRight
- deriving (Eq, Ord, Show)
+ | Collision GameObjectId GameObjectId
+ deriving (Eq, Show)
-- Game objects
+data GameObjectId
+ = Ball
+ | Enemy
+ | Player
+ deriving (Eq, Show)
+
data GameObject = GameObject
- { aabb :: AABB2,
- basis :: Transform2,
- gostep :: Step [GameObject] [GameEvent] GameObject GameObject
+ { gameObjectId :: !GameObjectId
+ , aabb :: {-# UNPACK #-} !AABB2
+ , basis :: {-# UNPACK #-} !Transform2
+ , gostep :: Step [GameObject] [GameEvent] GameObject GameObject
}
@@ -78,46 +87,68 @@ instance Spatial GameObject Vector2 Angle Transform2 where
transform = basis
+instance Bounded2 GameObject where
+ boundingVolume obj = aabb2Volume $ translate (position obj) (aabb obj)
+
+
ballBox, padBox :: AABB2
ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
padBox = AABB2 (-padSize) padSize
newWorld =
- [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
- GameObject padBox (makeAt initialEnemyPos) stepEnemy,
- GameObject padBox (makeAt initialPlayerPos) stepPlayer
+ [ GameObject Ball ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
+ GameObject Enemy padBox (makeAt initialEnemyPos) stepEnemy,
+ GameObject Player padBox (makeAt initialPlayerPos) stepPlayer
]
where makeAt = newTransform2 unitx2 unity2
+-- Step the game world:
+-- 1. Simulate physics.
+-- 2. Collide objects and clip -> produce collision events.
+-- 3. Update game objects <- input collision events.
stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
-stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
+stepWorld elapsed dt events gos@[ball, enemy, player] =
+ let
+ collisions = collide [ball] [enemy, player]
+ collisionEvents = (\(x,y) -> Collision (gameObjectId x) (gameObjectId y)) <$> collisions
+ events' = events ++ collisionEvents
+ gos' = map (update elapsed dt events' gos) gos
+ in
+ gos'
update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
-update elapsed dt evts gos go =
- let (go', s') = runStep (gostep go) elapsed dt gos evts go
- in go' {gostep = s'}
+update elapsed dt events gos go =
+ let (go', s') = runStep (gostep go) elapsed dt gos events go
+ in go' { gostep = s' }
+
-- Ball steppers
-stepBall vel = collideBall vel .> moveBall
+stepBall vel = bounceBall vel .> moveBall
-collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
-collideBall vel = step $ \_ dt gos _ ball ->
+bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
+bounceBall vel = step $ \_ dt gos events ball ->
let (AABB2 pmin pmax) = translate (position ball) (aabb 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
- vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel
+ collideWithPaddles vel = foldl (paddleBounce ball events) vel (tail gos)
+ vel' = normalise
+ . collideWithPaddles
+ . flipX
+ . flipY
+ $ vel
collision = vel' /= vel
-- Apply offset when collision occurs to avoid sticky collisions.
delta = (1::Float) + if collision then (3::Float)*dt else (0::Float)
- in ((ballSpeed * delta * vel', ball), collideBall vel')
+ in ((ballSpeed * delta * vel', ball), bounceBall vel')
-paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2
-paddleBounce ball v paddle =
- if collide ball paddle
+paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2
+paddleBounce ball events vel paddle =
+ let collision = Collision Ball (gameObjectId paddle) `elem` events
+ in if collision
then
let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle)
center = (x pmin + x pmax) / (2::Float)
@@ -126,25 +157,14 @@ paddleBounce ball v paddle =
offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float))
angle = offset * maxBounceAngle
-- When it bounces off of a paddle, y vel is flipped.
- ysign = -(signum (y v))
+ ysign = -(signum (y vel))
in vec2 (sin angle) (ysign * cos angle)
- else v
-
-collide :: GameObject -> GameObject -> Bool
-collide go1 go2 =
- let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
- translate (position go1) (aabb go1)
- (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
- translate (position go2) (aabb go2)
- in not $
- xmax1 < xmin2 ||
- xmin1 > xmax2 ||
- ymax1 < ymin2 ||
- ymin1 > ymax2
+ else vel
moveBall :: Step s e (Vector2, GameObject) GameObject
moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
+
-- Enemy stepper
stepEnemy = movePad 0 .> clamp
@@ -161,17 +181,18 @@ movePad previousMomentumVector = step $ \_ dt gos _ pad ->
sign :: Float -> Float
sign x = if x >= 0 then 1 else -1
+
-- Player stepper
-stepPlayer = sfold moveGO .> clamp
+stepPlayer = sfold movePlayer .> clamp
-moveGO = mconcat
- [ swhen MoveLeft $ moveGO' (vec2 (-playerSpeed) 0)
- , swhen MoveRight $ moveGO' (vec2 playerSpeed 0)
+movePlayer = mconcat
+ [ swhen MoveLeft $ movePlayer' (vec2 (-playerSpeed) 0)
+ , swhen MoveRight $ movePlayer' (vec2 playerSpeed 0)
]
-moveGO' :: Vector2 -> Step s e GameObject GameObject
-moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir)
+movePlayer' :: Vector2 -> Step s e GameObject GameObject
+movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir)
clamp :: Step s e GameObject GameObject
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
Spear.Math.Vector.Vector2
Spear.Math.Vector.Vector3
Spear.Math.Vector.Vector4
+ Spear.Physics.Collision
+ Spear.Physics.RigidBody
Spear.Prelude
Spear.Render.AnimatedModel
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 @@
-module Spear.Math.Physics.Rigid
-(
- module Spear.Math.Physics.Types
-, RigidBody(..)
-, rigidBody
-, update
-, setVelocity
-, setAcceleration
-)
-where
-
-import qualified Spear.Math.Matrix3 as M3
-import Spear.Math.Spatial2
-import Spear.Math.Vector
-import Spear.Physics.Types
-
-import Data.List (foldl')
-import Control.Monad.State
-
-data RigidBody = RigidBody
- { mass :: {-# UNPACK #-} !Float
- , position :: {-# UNPACK #-} !Position
- , velocity :: {-# UNPACK #-} !Velocity
- , acceleration :: {-# UNPACK #-} !Acceleration
- }
-
-instance Spatial2 RigidBody where
-
- move v body = body { position = v + position body }
-
- moveFwd speed body = body { position = position body + scale speed unity2 }
-
- moveBack speed body = body { position = position body + scale (-speed) unity2 }
-
- strafeLeft speed body = body { position = position body + scale (-speed) unitx2 }
-
- strafeRight speed body = body { position = position body + scale speed unitx2 }
-
- rotate angle = id
-
- setRotation angle = id
-
- pos = position
-
- fwd _ = unity2
-
- up _ = unity2
-
- right _ = unitx2
-
- transform body = M3.transform unitx2 unity2 $ position body
-
- setTransform transf body = body { position = M3.position transf }
-
- setPos p body = body { position = p }
-
--- | Build a 'RigidBody'.
-rigidBody :: Mass -> Position -> RigidBody
-rigidBody m x = RigidBody m x zero2 zero2
-
--- | Update the given 'RigidBody'.
-update :: [Force] -> Dt -> RigidBody -> RigidBody
-update forces dt body =
- let netforce = foldl' (+) zero2 forces
- m = mass body
- r1 = position body
- v1 = velocity body
- a1 = acceleration body
- r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1
- v' = v1 + scale (0.5*dt) a1
- a2 = a1 + scale (1/m) netforce
- v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2
- in
- RigidBody m r2 v2 a2
-
--- | Set the body's velocity.
-setVelocity :: Velocity -> RigidBody -> RigidBody
-setVelocity v body = body { velocity = v }
-
--- | Set the body's acceleration.
-setAcceleration :: Acceleration -> RigidBody -> RigidBody
-setAcceleration a body = body { acceleration = a }
-
-
--- test
-{-gravity = vec2 0 (-10)
-b0 = rigidBody 50 $ vec2 0 1000
-
-
-debug :: IO ()
-debug = evalStateT debug' b0
-
-
-
-debug' :: StateT RigidBody IO ()
-debug' = do
- lift . putStrLn $ "Initial body:"
- lift . putStrLn . show' $ b0
- lift . putStrLn $ "Falling..."
- step $ update [gravity*50] 1
- step $ update [gravity*50] 1
- step $ update [gravity*50] 1
- lift . putStrLn $ "Jumping"
- step $ update [gravity*50, vec2 0 9000] 1
- lift . putStrLn $ "Falling..."
- step $ update [gravity*50] 1
- step $ update [gravity*50] 1
- step $ update [gravity*50] 1
-
-
-step :: (RigidBody -> RigidBody) -> StateT RigidBody IO ()
-step update = do
- modify update
- body <- get
- lift . putStrLn . show' $ body
-
-
-show' body =
- "mass " ++ (show $ mass body) ++
- ", position " ++ (showVec $ position body) ++
- ", velocity " ++ (showVec $ velocity body) ++
- ", acceleration " ++ (showVec $ acceleration body)
-
-
-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 @@
-module Spear.Math.Physics.Types
-where
-
-import Spear.Math.Vector
-
-type Dt = Float
-type Force = Vector2
-type Mass = Float
-type Position = Vector2
-type Velocity = Vector2
-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 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Spear.Physics.Collision
+(
+ BoundingVolume2(..)
+, Bounded2(..)
+, aabb2Volume
+, collide
+)
+where
+
+import Spear.Math.AABB
+import Spear.Math.Spatial
+import Spear.Math.Spatial2
+import Spear.Math.Vector
+import Spear.Prelude
+
+import Data.Maybe (mapMaybe)
+
+
+-- Currently supporting AABB2. Add circles later when needed.
+data BoundingVolume2
+ = AABB2Volume { box2 :: {-# UNPACK #-} !AABB2 }
+
+
+class Bounded2 a where
+ boundingVolume :: a -> BoundingVolume2
+
+
+-- | Construct a new bounding volume from a 2D axis-aligned box.
+aabb2Volume :: AABB2 -> BoundingVolume2
+aabb2Volume = AABB2Volume
+
+
+-- | Find collisions between the objects in the first list and the objects in
+-- the second list.
+collide :: Bounded2 a => [a] -> [a] -> [(a,a)]
+collide xs ys =
+ mapMaybe testCollision pairs
+ where
+ testCollision [o1, o2] = if objectsCollide o1 o2 then Just (o1, o2) else Nothing
+ pairs = sequence [xs, ys]
+
+
+-- | Test two objects for collision.
+objectsCollide :: Bounded2 a => a -> a -> Bool
+objectsCollide o1 o2 =
+ collideAABB2 (box2 . boundingVolume $ o1) (box2 . boundingVolume $ o2)
+
+
+-- | Test two 2D axis-aligned bounding boxes for collision.
+collideAABB2 :: AABB2 -> AABB2 -> Bool
+collideAABB2 box1 box2 =
+ let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = box1
+ (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = box2
+ in not $
+ xmax1 < xmin2 ||
+ xmin1 > xmax2 ||
+ ymax1 < ymin2 ||
+ 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 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Spear.Physics.RigidBody
+(
+ RigidBody2
+, rigidBody
+, setVelocity
+, setAcceleration
+, update
+)
+where
+
+import Spear.Math.Spatial
+import Spear.Math.Spatial2
+import Spear.Math.Vector
+import Spear.Prelude
+
+import Control.Monad.State
+import Data.List (foldl')
+
+
+type Dt = Float
+type Force = Vector2
+type Mass = Float
+type Position = Vector2
+type Velocity = Vector2
+type Acceleration = Vector2
+
+
+{- class RigidBody2 a where
+ bodyMass :: a -> Float
+ bodyPosition :: a -> Vector2
+ bodyVelocity :: a -> Vector2
+ bodyAcceleration :: a -> Vector2 -}
+
+
+data RigidBody2 = RigidBody2
+ { bodyMass :: {-# UNPACK #-} !Float
+ , bodyPosition :: {-# UNPACK #-} !Position
+ , bodyVelocity :: {-# UNPACK #-} !Velocity
+ , bodyAcceleration :: {-# UNPACK #-} !Acceleration
+ }
+
+
+instance Positional RigidBody2 Vector2 where
+ setPosition p body = body { bodyPosition = p }
+ position = bodyPosition
+ translate v body = body { bodyPosition = bodyPosition body + v }
+
+
+-- | Build a 'RigidBody'.
+rigidBody :: Mass -> Position -> RigidBody2
+rigidBody mass position = RigidBody2 mass position zero2 zero2
+
+
+-- | Set the body's velocity.
+setVelocity :: Velocity -> RigidBody2 -> RigidBody2
+setVelocity velocity body = body { bodyVelocity = velocity }
+
+
+-- | Set the body's acceleration.
+setAcceleration :: Acceleration -> RigidBody2 -> RigidBody2
+setAcceleration acceleration body = body { bodyAcceleration = acceleration }
+
+
+-- | Update the given 'RigidBody'.
+update :: [Force] -> Dt -> RigidBody2 -> RigidBody2
+update forces dt body@(RigidBody2 m p v a) =
+ let f = foldl' (+) zero2 forces
+ a' = a + (f / m)
+ v' = v + (a' * dt)
+ p' = p + (v' * dt)
+ in
+ RigidBody2 m p' v' a'
--
cgit v1.2.3