Browse Source

reworked physics

physics3
nek0 2 months ago
parent
commit
9f47b192a5
  1. 130
      src/Physics/Classes/Collidible.hs
  2. 9
      src/Physics/Classes/Mass.hs
  3. 159
      src/Scenes/Test/Update.hs
  4. 20
      src/Types/Cast.hs
  5. 21
      src/Types/Map.hs
  6. 46
      src/Types/Player.hs
  7. 45
      src/Types/PowerUp.hs
  8. 4
      src/Util.hs

130
src/Physics/Classes/Collidible.hs

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

9
src/Physics/Classes/Mass.hs

@ -52,4 +52,11 @@ class Mass m where
dpos = (* dt) <$> nvel
npos = position m + dpos
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

159
src/Scenes/Test/Update.hs

@ -21,6 +21,7 @@ import Scenes.Test.Types
import Classes
import Types
import Physics
import Util
update
:: Test
@ -58,7 +59,7 @@ update level dt = liftIO $ do
let res = collisionCheck dt tangible1 tangible2
in
case res of
c@(CollisionImminent _ _) ->
c@(OverlapCollision _) ->
if qInd /= index
then jacc `V.snoc` (qInd, c)
else jacc
@ -71,7 +72,9 @@ update level dt = liftIO $ do
then iacc
else iacc `V.snoc`
( index
, sortOn (collisionTime . snd) (V.toList partners)
, sortOn
((\v -> collisionDepth v `dot` collisionDepth v) . snd)
(V.toList partners)
)
)
V.empty
@ -93,7 +96,10 @@ update level dt = liftIO $ do
d
dt
in
inter
resetImpactForces $ resetCollisionOccurence $
if collisionOccured inter
then addLoads inter (impactForces inter)
else addLoads inter constG
)
digest
in
@ -112,11 +118,11 @@ update level dt = liftIO $ do
(\acc@(castAcc, pAcc, _) input ->
case input of
TCast c ->
(castAcc `V.snoc` move dt c, pAcc, mnewCat)
(castAcc `V.snoc` updateByEuler c dt, pAcc, mnewCat)
TPowerUp p ->
(castAcc, pAcc `V.snoc` move dt p, mnewCat)
(castAcc, pAcc `V.snoc` updateByEuler p dt, mnewCat)
TPlayer ncat ->
(castAcc, pAcc, Just (move dt ncat))
(castAcc, pAcc, Just (updateByEuler ncat dt))
TTile _ ->
acc
)
@ -125,144 +131,3 @@ update level dt = liftIO $ do
writeTVar (testCast level) newCast
writeTVar (testPowerups level) newPowerups
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

20
src/Types/Cast.hs

@ -16,22 +16,32 @@ instance Mass Cast where
mass (Cast a) = mass a
acceleration (Cast a) = acceleration a
accelerationUpdater (Cast a) = Cast . accelerationUpdater a
velocity (Cast a) = velocity a
velocityUpdater (Cast a) = Cast . velocityUpdater a
forces (Cast a) = forces a
forcesUpdater (Cast a) = Cast . forcesUpdater a
position (Cast a) = position a
positionUpdater (Cast a) = Cast . positionUpdater a
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
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

21
src/Types/Map.hs

@ -41,6 +41,7 @@ data Tile = Tile
{ tilePosition :: V2 Word -- ^
, tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap'
, tileType :: TileType -- ^ Type of tile
, tileCollided :: Bool
}
deriving (Eq, Show)
@ -48,7 +49,7 @@ instance Drawable Tile where
-- 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
[ newVertex
@ -76,11 +77,11 @@ instance Drawable Tile where
instance Mass Tile where
mass _ = recip 0
forces _ = V2 0 0
acceleration _ = V2 0 0
forcesUpdater t _ = t
accelerationUpdater t = const t
mass _ = recip 0
velocity _ = V2 0 0
@ -95,6 +96,18 @@ instance Mass 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 _ =
( V2 (-16) (-16)
, V2 16 16

46
src/Types/Player.hs

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

45
src/Types/PowerUp.hs

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

4
src/Util.hs

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

Loading…
Cancel
Save