make better collision reaction
This commit is contained in:
parent
03c406fd3e
commit
a99a70eb9d
5 changed files with 146 additions and 63 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -87,6 +87,7 @@ load level progress = do
|
|||
(V2 0 1)
|
||||
(V2 0 0)
|
||||
(V2 0 0)
|
||||
(V2 0 0)
|
||||
100
|
||||
tex
|
||||
False
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in a new issue