reworked physics

This commit is contained in:
nek0 2021-09-05 10:46:33 +02:00
parent c574671244
commit 9f47b192a5
8 changed files with 177 additions and 259 deletions

View File

@ -6,20 +6,16 @@ import Affection as A
import Linear import Linear
import Data.String (fromString)
import Data.List (sortBy)
-- internal imports -- internal imports
import Physics.Classes.Mass import Physics.Classes.Mass
data CollisionResult time direction data CollisionResult direction
= NoCollision = NoCollision
| CollisionImminent -- | CollisionImminent
{ collisionTime :: time -- { collisionTime :: time
, collisionDirection :: direction -- , collisionDirection :: direction
} -- }
| OverlapCollision | OverlapCollision
{ collisionDepth :: direction { collisionDepth :: direction
} }
@ -52,6 +48,9 @@ class (Show c, Mass c) => Collidible c where
-- | Flag indicating a collision during the current time step -- | Flag indicating a collision during the current time step
collisionOccured :: c -> Bool collisionOccured :: c -> Bool
-- | Update the collision occurence flag
updateCollisionOccurence :: c -> (Bool -> c)
-- | returns the bottom left and top right corners relative to the objects -- | returns the bottom left and top right corners relative to the objects
-- positional vector of the axis aligned bounding box (AABB) serving here -- positional vector of the axis aligned bounding box (AABB) serving here
-- as collision boundaries. -- as collision boundaries.
@ -65,72 +64,73 @@ class (Show c, Mass c) => Collidible c where
:: (Collidible other) :: (Collidible other)
=> c -- ^ First object => c -- ^ First object
-> other -- ^ second object -> other -- ^ second object
-> CollisionResult Double (V2 Int) -- ^ Do the objects collide? -> CollisionResult (V2 Double) -- ^ Do the objects collide?
collisionCheck m1 m2 = collisionCheck m1 m2 =
let p1@(V2 p1x p1y) = position m1 let (V2 p1x p1y) = position m1
p2@(V2 p2x p2y) = position m2 (V2 p2x p2y) = position m2
v1@(V2 v1x v1y) = velocity m1 (V2 b1minx b1miny, V2 b1maxx b1maxy) = boundary m1
v2@(V2 v2x v2y) = velocity m2 (V2 b2minx b2miny, V2 b2maxx b2maxy) = boundary m2
(V2 dvx dvy) = v1 - v2 getCoordinates
(V2 dx dy) = p1 - p2 | p1x <= p2x && p1y <= p2y =
let x1 = p1x + b1maxx
y1 = p1y + b1maxy
x2 = p2x + b2minx
y2 = p2y + b2minx
in (x1, y1, x2, y2)
| p1x > p2x && p1y <= p2y =
let x1 = p1x + b1minx
y1 = p1y + b1maxy
x2 = p2x + b2maxx
y2 = p2y + b2miny
in (x1, y1, x2, y2)
| p1x <= p2x && p1y > p2y =
let x1 = p1x + b1maxx
y1 = p1y + b1miny
x2 = p2x + b2minx
y2 = p2y + b2maxy
in (x1, y1, x2, y2)
| otherwise =
let x1 = p1x + b1minx
y1 = p1y + b1miny
x2 = p2x + b2maxx
y2 = p2y + b2maxy
in (x1, y1, x2, y2)
(ox1, oy1, ox2, oy2) = getCoordinates
in in
error "collisionCheck: Not yet implemented!" if ox2 - ox1 < 0 || oy2 - oy1 < 0
then OverlapCollision
(V2
(min 0 (ox2 - ox1) * (- 1))
(min 0 (oy2 - oy1) * (- 1))
)
else
NoCollision
-- | This Function is called for every collision on both colliding objects. -- | This Function is called for every collision on both colliding objects.
collide collide
:: (Collidible other) :: (Collidible other)
=> c -- ^ Original object => c -- ^ Original object
-> [(other, CollisionResult Double (V2 Int))] -- ^ Collision partners and results -> [(other, CollisionResult (V2 Double))] -- ^ Collision partners and results
-> Double -- ^ Timestep length -> Double -- ^ Timestep length
-> c -- ^ Updated original object -> c -- ^ Updated original object
collide coll1 collrs = elasticCollision 0.9 coll1 (head collrs) collide coll1 collrs dt =
foldl (\acc a -> elasticCollision 0.9 acc a dt) coll1 collrs
-- | Implementation of a dampened elastic collision used as default collision -- | Implementation of a dampened elastic collision used as default collision
-- implementation of the collision reaction -- implementation of the collision reaction
elasticCollision elasticCollision
:: (Collidible c1, Collidible c2) :: (Collidible c1, Collidible c2)
=> Double => Double -- ^ Restitution coefficient
-> c1 -> c1 -- ^ First collision partner
-> (c2, CollisionResult Double (V2 Int)) -> (c2, CollisionResult (V2 Double)) -- ^ Second collision partner with collision result
-> Double -- ^ Timestep length -> Double -- ^ Timestep length
-> c1 -> c1 -- ^ Updated first collision partner
elasticCollision _ mo1 (_, NoCollision) _ = mo1 elasticCollision _ mo1 (_, NoCollision) _ = mo1
elasticCollision damping mo1 (mo2, CollisionImminent ddt (V2 dirx diry)) dt = elasticCollision restitution mo1 (mo2, OverlapCollision depth) dt =
let v1@(V2 v1x v1y) = velocity mo1 let dvel = (velocity mo1 - velocity mo2) * normalize depth
(V2 v2x v2y) = velocity mo2 j = (restitution + 1) * (- (dvel `dot` dvel)) /
p1 = position mo1 (1 / mass mo1 + 1 / mass mo2)
m1 = mass mo1 fi = (* (j / dt)) <$> normalize depth
m2 = mass mo2
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
nvel = if m1 == recip 0
then V2 0 0
else (damping *) <$>
if m2 == recip 0
then
if dirx /= 0
then V2 (-v1x) v1y
else V2 v1x (-v1y)
else V2 v1x' v1y'
in in
velocityUpdater positionUpdater (addImpactForce (updateCollisionOccurence mo1 True) fi)
mo1 (position mo1 - depth)
nvel
elasticCollision damping mo1 (mo2, OverlapCollision depth) dt =
let m1 = mass mo1
m2 = mass mo2
(V2 dx dy) = (/ dt) . fromIntegral <$> depth
v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx
v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
nvel = if m1 == recip 0
then V2 0 0
else (damping *) <$>
if m2 == recip 0
then
if dx /= 0
then V2 (-v1x') v1y'
else V2 v1x' (-v1y')
else
V2 v1x' v1y'
in
velocityUpdater mo1 nvel

