make better collision reaction

This commit is contained in:
nek0 2021-01-17 02:30:45 +01:00
parent 03c406fd3e
commit a99a70eb9d
5 changed files with 146 additions and 63 deletions

View File

@ -7,6 +7,11 @@ import Linear
import Classes.Physics.Mass import Classes.Physics.Mass
data CollisionResult a
= NoCollision
| Collision a
deriving (Show, Eq)
-- | Typeclass for implementing collision results on objects. -- | Typeclass for implementing collision results on objects.
class (Show c, Mass c) => Collidible c where class (Show c, Mass c) => Collidible c where
@ -24,7 +29,7 @@ class (Show c, Mass c) => Collidible c where
=> Double -- ^ Time step length => Double -- ^ Time step length
-> c -- ^ First object -> c -- ^ First object
-> other -- ^ second object -> other -- ^ second object
-> Bool -- ^ Do the objects collide? -> CollisionResult Double -- ^ Do the objects collide?
collisionCheck dt m1 m2 = collisionCheck dt m1 m2 =
let d1@(V2 d1x d1y) = (dt *) <$> velocity m1 let d1@(V2 d1x d1y) = (dt *) <$> velocity m1
d2@(V2 d2x d2y) = (dt *) <$> velocity m2 d2@(V2 d2x d2y) = (dt *) <$> velocity m2
@ -56,33 +61,48 @@ class (Show c, Mass c) => Collidible c where
(d1x * (mtpy - mqpy) - (mtpx - mqpx) * d1y) / (d1x * (mtpy - mqpy) - (mtpx - mqpx) * d1y) /
(d1x * (-(mtpy - mspy)) - (-(mtpx - mspx)) * d1y) (d1x * (-(mtpy - mspy)) - (-(mtpx - mspx)) * d1y)
inside m = inside m =
let am = m - (p2 + m2p1) let dm = m - (p2 + m2p4)
ab = (p2 + m2p2) - (p2 + m2p1) dc = (p2 + m2p3) - (p2 + m2p4)
ad = (p2 + m2p4) - (p2 + m2p1) da = (p2 + m2p1) - (p2 + m2p4)
in in
(0 < am `dot` ab && am `dot` ab < ab `dot` ab) && (0 < dm `dot` dc && dm `dot` dc < dc `dot` dc) &&
(0 < am `dot` ad && am `dot` ad < ad `dot` ad) (0 < dm `dot` da && dm `dot` da < da `dot` da)
in in
any inside quad1 || if any inside quad1
any then Collision 0
(\gx -> else
any let res = foldl
(\q -> (\acc1 gx ->
let qs = s q gx let gt = foldl
qt = t q gx (\acc2 q ->
in let qt = t q gx
(qs > 0 && qs < 1) && (qt > 0 && qt < dt) qs = s q gx
) in
quad1 if (qs > 0 && qs < 1) && (qt > 0 && qt < acc2)
) then qt
gs else acc2
)
acc1
quad1
in
if gt < acc1
then gt
else acc1
)
dt
gs
in
if res < dt
then Collision res
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 -- ^ Collision partner -> other -- ^ Collision partner
-> c -- ^ Updated original object -> CollisionResult Double -- ^ Collision reaction
-> c -- ^ Updated original object
collide = elasticCollision 1 collide = elasticCollision 1
-- | Implementation of a dampened elastic collision used as default collision -- | Implementation of a dampened elastic collision used as default collision
@ -92,9 +112,11 @@ elasticCollision
=> Double => Double
-> c1 -> c1
-> c2 -> c2
-> CollisionResult Double
-> c1 -> c1
elasticCollision damping mo1 mo2 = elasticCollision _ mo1 _ NoCollision = mo1
let (V2 v1x v1y) = velocity mo1 elasticCollision damping mo1 mo2 (Collision ddt) =
let v1@(V2 v1x v1y) = velocity mo1
(V2 v2x v2y) = velocity mo2 (V2 v2x v2y) = velocity mo2
p1@(V2 p1x p1y) = position mo1 p1@(V2 p1x p1y) = position mo1
p2 = position mo2 p2 = position mo2
@ -114,5 +136,53 @@ elasticCollision damping mo1 mo2 =
then (V2 (-v1x) v1y) then (V2 (-v1x) v1y)
else (V2 v1x (-v1y)) else (V2 v1x (-v1y))
else (V2 v1x' v1y') else (V2 v1x' v1y')
bx = if dx <= 0
then
if abs dx >= abs m1x1 + abs m2x2 &&
(if dy > 0
then abs dy >= abs m1y2 + abs m2y1
else abs dy >= abs m1y1 + abs m2y2
)
then 0
else (abs m1x1 + abs m2x2) - abs dx + 1
else
if abs dx >= abs m1x2 + abs m2x1 &&
(if dy > 0
then abs dy >= abs m1y2 + abs m2y1
else abs dy >= abs m1y1 + abs m2y2
)
then 0
else -((abs m1x2 + abs m2x1) - abs dx + 1)
by = if dy <= 0
then
if abs dy >= abs m1y1 + abs m2y2 &&
(if dx > 0
then abs dx >= abs m1x2 + abs m2x1
else abs dx >= abs m1x1 + abs m2x2
)
then 0
else (abs m1y1 + abs m2y2) - abs dy + 1
else
if abs dy >= abs m1y2 + abs m2y1 &&
(if dx > 0
then abs dx >= abs m1x2 + abs m2x1
else abs dx >= abs m1x1 + abs m2x2
)
then 0
else -((abs m1y2 + abs m2y1) - abs dy + 1)
in in
(velocityUpdater mo1) nvel (velocityUpdater
((positionUpdater mo1)
(p1 +
if ddt == 0
then
if abs by > abs bx
then
V2 bx 0
else
V2 0 by
else
V2 0 0
)
)
) nvel

