reworked collision again

This commit is contained in:
nek0 2021-01-14 23:08:24 +01:00
parent 8627f80be2
commit 430e2fff14
5 changed files with 73 additions and 77 deletions

View File

@ -26,41 +26,56 @@ class (Show c, Mass c) => Collidible c where
-> other -- ^ second object -> other -- ^ second object
-> Bool -- ^ Do the objects collide? -> Bool -- ^ Do the objects collide?
collisionCheck dt m1 m2 = collisionCheck dt m1 m2 =
let (V2 m1x1 m1y1) = position m1 + fst (boundary m1) -- + delta1 let d1@(V2 d1x d1y) = (dt *) <$> velocity m1
(V2 m1x2 m1y2) = position m1 + snd (boundary m1) -- + delta1 d2@(V2 d2x d2y) = (dt *) <$> velocity m2
(V2 m2x1 m2y1) = position m2 + fst (boundary m2) -- + delta2 p1 = position m1
(V2 m2x2 m2y2) = position m2 + snd (boundary m2) -- + delta2 p2 = position m2
delta1@(V2 vx1 vy1) = (dt *) <$> velocity m1 (m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1
delta2@(V2 vx2 vy2) = (dt *) <$> velocity m2 (m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2
dtx 0 = dt m1p1 = m1b1
dtx vx = m1p2 = V2 m1b1x m1b2y
if vx > 0 m1p3 = m1b2
then ((m2x1 + vx2) - (m1x2 + vx1)) / vx m1p4 = V2 m1b2x m1b1y
else ((m1x1 + vx1) - (m2x2 + vx2)) / (-vx) m2p1 = m2b1
dty 0 = dt m2p2 = V2 m2b1x m2b2y
dty vy = m2p3 = m2b2
if vy > 0 m2p4 = V2 m2b2x m2b1y
then ((m2y1 + vy2) - (m1y2 + vy1)) / vy quad1 = map (p1 + d1 +) [m1p1, m1p2, m1p3, m1p4]
else ((m1y1 + vy1) - (m2y2 + vy2)) / (-vy) g1 = (m2p1, m2p2)
posColl = g2 = (m2p2, m2p3)
or g3 = (m2p3, m2p4)
[ m1x1 < m2x2 && m1x1 > m2x1 g4 = (m2p4, m2p1)
, m1x2 < m2x2 && m1x2 > m2x1 gs = map (\(s1, s2) -> (p2 + s1, p2 + s2)) [g1, g2, g3, g4]
, m2x1 < m1x2 && m2x1 > m1x1 t (V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) =
, m2x2 < m1x2 && m2x2 > m1x1 if d1x == 0 && d1y == 0
] && or then dt
[ m1y1 < m2y2 && m1y1 > m2y1 else
, m1y2 < m2y2 && m1y2 > m2y1 ((mtpx - mqpx) * (-(mtpy - mspy)) - (-(mtpx - mspx)) * (mspy - mqpy)) /
, m2y1 < m1y2 && m2y1 > m1y1 (d1x * (-(mtpy - mspy)) - (-(mtpx - mspx)) * d1y)
, m2y2 < m1y2 && m2y2 > m1y1 s (V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) =
] (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)
in
(0 < am `dot` ab && am `dot` ab < ab `dot` ab) &&
(0 < am `dot` ad && am `dot` ad < ad `dot` ad)
in in
-- posColl || (dt > dtx vx1 || dt > dty vy1) any inside quad1 ||
-- (if vx1 == 0 then posColl else dt > dtx vx1) any
(posColl || dt > dtx vx1) (\gx ->
&& any
-- (if vy1 == 0 then posColl else dt > dty vy1) (\q ->
(posColl || dt > dty vy1) let qs = s q gx
qt = t q gx
in
(qs > 0 && qs < 1) && (qt > 0 && qt < dt)
)
quad1
)
gs
-- | This Function is called for every collision on both colliding objects. -- | This Function is called for every collision on both colliding objects.
collide collide
@ -90,29 +105,14 @@ elasticCollision damping mo1 mo2 =
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
(V2 dx dy) = p2 - p1 (V2 dx dy) = p2 - p1
np = V2 nvel@(V2 nvx nvy) = if m1 == recip 0
( p1x + if v1x == 0
then 0
else
if dx < 0
then (abs m2x1 + abs m1x2 - abs dx)
else - (abs m2x2 + abs m1x1 - abs dx)
)
( p1y + if v1y == 0
then 0
else
if dy < 0
then (abs m2y1 + abs m1y2 - abs dy)
else - (abs m2y2 + abs m1y1 - abs dy)
)
in
(velocityUpdater ((positionUpdater mo1) np))
(if m1 == recip 0
then V2 0 0 then V2 0 0
else (damping *) <$> else (damping *) <$>
if m2 == recip 0 if m2 == recip 0
then if abs dy < abs dx then
if abs dy < abs dx
then (V2 (-v1x) v1y) then (V2 (-v1x) v1y)
else (V2 v1x (-v1y)) else (V2 v1x (-v1y))
else (V2 v1x' v1y') else (V2 v1x' v1y')
) in
(velocityUpdater mo1) nvel

View File

@ -59,6 +59,6 @@ class Mass m where
move dt m = move dt m =
let dpos = ((dt *) <$> velocity m) let dpos = ((dt *) <$> velocity m)
in in
if quadrance dpos * sqrt 2 > dt if quadrance dpos > 0.5
then (positionUpdater m) (position m + dpos) then (positionUpdater m) (position m + dpos)
else m else m

View File

@ -22,17 +22,9 @@ singleHandler
-> Affection () -> Affection ()
singleHandler level event = do singleHandler level event = do
let multiplier = if tmKeyMotion event == SDL.Pressed then 1 else 0 let multiplier = if tmKeyMotion event == SDL.Pressed then 1 else 0
changeDirection cat state dirVel = changeDirection cat state =
Just cat Just cat
{ pcMoveState = if multiplier > 0 then Just state else Nothing { pcMoveState = if multiplier > 0 then Just state else Nothing
, pcVel = if multiplier > 0
then pcVel cat + V2 dirVel 0
else
let (V2 vx vy) = pcVel cat
in
if abs vx - dirVel < 0
then V2 0 vy
else V2 (vx - dirVel) vy
} }
liftIO $ atomically $ modifyTVar (testPlayer level) (\(Just pituicat) -> liftIO $ atomically $ modifyTVar (testPlayer level) (\(Just pituicat) ->
A.log Debug ("Grounded: " <> fromString (show $ pcGrounded pituicat)) $ A.log Debug ("Grounded: " <> fromString (show $ pcGrounded pituicat)) $
@ -46,7 +38,7 @@ singleHandler level event = do
) )
else else
Just pituicat Just pituicat
MoveRight -> changeDirection pituicat MoveRight catMoveVelocity MoveRight -> changeDirection pituicat MoveRight
MoveLeft -> changeDirection pituicat MoveLeft (-catMoveVelocity) MoveLeft -> changeDirection pituicat MoveLeft
_ -> Just pituicat _ -> Just pituicat
) )