View File

@ -52,4 +52,11 @@ class Mass m where
dpos = (* dt) <$> nvel dpos = (* dt) <$> nvel
npos = position m + dpos npos = position m + dpos
in in
positionUpdater (velocityUpdater m nvel) npos resetForces $ positionUpdater (velocityUpdater m nvel) npos
calculateLoads
:: m -- ^ Original mass object
-> V2 Double -- ^ Gravitational force vector
-> m -- ^ Updated mass object
calculateLoads =
addLoads

View File

@ -21,6 +21,7 @@ import Scenes.Test.Types
import Classes import Classes
import Types import Types
import Physics import Physics
import Util
update update
:: Test :: Test
@ -58,7 +59,7 @@ update level dt = liftIO $ do
let res = collisionCheck dt tangible1 tangible2 let res = collisionCheck dt tangible1 tangible2
in in
case res of case res of
c@(CollisionImminent _ _) -> c@(OverlapCollision _) ->
if qInd /= index if qInd /= index
then jacc `V.snoc` (qInd, c) then jacc `V.snoc` (qInd, c)
else jacc else jacc
@ -71,7 +72,9 @@ update level dt = liftIO $ do
then iacc then iacc
else iacc `V.snoc` else iacc `V.snoc`
( index ( index
, sortOn (collisionTime . snd) (V.toList partners) , sortOn
((\v -> collisionDepth v `dot` collisionDepth v) . snd)
(V.toList partners)
) )
) )
V.empty V.empty
@ -93,7 +96,10 @@ update level dt = liftIO $ do
d d
dt dt
in in
inter resetImpactForces $ resetCollisionOccurence $
if collisionOccured inter
then addLoads inter (impactForces inter)
else addLoads inter constG
) )
digest digest
in in
@ -112,11 +118,11 @@ update level dt = liftIO $ do
(\acc@(castAcc, pAcc, _) input -> (\acc@(castAcc, pAcc, _) input ->
case input of case input of
TCast c -> TCast c ->
(castAcc `V.snoc` move dt c, pAcc, mnewCat) (castAcc `V.snoc` updateByEuler c dt, pAcc, mnewCat)
TPowerUp p -> TPowerUp p ->
(castAcc, pAcc `V.snoc` move dt p, mnewCat) (castAcc, pAcc `V.snoc` updateByEuler p dt, mnewCat)
TPlayer ncat -> TPlayer ncat ->
(castAcc, pAcc, Just (move dt ncat)) (castAcc, pAcc, Just (updateByEuler ncat dt))
TTile _ -> TTile _ ->
acc acc
) )
@ -125,144 +131,3 @@ update level dt = liftIO $ do
writeTVar (testCast level) newCast writeTVar (testCast level) newCast
writeTVar (testPowerups level) newPowerups writeTVar (testPowerups level) newPowerups
writeTVar (testPlayer level) mnewCat writeTVar (testPlayer level) mnewCat
-- oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$>
-- readTVar (testCast level)
-- oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level)
-- modifyTVar (testCast level) $ \cast ->
-- let playedCast =
-- V.map
-- (\(Cast c) -> Cast (perform dt c))
-- cast
-- collidedCast =
-- V.map
-- (\(Cast c1) ->
-- let partners = V.foldl
-- (\acc@(Cast _, ires) (Cast c2) ->
-- let res = collisionCheck dt c1 c2
-- in
-- if res /= NoCollision &&
-- collisionTime res < collisionTime ires
-- then (Cast c2, res)
-- else acc
-- )
-- (Cast c1, NoCollision)
-- playedCast
-- in
-- if null partners
-- then Cast c1
-- else
-- uncurry
-- (\(Cast c2) result -> Cast $ collide c1 c2 result)
-- partners
-- )
-- playedCast
-- wallCast (Cast c) =
-- Cast $ performWorldCollision c layer dt
-- walledCast =
-- V.map wallCast collidedCast
-- cattedCast = V.map
-- (\(Cast c) ->
-- Cast $ collide c oldCat $ collisionCheck dt c oldCat
-- )
-- walledCast
-- in
-- V.map
-- (\(Cast c) -> Cast $
-- move dt c
-- )
-- walledCast
-- releasedEffects <- stateTVar (testPowerups level) $ \pus ->
-- let living = V.foldl
-- (\acc pu ->
-- let npu = perform dt pu
-- in
-- if puTTL npu > 0
-- then npu `V.cons` acc
-- else acc
-- )
-- V.empty
-- pus
-- indexCollected = V.filter ((/= NoCollision) . snd) $
-- V.zip (V.fromList [0..length living])
-- (V.map
-- (collisionCheck dt oldCat)
-- living
-- )
-- collected = V.foldl
-- (\acc (ind, _) ->
-- (living V.! ind) `V.cons` acc
-- )
-- V.empty
-- indexCollected
-- differ = V.foldl
-- (\acc life -> if life `V.elem` collected
-- then acc
-- else life `V.cons` acc
-- )
-- V.empty
-- living
-- fin = V.map
-- (\pu -> move dt $ performWorldCollision pu layer dt)
-- differ
-- in
-- (collected, fin)
-- modifyTVar
-- (testPlayer level) $ \(Just pituicat) ->
-- let playedCat = perform dt pituicat
-- castCat =
-- let allPartners = V.zip (V.fromList [0..V.length oldCast])
-- (V.map
-- (\(Cast c) -> collisionCheck dt playedCat c)
-- oldCast
-- )
-- filtered = (V.filter ((/= NoCollision) . snd) allPartners)
-- partner = V.minimumBy
-- (\(_, e) (_, f) -> collisionTime e `compare` collisionTime f)
-- filtered
-- in
-- if V.null filtered
-- then
-- playedCat
-- else
-- uncurry
-- (\(Cast c) cr -> collide playedCat c cr)
-- (oldCast V.! fst partner, snd partner)
-- walledCat = performWorldCollision castCat layer dt
-- affectedCat = walledCat
-- { pcEffects = pcEffects walledCat ++
-- map puEffect (V.toList releasedEffects)
-- }
-- in Just $ move dt affectedCat
-- performWorldCollision
-- :: (Collidible c)
-- => c -- ^ Cast member to check
-- -> Layer -- ^ The walk layer of the level
-- -> Double -- ^ Tick length
-- -> c -- ^ Updated cast member
-- performWorldCollision c layer dt =
-- let partner = V.foldl
-- (\acc@(part, cr) tile ->
-- let res = collisionCheck dt c tile
-- ret = if cr == NoCollision && res == NoCollision
-- then
-- acc
-- else
-- if cr == NoCollision && res /= NoCollision
-- then (tile, res)
-- else
-- if cr /= NoCollision && res == NoCollision
-- then
-- acc
-- else
-- if collisionTime cr < collisionTime res
-- then acc
-- else (tile, res)
-- in
-- ret
-- )
-- (V.head layer, collisionCheck dt c $ V.head layer)
-- layer
-- in
-- (uncurry (collide c) partner) dt