View File

@ -57,8 +57,8 @@ class Mass m where
-> m -- ^ Original mass object -> m -- ^ Original mass object
-> m -- ^ Updated mass object -> m -- ^ Updated mass object
move dt m = move dt m =
let dpos = ((dt *) <$> velocity m) let dpos@(V2 dx dy) = (dt *) <$> velocity m
in in
if quadrance dpos > 0.5 if dy < 0 && abs dy < 1
then (positionUpdater m) (position m + dpos) then (positionUpdater m) (position m + (V2 dx 0))
else m else (positionUpdater m) (position m + dpos)

View File

@ -87,6 +87,7 @@ load level progress = do
(V2 0 1) (V2 0 1)
(V2 0 0) (V2 0 0)
(V2 0 0) (V2 0 0)
(V2 0 0)
100 100
tex tex
False False

View File

@ -35,18 +35,13 @@ update level dt = liftIO $ do
cast cast
collidedCast = collidedCast =
(\(Cast c1) (Cast c2) -> (\(Cast c1) (Cast c2) ->
Cast $ Cast $ collide c1 c2 (collisionCheck dt c1 c2)
if collisionCheck dt c1 c2
then collide c1 c2
else c1
) )
<$> playedCast <*> playedCast <$> playedCast <*> playedCast
wallCast (Cast c) = Cast $ wallCast (Cast c) = Cast $
V.foldl V.foldl
(\member tile -> (\member tile ->
if collisionCheck dt member tile collide member tile (collisionCheck dt member tile)
then collide member tile
else member
) )
c c
layer layer
@ -65,19 +60,15 @@ update level dt = liftIO $ do
collidedCat = collidedCat =
V.foldl V.foldl
(\cat (Cast c) -> (\cat (Cast c) ->
if collisionCheck dt cat c collide cat c (collisionCheck dt cat c)
then collide cat c
else cat
) )
playedCat playedCat
updatedCast updatedCast
walledCat = walledCat =
V.foldl V.foldl
(\cat tile -> (\cat tile ->
if collisionCheck dt cat tile collide cat tile (collisionCheck dt cat tile)
then collide cat tile
else cat
) )
collidedCat collidedCat
layer layer
in Just $ walledCat in Just $ move dt walledCat

