From 7654888f6f540967eb68481f68f35806c2dfd6fe Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 22 Mar 2021 06:36:28 +0100 Subject: [PATCH] more work on collision --- src/Classes/Physics/Collidible.hs | 40 +++++++++---------- src/Scenes/Test/Update.hs | 66 +++++++++++++++++-------------- 2 files changed, 56 insertions(+), 50 deletions(-) diff --git a/src/Classes/Physics/Collidible.hs b/src/Classes/Physics/Collidible.hs index cbf986b..7ed3ba2 100644 --- a/src/Classes/Physics/Collidible.hs +++ b/src/Classes/Physics/Collidible.hs @@ -107,27 +107,27 @@ class (Show c, Mass c) => Collidible c where in in2 || in1 tx = - let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p4) - p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p4 else m2p1) + let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p2) + p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p2 else m2p1) in if d2x - d1x == 0 then dt else (p1x - p2x) / (d2x - d1x) ty = - let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p1 else m1p2) - p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p2 else m2p1) + let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p4 else m1p1) + p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p1 else m2p4) in if d2y - d1y == 0 then dt else (p1y - p2y) / (d2y - d1y) in if broadphaseOverlap then - if tx < ty + if tx <= ty then if tx < dt then - if d1x < 0 + if d1x <= 0 then let (V2 _ g1s) = m1p1 + ((tx *) <$> d1) - (V2 _ g1e) = m1p2 + ((tx *) <$> d1) - (V2 _ g2s) = m2p4 + ((tx *) <$> d2) + (V2 _ g1e) = m1p4 + ((tx *) <$> d1) + (V2 _ g2s) = m2p2 + ((tx *) <$> d2) (V2 _ g2e) = m2p3 + ((tx *) <$> d2) s11 = (g1s - g2s) / (g2e - g2s) s12 = (g1e - g2s) / (g2e - g2s) @@ -138,10 +138,10 @@ class (Show c, Mass c) => Collidible c where then Collision tx (V2 (floor $ signum d1x) 0) else NoCollision else - let (V2 _ g1s) = m1p4 + ((tx *) <$> d1) + let (V2 _ g1s) = m1p2 + ((tx *) <$> d1) (V2 _ g1e) = m1p3 + ((tx *) <$> d1) (V2 _ g2s) = m2p1 + ((tx *) <$> d2) - (V2 _ g2e) = m2p2 + ((tx *) <$> d2) + (V2 _ g2e) = m2p4 + ((tx *) <$> d2) s11 = (g1s - g2s) / (g2e - g2s) s12 = (g1e - g2s) / (g2e - g2s) s21 = (g2s - g1s) / (g1e - g1s) @@ -155,12 +155,12 @@ class (Show c, Mass c) => Collidible c where else if ty < dt then - if d1y < 0 + if d1y <= 0 then - let (V2 g1s _) = m1p2 + ((ty *) <$> d1) - (V2 g1e _) = m1p3 + ((ty *) <$> d1) - (V2 g2s _) = m2p1 + ((ty *) <$> d2) - (V2 g2e _) = m2p4 + ((ty *) <$> d2) + let (V2 g1s _) = m1p1 + ((ty *) <$> d1) + (V2 g1e _) = m1p2 + ((ty *) <$> d1) + (V2 g2s _) = m2p4 + ((ty *) <$> d2) + (V2 g2e _) = m2p3 + ((ty *) <$> d2) s11 = (g1s - g2s) / (g2e - g2s) s12 = (g1e - g2s) / (g2e - g2s) s21 = (g2s - g1s) / (g1e - g1s) @@ -170,10 +170,10 @@ class (Show c, Mass c) => Collidible c where then Collision ty (V2 0 (floor $ signum d1y)) else NoCollision else - let (V2 g1s _) = m1p1 + ((ty *) <$> d1) - (V2 g1e _) = m1p4 + ((ty *) <$> d1) - (V2 g2s _) = m2p2 + ((ty *) <$> d2) - (V2 g2e _) = m2p3 + ((ty *) <$> d2) + let (V2 g1s _) = m1p4 + ((ty *) <$> d1) + (V2 g1e _) = m1p3 + ((ty *) <$> d1) + (V2 g2s _) = m2p1 + ((ty *) <$> d2) + (V2 g2e _) = m2p2 + ((ty *) <$> d2) s11 = (g1s - g2s) / (g2e - g2s) s12 = (g1e - g2s) / (g2e - g2s) s21 = (g2s - g1s) / (g1e - g1s) @@ -223,7 +223,7 @@ elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx diry)) = else (damping *) <$> if m2 == recip 0 then - if abs dy < abs dx + if abs dirx > 0 then (V2 (-v1x) v1y) else (V2 v1x (-v1y)) else (V2 v1x' v1y') diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index 1170650..32457fa 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Scenes.Test.Update where import Affection @@ -7,6 +8,8 @@ import Control.Concurrent.STM import qualified Data.Vector as V +import Data.Maybe + import Data.String (fromString) import Linear @@ -47,7 +50,7 @@ update level dt = liftIO $ do then (Cast c2, res) else acc ) - (Cast c1, Collision dt (V2 0 0)) + (Cast c1, NoCollision) playedCast in if null partners @@ -58,18 +61,8 @@ update level dt = liftIO $ do partners ) playedCast - wallCast (Cast c) = Cast $ uncurry (collide c) $ - V.foldl - (\acc@(_, ires) tile -> - let res = collisionCheck dt c tile - in - if res /= NoCollision && - collisionTime res < collisionTime ires - then (tile, res) - else acc - ) - (V.head layer, Collision dt (V2 0 0)) - layer + wallCast (Cast c) = + Cast $ performWorldCollision c layer dt walledCast = V.map wallCast collidedCast in @@ -93,7 +86,7 @@ update level dt = liftIO $ do then (Cast c, res) else acc ) - (V.head updatedCast, Collision dt (V2 0 0)) + (V.head updatedCast, NoCollision) updatedCast in if (collisionTime $ snd partner) == dt @@ -102,20 +95,33 @@ update level dt = liftIO $ do (\(Cast cx) res -> collide playedCat cx res) partner walledCat = - let partner = - V.foldl - (\acc@(_, ires) tile -> - let res = collisionCheck dt collidedCat tile - in - if res /= NoCollision && - collisionTime res < collisionTime ires - then (tile, res) - else acc - ) - (V.head layer, Collision dt (V2 0 0)) - layer - in - if (collisionTime $ snd partner) == dt - then collidedCat - else uncurry (collide collidedCat) partner + performWorldCollision playedCat layer dt in Just $ move dt walledCat + +performWorldCollision + :: (Collidible c) + => c -- ^ Cast member to check + -> Layer -- ^ The walk layer of the level + -> Double -- ^ Tick length + -> c -- ^ Updated cast member +performWorldCollision c layer dt = + let partner = V.foldl + (\acc tile -> + let res = collisionCheck dt c tile + ret = if isNothing acc + then if res /= NoCollision && collisionTime res < dt + then Just (c, res) + else Nothing + else if res /= NoCollision && + collisionTime res < collisionTime (snd (fromJust acc)) + then Just (c, res) + else acc + in + ret + ) + Nothing + layer + in + if isNothing partner + then c + else uncurry (collide c) (fromJust partner)