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
data CollisionResult a
= NoCollision
| Collision a
deriving (Show, Eq)
-- | Typeclass for implementing collision results on objects.
class (Show c, Mass c) => Collidible c where
@ -24,7 +29,7 @@ class (Show c, Mass c) => Collidible c where
=> Double -- ^ Time step length
-> c -- ^ First object
-> other -- ^ second object
-> Bool -- ^ Do the objects collide?
-> CollisionResult Double -- ^ Do the objects collide?
collisionCheck dt m1 m2 =
let d1@(V2 d1x d1y) = (dt *) <$> velocity m1
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 - mspy)) - (-(mtpx - mspx)) * d1y)
inside m =
let am = m - (p2 + m2p1)
ab = (p2 + m2p2) - (p2 + m2p1)
ad = (p2 + m2p4) - (p2 + m2p1)
let dm = m - (p2 + m2p4)
dc = (p2 + m2p3) - (p2 + m2p4)
da = (p2 + m2p1) - (p2 + m2p4)
in
(0 < am `dot` ab && am `dot` ab < ab `dot` ab) &&
(0 < am `dot` ad && am `dot` ad < ad `dot` ad)
(0 < dm `dot` dc && dm `dot` dc < dc `dot` dc) &&
(0 < dm `dot` da && dm `dot` da < da `dot` da)
in
any inside quad1 ||
any
(\gx ->
any
(\q ->
let qs = s q gx
qt = t q gx
in
(qs > 0 && qs < 1) && (qt > 0 && qt < dt)
)
quad1
)
gs
if any inside quad1
then Collision 0
else
let res = foldl
(\acc1 gx ->
let gt = foldl
(\acc2 q ->
let qt = t q gx
qs = s q gx
in
if (qs > 0 && qs < 1) && (qt > 0 && qt < acc2)
then qt
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.
collide
:: (Collidible other)
=> c -- ^ Original object
-> other -- ^ Collision partner
-> c -- ^ Updated original object
=> c -- ^ Original object
-> other -- ^ Collision partner
-> CollisionResult Double -- ^ Collision reaction
-> c -- ^ Updated original object
collide = elasticCollision 1
-- | Implementation of a dampened elastic collision used as default collision
@ -92,9 +112,11 @@ elasticCollision
=> Double
-> c1
-> c2
-> CollisionResult Double
-> c1
elasticCollision damping mo1 mo2 =
let (V2 v1x v1y) = velocity mo1
elasticCollision _ mo1 _ NoCollision = mo1
elasticCollision damping mo1 mo2 (Collision ddt) =
let v1@(V2 v1x v1y) = velocity mo1
(V2 v2x v2y) = velocity mo2
p1@(V2 p1x p1y) = position mo1
p2 = position mo2
@ -114,5 +136,53 @@ elasticCollision damping mo1 mo2 =
then (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
(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 -- ^ Updated mass object
move dt m =
let dpos = ((dt *) <$> velocity m)
let dpos@(V2 dx dy) = (dt *) <$> velocity m
in
if quadrance dpos > 0.5
then (positionUpdater m) (position m + dpos)
else m
if dy < 0 && abs dy < 1
then (positionUpdater m) (position m + (V2 dx 0))
else (positionUpdater m) (position m + dpos)

View File

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

View File

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

View File

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