make better collision reaction
This commit is contained in:
parent
03c406fd3e
commit
a99a70eb9d
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
}
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue