diff --git a/src/Physics/Classes/Collidible.hs b/src/Physics/Classes/Collidible.hs index 72e4509..9c524ce 100644 --- a/src/Physics/Classes/Collidible.hs +++ b/src/Physics/Classes/Collidible.hs @@ -41,15 +41,17 @@ class (Show c, Mass c) => Collidible c where collisionCheck dt m1 m2 = let d1@(V2 d1x d1y) = velocity m1 d2@(V2 d2x d2y) = velocity m2 - p1 = position m1 - p2 = position m2 + p1@(V2 p1x p1y) = position m1 + p2@(V2 p2x p2y) = position m2 (m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1 (m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2 + (V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = (p1 +) <$> boundary m1 + (V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = (p2 +) <$> boundary m2 m1p1 = p1 + m1b1 m1p2 = p1 + V2 m1b1x m1b2y m1p3 = p1 + m1b2 - m1p4 = p1 + V2 m1b2x m1b1y - m2p1 = p2 + m2b1 + m1p4@(V2 m1p4x _) = p1 + V2 m1b2x m1b1y + m2p1@(V2 m2p1x _) = p2 + m2b1 m2p2 = p2 + V2 m2b1x m2b2y m2p3 = p2 + m2b2 m2p4 = p2 + V2 m2b2x m2b1y @@ -92,23 +94,23 @@ class (Show c, Mass c) => Collidible c where in2 || in1 overlap = let in1 = - (m1b1x > m2b1x && m1b1x < m2b2x && - m1b1y > m2b1y && m1b1y < m2b2y) || - (m1b2x > m2b1x && m1b2x < m2b2x && - m1b1y > m2b1y && m1b1y < m2b2y) || - (m1b1x > m2b1x && m1b2x < m2b2x && - m1b2y > m2b1y && m1b2y < m2b2y) || - (m1b2x > m2b1x && m1b2x < m2b2x && - m1b2y > m2b1y && m1b2y < m2b2y) + (pm1b1x > pm2b1x && pm1b1x < pm2b2x && + pm1b1y > pm2b1y && pm1b1y < pm2b2y) || + (pm1b2x > pm2b1x && pm1b2x < pm2b2x && + pm1b1y > pm2b1y && pm1b1y < pm2b2y) || + (pm1b1x > pm2b1x && pm1b2x < pm2b2x && + pm1b2y > pm2b1y && pm1b2y < pm2b2y) || + (pm1b2x > pm2b1x && pm1b2x < pm2b2x && + pm1b2y > pm2b1y && pm1b2y < pm2b2y) in2 = - (m2b1x > m1b1x && m2b1x < m1b2x && - m2b1y > m1b1y && m2b1y < m1b2y) || - (m2b2x > m1b1x && m2b2x < m1b2x && - m2b1y > m1b1y && m2b1y < m1b2y) || - (m2b1x > m1b1x && m2b2x < m1b2x && - m2b2y > m1b1y && m2b2y < m1b2y) || - (m2b2x > m1b1x && m2b2x < m1b2x && - m2b2y > m1b1y && m2b2y < m1b2y) + (pm2b1x > pm1b1x && pm2b1x < pm1b2x && + pm2b1y > pm1b1y && pm2b1y < pm1b2y) || + (pm2b2x > pm1b1x && pm2b2x < pm1b2x && + pm2b1y > pm1b1y && pm2b1y < pm1b2y) || + (pm2b1x > pm1b1x && pm2b2x < pm1b2x && + pm2b2y > pm1b1y && pm2b2y < pm1b2y) || + (pm2b2x > pm1b1x && pm2b2x < pm1b2x && + pm2b2y > pm1b1y && pm2b2y < pm1b2y) in in2 || in1 tx = @@ -124,71 +126,62 @@ class (Show c, Mass c) => Collidible c where in if broadphaseOverlap then - -- if overlap - if False - then - Collision - (if tx < ty then tx else ty) - (if tx < ty - then V2 (floor $ signum d1x) 0 - else V2 0 (floor $ signum d1y) - ) - else - let coll xdir = - let (p11, p12, p21, p22) - | xdir = - if d1x < 0 - then - (m1p1, m1p2, m2p4, m2p3) - else - (m1p4, m1p3, m2p1, m2p2) - | otherwise = - if d1y < 0 - then - (m1p1, m1p4, m2p2, m2p3) - else - (m1p2, m1p3, m2p1, m2p4) - vselector (V2 x y) = if xdir then y else x - tick = if xdir then tx else ty - g1s = vselector $ p11 + ((tick *) <$> d1) - g1e = vselector $ p12 + ((tick *) <$> d1) - g2s = vselector $ p21 + ((tick *) <$> d2) - g2e = vselector $ p22 + ((tick *) <$> d2) - s11 = (g1s - g2s) / (g2e - g2s) - s12 = (g1e - g2s) / (g2e - g2s) - s21 = (g2s - g1s) / (g1e - g1s) - s22 = (g2e - g1s) / (g1e - g1s) - in - any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22] - res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of - (True, _, True, True, _) -> - Collision tx (V2 (floor $ signum d1x) 0) - (_, True, False, _, True) -> - Collision ty (V2 0 (floor $ signum d1y)) - (True, _, False, True, False) -> - Collision tx (V2 (floor $ signum d1x) 0) - (_, True, True, False, True) -> - Collision ty (V2 0 (floor $ signum d1y)) - (True, _, True, False, _) -> - NoCollision - (_, True, False, _, False) -> - NoCollision - (_, _, _, False, False) -> - NoCollision - (_, _, True, _, _) -> - A.log A.Debug "CORNER CASE!" NoCollision - (False, False, _, _, _) -> - NoCollision - x -> error $ - "Unhandled combination of collision check results: " - <> fromString (show x) - in - res - -- case res of - -- Collision _ _ -> - -- A.log A.Debug "colliding!" res - -- NoCollision -> - -- res + let coll xdir = + let (p11, p12, p21, p22) + | xdir = + if d1x < 0 + then + (m1p1, m1p2, m2p4, m2p3) + else + (m1p4, m1p3, m2p1, m2p2) + | otherwise = + if d1y < 0 + then + (m1p1, m1p4, m2p2, m2p3) + else + (m1p2, m1p3, m2p1, m2p4) + vselector (V2 x y) = if xdir then y else x + tick = if xdir then tx else ty + g1s = vselector $ p11 + ((tick *) <$> d1) + g1e = vselector $ p12 + ((tick *) <$> d1) + g2s = vselector $ p21 + ((tick *) <$> d2) + g2e = vselector $ p22 + ((tick *) <$> d2) + s11 = (g1s - g2s) / (g2e - g2s) + s12 = (g1e - g2s) / (g2e - g2s) + s21 = (g2s - g1s) / (g1e - g1s) + s22 = (g2e - g1s) / (g1e - g1s) + in + any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22] + res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of + (True, _, True, True, _) -> + Collision tx (V2 (floor $ signum d1x) 0) + (_, True, False, _, True) -> + Collision ty (V2 0 (floor $ signum d1y)) + (True, _, False, True, False) -> + Collision tx (V2 (floor $ signum d1x) 0) + (_, True, True, False, True) -> + Collision ty (V2 0 (floor $ signum d1y)) + -- (True, _, True, False, _) -> + -- NoCollision + -- (_, True, False, _, False) -> + -- NoCollision + (_, _, _, False, False) -> + NoCollision + (_, _, True, _, _) -> + A.log A.Debug "CORNER CASE!" NoCollision + (False, False, _, _, _) -> + NoCollision + x -> error $ + "Unhandled combination of collision check results: " + <> fromString (show x) + in + case res of + Collision _ _ -> + res + NoCollision -> + if overlap + then Collision 0 (V2 0 0) + else NoCollision else NoCollision @@ -211,7 +204,7 @@ elasticCollision -> Double -- ^ Timestep length -> c1 elasticCollision _ mo1 (_, NoCollision) _ = mo1 -elasticCollision damping mo1 (mo2, (Collision ddt (V2 dirx _))) _ = +elasticCollision damping mo1 (mo2, Collision ddt (V2 dirx diry)) dt = let v1@(V2 v1x v1y) = velocity mo1 (V2 v2x v2y) = velocity mo2 p1 = position mo1 @@ -231,5 +224,12 @@ elasticCollision damping mo1 (mo2, (Collision ddt (V2 dirx _))) _ = in velocityUpdater mo1 - -- (positionUpdater mo1 (p1 + ((ddt *) <$> v1))) + -- (positionUpdater + -- mo1 + -- (p1 + + -- if dirx == 0 && diry == 0 + -- then (dt *) <$> V2 (-v1x) 0 + -- else (ddt *) <$> v1 + -- ) + -- ) nvel diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index 9dffa26..efdb2a6 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -97,7 +97,14 @@ update level dt = liftIO $ do (aindex, res) in tangibles `V.update` - V.map updater collisionPartners + V.map + updater + (A.log + A.Debug + ("Collision partners: " <> + fromString (show collisionPartners)) + collisionPartners + ) (newCast, newPowerups, mnewCat@(Just _)) = V.foldl (\acc@(castAcc, pAcc, _) input -> case input of diff --git a/src/Types/Player.hs b/src/Types/Player.hs index af8e82f..689d550 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -114,12 +114,12 @@ instance Actor Pituicat where } ) finalCat = physCat - { pcMoveVel = + { pcMoveVel = (if pcXColl physCat then V2 0 1 else V2 1 1) * lerp (min 0.95 (60 * dt)) (pcMoveVel physCat) (pcTMoveVel physCat) , pcGrounded = pcGrounded physCat && abs dy * dt <= 2 - , pcPos = pcPos physCat + if not (pcXColl physCat) - then ((dt *) <$> pcMoveVel physCat) - else V2 0 0 + -- , pcPos = pcPos physCat + if not (pcXColl physCat) + -- then (dt *) <$> pcMoveVel physCat + -- else V2 0 0 , pcEffects = foldl (\acc eff -> @@ -174,6 +174,13 @@ instance Mass Pituicat where { pcPos = pos } + move dt cat = + let dpos = (dt *) <$> velocity cat + mpos = (dt *) <$> + (if pcXColl cat then V2 (-1) 1 else V2 1 1) * pcMoveVel cat + in + positionUpdater cat (position cat + dpos + mpos) + instance Collidible Pituicat where boundary cat = @@ -223,7 +230,5 @@ instance Collidible Pituicat where in ncat { pcGrounded = grounded - , pcXColl = any - (\(_, Collision _ (V2 cx _)) -> cx /= 0) - (filter ((NoCollision /=) . snd) collrs) || dirx /= 0 + , pcXColl = not grounded && diry /= 0 }