From 430e2fff14243faa23546d5bcba4e830af53998e Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 14 Jan 2021 23:08:24 +0100 Subject: [PATCH] reworked collision again --- src/Classes/Physics/Collidible.hs | 108 +++++++++++++++--------------- src/Classes/Physics/Mass.hs | 2 +- src/Scenes/Test/EventHandler.hs | 14 +--- src/Scenes/Test/Load.hs | 1 + src/Types/Player.hs | 25 ++++--- 5 files changed, 73 insertions(+), 77 deletions(-) diff --git a/src/Classes/Physics/Collidible.hs b/src/Classes/Physics/Collidible.hs index 45e5110..f32ebf9 100644 --- a/src/Classes/Physics/Collidible.hs +++ b/src/Classes/Physics/Collidible.hs @@ -26,41 +26,56 @@ class (Show c, Mass c) => Collidible c where -> other -- ^ second object -> Bool -- ^ Do the objects collide? collisionCheck dt m1 m2 = - let (V2 m1x1 m1y1) = position m1 + fst (boundary m1) -- + delta1 - (V2 m1x2 m1y2) = position m1 + snd (boundary m1) -- + delta1 - (V2 m2x1 m2y1) = position m2 + fst (boundary m2) -- + delta2 - (V2 m2x2 m2y2) = position m2 + snd (boundary m2) -- + delta2 - delta1@(V2 vx1 vy1) = (dt *) <$> velocity m1 - delta2@(V2 vx2 vy2) = (dt *) <$> velocity m2 - dtx 0 = dt - dtx vx = - if vx > 0 - then ((m2x1 + vx2) - (m1x2 + vx1)) / vx - else ((m1x1 + vx1) - (m2x2 + vx2)) / (-vx) - dty 0 = dt - dty vy = - if vy > 0 - then ((m2y1 + vy2) - (m1y2 + vy1)) / vy - else ((m1y1 + vy1) - (m2y2 + vy2)) / (-vy) - posColl = - or - [ m1x1 < m2x2 && m1x1 > m2x1 - , m1x2 < m2x2 && m1x2 > m2x1 - , m2x1 < m1x2 && m2x1 > m1x1 - , m2x2 < m1x2 && m2x2 > m1x1 - ] && or - [ m1y1 < m2y2 && m1y1 > m2y1 - , m1y2 < m2y2 && m1y2 > m2y1 - , m2y1 < m1y2 && m2y1 > m1y1 - , m2y2 < m1y2 && m2y2 > m1y1 - ] + let d1@(V2 d1x d1y) = (dt *) <$> velocity m1 + d2@(V2 d2x d2y) = (dt *) <$> velocity m2 + p1 = position m1 + p2 = position m2 + (m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1 + (m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2 + m1p1 = m1b1 + m1p2 = V2 m1b1x m1b2y + m1p3 = m1b2 + m1p4 = V2 m1b2x m1b1y + m2p1 = m2b1 + m2p2 = V2 m2b1x m2b2y + m2p3 = m2b2 + m2p4 = V2 m2b2x m2b1y + quad1 = map (p1 + d1 +) [m1p1, m1p2, m1p3, m1p4] + g1 = (m2p1, m2p2) + g2 = (m2p2, m2p3) + g3 = (m2p3, m2p4) + g4 = (m2p4, m2p1) + gs = map (\(s1, s2) -> (p2 + s1, p2 + s2)) [g1, g2, g3, g4] + t (V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) = + if d1x == 0 && d1y == 0 + then dt + else + ((mtpx - mqpx) * (-(mtpy - mspy)) - (-(mtpx - mspx)) * (mspy - mqpy)) / + (d1x * (-(mtpy - mspy)) - (-(mtpx - mspx)) * d1y) + 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 - -- posColl || (dt > dtx vx1 || dt > dty vy1) - -- (if vx1 == 0 then posColl else dt > dtx vx1) - (posColl || dt > dtx vx1) - && - -- (if vy1 == 0 then posColl else dt > dty vy1) - (posColl || dt > dty vy1) + 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 -- | This Function is called for every collision on both colliding objects. collide @@ -90,29 +105,14 @@ elasticCollision damping mo1 mo2 = v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y (V2 dx dy) = p2 - p1 - np = V2 - ( 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 + nvel@(V2 nvx nvy) = if m1 == recip 0 then V2 0 0 else (damping *) <$> if m2 == recip 0 - then if abs dy < abs dx + then + if abs dy < abs dx then (V2 (-v1x) v1y) else (V2 v1x (-v1y)) else (V2 v1x' v1y') - ) + in + (velocityUpdater mo1) nvel diff --git a/src/Classes/Physics/Mass.hs b/src/Classes/Physics/Mass.hs index d05c3e6..830b912 100644 --- a/src/Classes/Physics/Mass.hs +++ b/src/Classes/Physics/Mass.hs @@ -59,6 +59,6 @@ class Mass m where move dt m = let dpos = ((dt *) <$> velocity m) in - if quadrance dpos * sqrt 2 > dt + if quadrance dpos > 0.5 then (positionUpdater m) (position m + dpos) else m diff --git a/src/Scenes/Test/EventHandler.hs b/src/Scenes/Test/EventHandler.hs index d2d2f4e..9f4d6f6 100644 --- a/src/Scenes/Test/EventHandler.hs +++ b/src/Scenes/Test/EventHandler.hs @@ -22,17 +22,9 @@ singleHandler -> Affection () singleHandler level event = do let multiplier = if tmKeyMotion event == SDL.Pressed then 1 else 0 - changeDirection cat state dirVel = + changeDirection cat state = Just cat { 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) -> A.log Debug ("Grounded: " <> fromString (show $ pcGrounded pituicat)) $ @@ -46,7 +38,7 @@ singleHandler level event = do ) else Just pituicat - MoveRight -> changeDirection pituicat MoveRight catMoveVelocity - MoveLeft -> changeDirection pituicat MoveLeft (-catMoveVelocity) + MoveRight -> changeDirection pituicat MoveRight + MoveLeft -> changeDirection pituicat MoveLeft _ -> Just pituicat ) diff --git a/src/Scenes/Test/Load.hs b/src/Scenes/Test/Load.hs index cc3c4f6..b26a284 100644 --- a/src/Scenes/Test/Load.hs +++ b/src/Scenes/Test/Load.hs @@ -84,6 +84,7 @@ load level progress = do let pituicat = Pituicat (V2 100 1948) + (V2 0 1) (V2 0 0) (V2 0 0) 100 diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 0a58b6b..0666e95 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -24,11 +24,12 @@ import Types.Texture import Types.Subsystems catMoveVelocity :: Double -catMoveVelocity = 1 +catMoveVelocity = 10 data Pituicat = Pituicat { pcPos :: V2 Double , pcVel :: V2 Double + , pcMoveVel :: V2 Double , pcAcc :: V2 Double , pcHealth :: Int , pcTexture :: Texture @@ -39,7 +40,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 @@ -78,14 +79,18 @@ instance Actor Pituicat where (p {pcAcc = 0}) (V2 vx vy) = pcVel physCat finalCat = physCat - { pcGrounded = pcGrounded physCat || (vy < 0 && abs vy < 2) - , pcVel = case pcMoveState physCat of - Just MoveRight -> V2 (min catMoveVelocity vx) vy - Just MoveLeft -> V2 (min (-catMoveVelocity) vx) vy - _ -> V2 vx vy + { pcGrounded = (vy <= 0 && abs vy < 30 ) + , pcMoveVel = case pcMoveState physCat of + Just MoveRight -> V2 catMoveVelocity 0 + Just MoveLeft -> V2 (-catMoveVelocity) 0 + _ -> V2 0 0 } 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 @@ -99,7 +104,7 @@ instance Mass Pituicat where } ) - velocity = pcVel + velocity cat = pcVel cat + pcMoveVel cat velocityUpdater cat = (\vel -> cat @@ -131,6 +136,4 @@ instance Collidible Pituicat where (V2 _ dy) = pcVel ncat in ncat - { pcGrounded = dy > 0 && abs dy < 10 - } )