View File

@ -24,12 +24,13 @@ import Types.Texture
import Types.Subsystems import Types.Subsystems
catMoveVelocity :: Double catMoveVelocity :: Double
catMoveVelocity = 10 catMoveVelocity = 100
data Pituicat = Pituicat data Pituicat = Pituicat
{ pcPos :: V2 Double { pcPos :: V2 Double
, pcVel :: V2 Double , pcVel :: V2 Double
, pcMoveVel :: V2 Double , pcMoveVel :: V2 Double
, pcTMoveVel :: V2 Double
, pcAcc :: V2 Double , pcAcc :: V2 Double
, pcHealth :: Int , pcHealth :: Int
, pcTexture :: Texture , pcTexture :: Texture
@ -40,7 +41,7 @@ data Pituicat = Pituicat
instance Drawable Pituicat where instance Drawable Pituicat where
toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _) = toVertices (Pituicat (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
@ -75,20 +76,25 @@ instance Prop Pituicat where
instance Actor Pituicat where instance Actor Pituicat where
perform dt p = perform dt p =
let physCat = (move dt . accelerate dt . gravitate constG) let physCat = (accelerate dt . gravitate constG)
(p {pcAcc = 0}) (p
(V2 vx vy) = pcVel physCat { pcAcc = 0
, pcTMoveVel =
case pcMoveState physCat of
Just MoveRight -> V2 catMoveVelocity 0
Just MoveLeft -> V2 (-catMoveVelocity) 0
_ -> V2 0 0
}
)
finalCat = physCat finalCat = physCat
{ pcGrounded = (vy <= 0 && abs vy < 30 ) { pcMoveVel =
, pcMoveVel = case pcMoveState physCat of -- lerp (min 0.9 (59 * dt)) (pcMoveVel physCat) (pcTMoveVel physCat)
Just MoveRight -> V2 catMoveVelocity 0 pcTMoveVel physCat
Just MoveLeft -> V2 (-catMoveVelocity) 0
_ -> V2 0 0
} }
in in
(A.log Debug ( (A.log Debug (
("being at " <> fromString (show $ pcPos finalCat)) <> ("being at " <> fromString (show $ position finalCat)) <>
("; moving with " <> fromString (show $ pcVel finalCat)) ("; moving with " <> fromString (show $ velocity finalCat))
) )
) finalCat ) finalCat
@ -107,9 +113,20 @@ instance Mass Pituicat where
velocity cat = pcVel cat + pcMoveVel cat velocity cat = pcVel cat + pcMoveVel cat
velocityUpdater cat = velocityUpdater cat =
(\vel -> cat (\vel@(V2 vx vy) ->
{ pcVel = vel let (V2 mx my) = pcMoveVel cat
} nx =
if abs mx > abs vx
then 0
else vx - mx
ny =
if abs my > abs vy
then 0
else vy - my
in
cat
{ pcVel = (V2 nx ny)
}
) )
position = pcPos position = pcPos
@ -127,13 +144,17 @@ instance Collidible Pituicat where
, V2 25 25 , V2 25 25
) )
collide cat other = collide cat _ NoCollision = cat
collide cat other collr@(Collision ddt) =
A.log A.log
Debug Debug
("*boing* meow! other: " <> ("*boing* meow! other: " <>
fromString (show other)) fromString (show other))
(let ncat = (elasticCollision 0.3 cat other) (
(V2 _ dy) = pcVel ncat let ncat = (elasticCollision 0.3 cat other collr)
in (V2 dx dy) = (ddt *) <$> velocity ncat
ncat in
ncat
{ pcGrounded = abs dy < 2
}
) )