View File

@ -16,22 +16,32 @@ instance Mass Cast where
mass (Cast a) = mass a mass (Cast a) = mass a
acceleration (Cast a) = acceleration a
accelerationUpdater (Cast a) = Cast . accelerationUpdater a
velocity (Cast a) = velocity a velocity (Cast a) = velocity a
velocityUpdater (Cast a) = Cast . velocityUpdater a velocityUpdater (Cast a) = Cast . velocityUpdater a
forces (Cast a) = forces a
forcesUpdater (Cast a) = Cast . forcesUpdater a
position (Cast a) = position a position (Cast a) = position a
positionUpdater (Cast a) = Cast . positionUpdater a positionUpdater (Cast a) = Cast . positionUpdater a
instance Collidible Cast where instance Collidible Cast where
prevPosition (Cast c) = prevPosition c
impactForces (Cast c) = impactForces c
impactForcesUpdater (Cast c) = Cast . impactForcesUpdater c
collisionOccured (Cast c) = collisionOccured c
updateCollisionOccurence (Cast c) = Cast . updateCollisionOccurence c
boundary (Cast c) = boundary c boundary (Cast c) = boundary c
collisionCheck dt (Cast c1) c2 = collisionCheck dt c1 c2 collisionCheck (Cast c1) c2 = collisionCheck c1 c2
collide (Cast c1) res dt = Cast $ collide c1 res dt collide (Cast c1) res dt = Cast $ collide c1 res dt