View File

@ -84,6 +84,7 @@ load level progress = do
let pituicat = Pituicat let pituicat = Pituicat
(V2 100 1948) (V2 100 1948)
(V2 0 1)
(V2 0 0) (V2 0 0)
(V2 0 0) (V2 0 0)
100 100

View File

@ -24,11 +24,12 @@ import Types.Texture
import Types.Subsystems import Types.Subsystems
catMoveVelocity :: Double catMoveVelocity :: Double
catMoveVelocity = 1 catMoveVelocity = 10
data Pituicat = Pituicat data Pituicat = Pituicat
{ pcPos :: V2 Double { pcPos :: V2 Double
, pcVel :: V2 Double , pcVel :: V2 Double
, pcMoveVel :: V2 Double
, pcAcc :: V2 Double , pcAcc :: V2 Double
, pcHealth :: Int , pcHealth :: Int
, pcTexture :: Texture , pcTexture :: Texture
@ -39,7 +40,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
@ -78,14 +79,18 @@ instance Actor Pituicat where
(p {pcAcc = 0}) (p {pcAcc = 0})
(V2 vx vy) = pcVel physCat (V2 vx vy) = pcVel physCat
finalCat = physCat finalCat = physCat
{ pcGrounded = pcGrounded physCat || (vy < 0 && abs vy < 2) { pcGrounded = (vy <= 0 && abs vy < 30 )
, pcVel = case pcMoveState physCat of , pcMoveVel = case pcMoveState physCat of
Just MoveRight -> V2 (min catMoveVelocity vx) vy Just MoveRight -> V2 catMoveVelocity 0
Just MoveLeft -> V2 (min (-catMoveVelocity) vx) vy Just MoveLeft -> V2 (-catMoveVelocity) 0
_ -> V2 vx vy _ -> V2 0 0
} }
in in
(A.log Debug ("moving with " <> fromString (show $ pcVel finalCat))) finalCat (A.log Debug (
("being at " <> fromString (show $ pcPos finalCat)) <>
("; moving with " <> fromString (show $ pcVel finalCat))
)
) finalCat
instance Mass Pituicat where instance Mass Pituicat where
@ -99,7 +104,7 @@ instance Mass Pituicat where
} }
) )
velocity = pcVel velocity cat = pcVel cat + pcMoveVel cat
velocityUpdater cat = velocityUpdater cat =
(\vel -> cat (\vel -> cat
@ -131,6 +136,4 @@ instance Collidible Pituicat where
(V2 _ dy) = pcVel ncat (V2 _ dy) = pcVel ncat
in in
ncat ncat
{ pcGrounded = dy > 0 && abs dy < 10
}
) )