View File

@ -41,6 +41,7 @@ data Tile = Tile
{ tilePosition :: V2 Word -- ^ { tilePosition :: V2 Word -- ^
, tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap' , tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap'
, tileType :: TileType -- ^ Type of tile , tileType :: TileType -- ^ Type of tile
, tileCollided :: Bool
} }
deriving (Eq, Show) deriving (Eq, Show)
@ -48,7 +49,7 @@ instance Drawable Tile where
-- type VertexList Tile = V.Vector -- type VertexList Tile = V.Vector
toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _) = toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _ _) =
( V.fromList [ 0, 1, 2, 2, 3, 0 ] ( V.fromList [ 0, 1, 2, 2, 3, 0 ]
, V.fromList , V.fromList
[ newVertex [ newVertex
@ -76,12 +77,12 @@ instance Drawable Tile where
instance Mass Tile where instance Mass Tile where
forces _ = V2 0 0
forcesUpdater t _ = t
mass _ = recip 0 mass _ = recip 0
acceleration _ = V2 0 0
accelerationUpdater t = const t
velocity _ = V2 0 0 velocity _ = V2 0 0
velocityUpdater t = const t velocityUpdater t = const t
@ -95,6 +96,18 @@ instance Mass Tile where
instance Collidible Tile where instance Collidible Tile where
prevPosition t = position t
impactForces _ = V2 0 0
impactForcesUpdater t _ = t
collisionOccured t = tileCollided t
updateCollisionOccurence t coll = t
{ tileCollided = coll
}
boundary _ = boundary _ =
( V2 (-16) (-16) ( V2 (-16) (-16)
, V2 16 16 , V2 16 16

View File

@ -31,7 +31,10 @@ catMoveVelocity = 100
data Pituicat = Pituicat data Pituicat = Pituicat
{ pcPos :: V2 Double { pcPos :: V2 Double
, pcPrevPos :: V2 Double
, pcVel :: V2 Double , pcVel :: V2 Double
, pcForces :: V2 Double
, pcImpactForces :: V2 Double
, pcMoveVel :: V2 Double , pcMoveVel :: V2 Double
, pcTMoveVel :: V2 Double , pcTMoveVel :: V2 Double
, pcAcc :: V2 Double , pcAcc :: V2 Double
@ -42,6 +45,7 @@ data Pituicat = Pituicat
, pcViewDirection :: ViewDirection , pcViewDirection :: ViewDirection
, pcEffects :: [EffectHolder] , pcEffects :: [EffectHolder]
, pcXColl :: Bool , pcXColl :: Bool
, pcCollisionOcc :: Bool
} }
deriving (Eq, Show) deriving (Eq, Show)
@ -50,7 +54,7 @@ data ViewDirection = ViewLeft | ViewRight
instance Drawable Pituicat where instance Drawable Pituicat where
toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ vd _ _) = toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ _ _ _ vd _ _ _) =
( V.fromList [0, 1, 2, 2, 3, 0] ( V.fromList [0, 1, 2, 2, 3, 0]
, V.fromList , V.fromList
[ newVertex [ newVertex
@ -103,7 +107,7 @@ instance Actor Pituicat where
not (any ((SpeedUp ==) . effectReleased) (pcEffects p)) not (any ((SpeedUp ==) . effectReleased) (pcEffects p))
then 1 then 1
else 2 else 2
physCat = (accelerate dt . gravitate constG) physCat =
(p (p
{ pcAcc = V2 0 0 { pcAcc = V2 0 0
, pcTMoveVel = , pcTMoveVel =
@ -149,13 +153,6 @@ instance Mass Pituicat where
mass _ = 100 mass _ = 100
acceleration = pcAcc
accelerationUpdater cat =
\accel -> cat
{ pcAcc = accel
}
velocity = velocity =
pcVel pcVel
@ -164,6 +161,12 @@ instance Mass Pituicat where
{ pcVel = vel { pcVel = vel
} }
forces = pcForces
forcesUpdater c force = c
{ pcForces = force
}
position = pcPos position = pcPos
positionUpdater cat = positionUpdater cat =
@ -171,15 +174,22 @@ instance Mass Pituicat where
{ pcPos = pos { pcPos = pos
} }
move dt cat =
let dpos = (dt *) <$> velocity cat
mpos = (dt *) <$>
(if pcXColl cat then V2 (-1) 1 else V2 1 1) * pcMoveVel cat
in
positionUpdater cat (position cat + dpos + mpos)
instance Collidible Pituicat where instance Collidible Pituicat where
impactForces = pcImpactForces
impactForcesUpdater c force = c
{ pcImpactForces = force
}
collisionOccured = pcCollisionOcc
updateCollisionOccurence c coll = c
{ pcCollisionOcc = coll
}
prevPosition = pcPrevPos
boundary cat = boundary cat =
if pcViewDirection cat == ViewRight if pcViewDirection cat == ViewRight
then then
@ -196,12 +206,12 @@ instance Collidible Pituicat where
} }
collide cat collrs@((_, NoCollision):_) _ = cat collide cat collrs@((_, NoCollision):_) _ = cat
{ pcXColl = any { pcXColl = any
(\(_, CollisionImminent _ (V2 cx _)) -> cx /= 0) (\(_, OverlapCollision (V2 cx _)) -> cx /= 0)
(filter ((NoCollision /= ) . snd) collrs) (filter ((NoCollision /= ) . snd) collrs)
} }
collide cat collrs@(collr@(_, OverlapCollision direction):_) dt = collide cat collrs@(collr@(_, OverlapCollision direction):_) dt =
elasticCollision 0.3 cat collr dt elasticCollision 0.3 cat collr dt
collide cat collrs@(collr@(other, CollisionImminent ddt (V2 dirx diry)):_) dt = collide cat collrs@(collr@(other, OverlapCollision (V2 dirx diry)):_) dt =
let ncat = elasticCollision 0.3 cat collr dt let ncat = elasticCollision 0.3 cat collr dt
vel@(V2 vx vy) = velocity ncat vel@(V2 vx vy) = velocity ncat
moveVel@(V2 mx my) = pcMoveVel cat moveVel@(V2 mx my) = pcMoveVel cat

View File

@ -17,21 +17,23 @@ import Graphics.Types.Texture
import Graphics.Classes.Drawable import Graphics.Classes.Drawable
import Graphics.Classes.Bindable import Graphics.Classes.Bindable
import Util
data PowerUp = PowerUp data PowerUp = PowerUp
{ puPos :: V2 Double { puPos :: V2 Double
, puVel :: V2 Double , puPrevPos :: V2 Double
, puAcc :: V2 Double , puVel :: V2 Double
, puTTL :: Double , puAcc :: V2 Double
, puTexture :: Texture , puTTL :: Double
, puEffect :: EffectHolder , puTexture :: Texture
, puEffect :: EffectHolder
, puForces :: V2 Double
, puImpactForces :: V2 Double
, puCollided :: Bool
} }
deriving (Eq, Show) deriving (Eq, Show)
instance Drawable PowerUp where instance Drawable PowerUp where
toVertices (PowerUp (V2 x y) _ _ _ _ _) = toVertices (PowerUp (V2 x y) _ _ _ _ _ _ _ _ _) =
( V.fromList [0, 1, 2, 2, 3, 0] ( V.fromList [0, 1, 2, 2, 3, 0]
, V.fromList , V.fromList
[ newVertex [ newVertex
@ -66,7 +68,7 @@ instance Prop PowerUp where
instance Actor PowerUp where instance Actor PowerUp where
perform dt o = perform dt o =
let phys = (accelerate dt . gravitate constG) let phys =
o o
{ puAcc = V2 0 0 { puAcc = V2 0 0
, puTTL = puTTL o - dt , puTTL = puTTL o - dt
@ -78,12 +80,11 @@ instance Mass PowerUp where
mass _ = 0.1 mass _ = 0.1
acceleration = puAcc forces = puForces
accelerationUpdater o = forcesUpdater p force = p
\acc -> o { puForces = force
{ puAcc = acc }
}
velocity = puVel velocity = puVel
@ -101,6 +102,20 @@ instance Mass PowerUp where
instance Collidible PowerUp where instance Collidible PowerUp where
prevPosition = puPrevPos
impactForces = puImpactForces
impactForcesUpdater p force = p
{ puImpactForces = force
}
collisionOccured = puCollided
updateCollisionOccurence p coll = p
{ puCollided = coll
}
boundary _ = boundary _ =
( V2 (-20) (-20) ( V2 (-20) (-20)
, V2 20 20 , V2 20 20

View File

@ -3,20 +3,18 @@ module Util where
import Affection import Affection
import qualified SDL import qualified SDL
import qualified SDL.Internal.Numbered as SDL
import Linear import Linear
-- internal imports -- internal imports
import Types.Application import Types.Application
import Types.Subsystems
globalKeyHandle globalKeyHandle
:: GameData :: GameData
-> KeyboardMessage -> KeyboardMessage
-> Affection () -> Affection ()
globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) = globalKeyHandle _ mesg@MsgKeyboardEvent {} =
case mesg of case mesg of
MsgKeyboardEvent MsgKeyboardEvent
_ _