From b3a2e58af4aacb0b989846a2b38d946834b58647 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 8 Jul 2021 18:39:31 +0200 Subject: [PATCH] tinker more on collision. objects move, but glitches ensue. --- src/Physics/Classes/Collidible.hs | 139 +++++++++----- src/Physics/Classes/Mass.hs | 2 +- src/Scenes/Test/Update.hs | 291 +++++++++++++++++++----------- src/Types.hs | 1 + src/Types/Cast.hs | 29 +++ src/Types/Player.hs | 12 +- src/Types/Tangible.hs | 74 +++++++- src/Util.hs | 8 +- 8 files changed, 388 insertions(+), 168 deletions(-) diff --git a/src/Physics/Classes/Collidible.hs b/src/Physics/Classes/Collidible.hs index 5462e57..e6c8130 100644 --- a/src/Physics/Classes/Collidible.hs +++ b/src/Physics/Classes/Collidible.hs @@ -90,6 +90,27 @@ class (Show c, Mass c) => Collidible c where b2maxy > b1miny && b2maxy < b1maxy) in 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) + 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) + 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) @@ -103,57 +124,75 @@ class (Show c, Mass c) => Collidible c where in if broadphaseOverlap then - let coll xdir = - let (p11, p12, p21, p22) = - if xdir - then - if d1x < 0 + -- 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) = + if xdir then - (m1p1, m1p2, m2p4, m2p3) + if d1x < 0 + then + (m1p1, m1p2, m2p4, m2p3) + else + (m1p4, m1p3, m2p1, m2p2) else - (m1p4, m1p3, m2p1, m2p2) - else - 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 + 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 + if tx < 0 || ty < 0 + then A.log A.Debug ("PING!") res + else res + -- case res of + -- Collision _ _ -> + -- A.log A.Debug "colliding!" res + -- NoCollision -> + -- res else NoCollision @@ -189,7 +228,7 @@ elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx _)) = else (damping *) <$> if m2 == recip 0 then - if abs dirx > 0 + if dirx /= 0 then (V2 (-v1x) v1y) else (V2 v1x (-v1y)) else (V2 v1x' v1y') diff --git a/src/Physics/Classes/Mass.hs b/src/Physics/Classes/Mass.hs index 7fa016c..b4886c7 100644 --- a/src/Physics/Classes/Mass.hs +++ b/src/Physics/Classes/Mass.hs @@ -15,7 +15,7 @@ class Mass m where -- | Overwrite the acceleration of the mass object. accelerationUpdater :: m -> (V2 Double -> m) - -- | retrieve the elocity of the mass object. + -- | retrieve the velocity of the mass object. velocity :: m -> V2 Double -- | Overwrite the velocity of the mass object. diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index 2bd3456..d33b709 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -1,11 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Scenes.Test.Update where import Affection as A import Control.Concurrent.STM +import Data.List (sortOn) + import qualified Data.Vector as V import Data.Maybe @@ -32,115 +35,195 @@ update level dt = liftIO $ do -- (Typeclasses rock!) atomically $ do lmap <- readTMVar (testMap level) + cast <- + V.map (\(Cast c) -> Cast $ perform dt c) <$> readTVar (testCast level) + powerups <- V.filter ((0 <) . puTTL) <$> + V.map (perform dt) <$> + readTVar (testPowerups level) + cat <- perform dt <$> fromJust <$> readTVar (testPlayer level) let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap) - oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$> - readTVar (testCast level) - oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level) - modifyTVar (testCast level) $ \cast -> - let playedCast = - V.map - (\(Cast c) -> Cast (perform dt c)) - cast - collidedCast = - V.map - (\(Cast c1) -> - let partners = V.foldl - (\acc@(Cast _, ires) (Cast c2) -> - let res = collisionCheck dt c1 c2 - in - if res /= NoCollision && - collisionTime res < collisionTime ires - then (Cast c2, res) - else acc + tangibles = + (V.map TTile layer) V.++ + (V.map TCast cast) V.++ + (V.map TPowerUp powerups) `V.snoc` + TPlayer cat + + + indexedTangibles = V.zip + (V.fromList [0 .. ((V.length tangibles) - 1)]) + tangibles + collidedTangibles = + let collisionPartners = + V.foldl + (\acc (index, tangible1) -> + let partners = + V.foldl + (\acc (qInd, tangible2) -> + let res = collisionCheck dt tangible1 tangible2 + in + if res /= NoCollision && qInd /= index + then acc `V.snoc` (qInd, res) + else acc + ) + V.empty + indexedTangibles + in + if V.null partners + then acc + else acc `V.snoc` + ( index + , head + (sortOn (collisionTime . snd) (V.toList partners)) ) - (Cast c1, NoCollision) - playedCast + ) + V.empty + indexedTangibles + updater (aindex, partner) = + let aobject = (snd $ indexedTangibles V.! aindex) + res = + (\(pindex, presult) -> + let inter = + collide + aobject + (snd $ indexedTangibles V.! pindex) + presult + in + inter + ) + partner in - if null partners - then Cast c1 - else - uncurry - (\(Cast c2) result -> Cast $ collide c1 c2 result) - partners - ) - playedCast - wallCast (Cast c) = - Cast $ performWorldCollision c layer dt - walledCast = - V.map wallCast collidedCast - cattedCast = V.map - (\(Cast c) -> - Cast $ collide c oldCat $ collisionCheck dt c oldCat + (aindex, res) + in + tangibles `V.update` (A.log A.Debug + ("Partner: " <> (fromString $ show collisionPartners)) + (V.map updater collisionPartners) ) - walledCast - in - V.map - (\(Cast c) -> Cast $ - move dt c + (newCast, newPowerups, mnewCat@(Just _)) = V.foldl + (\acc@(castAcc, puAcc, mcat) input -> + case input of + TCast c -> + (castAcc `V.snoc` move dt c, puAcc, mnewCat) + TPowerUp p -> + (castAcc, puAcc `V.snoc` move dt p, mnewCat) + TPlayer cat -> + (castAcc, puAcc, Just (move dt cat)) + TTile t -> + acc ) - walledCast - releasedEffects <- stateTVar (testPowerups level) $ \pus -> - let living = V.foldl - (\acc pu -> - let npu = perform dt pu - in - if puTTL npu > 0 - then npu `V.cons` acc - else acc - ) - V.empty - pus - indexCollected = V.filter ((/= NoCollision) . snd) $ - V.zip (V.fromList [0..length living]) - (V.map - (collisionCheck dt oldCat) - living - ) - collected = V.foldl - (\acc (ind, _) -> - (living V.! ind) `V.cons` acc - ) - V.empty - indexCollected - differ = V.foldl - (\acc life -> if life `V.elem` collected - then acc - else life `V.cons` acc - ) - V.empty - living - fin = V.map - (\pu -> move dt $ performWorldCollision pu layer dt) - differ - in - (collected, fin) - modifyTVar - (testPlayer level) $ \(Just pituicat) -> - let playedCat = perform dt pituicat - castCat = - let allPartners = V.zip (V.fromList [0..V.length oldCast]) - (V.map - (\(Cast c) -> collisionCheck dt playedCat c) - oldCast - ) - filtered = (V.filter ((/= NoCollision) . snd) allPartners) - partner = V.minimumBy - (\(_, e) (_, f) -> collisionTime e `compare` collisionTime f) - filtered - in - if V.null filtered - then - playedCat - else - uncurry - (\(Cast c) cr -> collide playedCat c cr) - (oldCast V.! fst partner, snd partner) - walledCat = performWorldCollision castCat layer dt - affectedCat = walledCat - { pcEffects = pcEffects walledCat ++ - map puEffect (V.toList releasedEffects) - } - in Just $ move dt affectedCat + (V.empty, V.empty, Nothing) + collidedTangibles + writeTVar (testCast level) newCast + writeTVar (testPowerups level) newPowerups + writeTVar (testPlayer level) mnewCat + + -- oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$> + -- readTVar (testCast level) + -- oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level) + -- modifyTVar (testCast level) $ \cast -> + -- let playedCast = + -- V.map + -- (\(Cast c) -> Cast (perform dt c)) + -- cast + -- collidedCast = + -- V.map + -- (\(Cast c1) -> + -- let partners = V.foldl + -- (\acc@(Cast _, ires) (Cast c2) -> + -- let res = collisionCheck dt c1 c2 + -- in + -- if res /= NoCollision && + -- collisionTime res < collisionTime ires + -- then (Cast c2, res) + -- else acc + -- ) + -- (Cast c1, NoCollision) + -- playedCast + -- in + -- if null partners + -- then Cast c1 + -- else + -- uncurry + -- (\(Cast c2) result -> Cast $ collide c1 c2 result) + -- partners + -- ) + -- playedCast + -- wallCast (Cast c) = + -- Cast $ performWorldCollision c layer dt + -- walledCast = + -- V.map wallCast collidedCast + -- cattedCast = V.map + -- (\(Cast c) -> + -- Cast $ collide c oldCat $ collisionCheck dt c oldCat + -- ) + -- walledCast + -- in + -- V.map + -- (\(Cast c) -> Cast $ + -- move dt c + -- ) + -- walledCast + -- releasedEffects <- stateTVar (testPowerups level) $ \pus -> + -- let living = V.foldl + -- (\acc pu -> + -- let npu = perform dt pu + -- in + -- if puTTL npu > 0 + -- then npu `V.cons` acc + -- else acc + -- ) + -- V.empty + -- pus + -- indexCollected = V.filter ((/= NoCollision) . snd) $ + -- V.zip (V.fromList [0..length living]) + -- (V.map + -- (collisionCheck dt oldCat) + -- living + -- ) + -- collected = V.foldl + -- (\acc (ind, _) -> + -- (living V.! ind) `V.cons` acc + -- ) + -- V.empty + -- indexCollected + -- differ = V.foldl + -- (\acc life -> if life `V.elem` collected + -- then acc + -- else life `V.cons` acc + -- ) + -- V.empty + -- living + -- fin = V.map + -- (\pu -> move dt $ performWorldCollision pu layer dt) + -- differ + -- in + -- (collected, fin) + -- modifyTVar + -- (testPlayer level) $ \(Just pituicat) -> + -- let playedCat = perform dt pituicat + -- castCat = + -- let allPartners = V.zip (V.fromList [0..V.length oldCast]) + -- (V.map + -- (\(Cast c) -> collisionCheck dt playedCat c) + -- oldCast + -- ) + -- filtered = (V.filter ((/= NoCollision) . snd) allPartners) + -- partner = V.minimumBy + -- (\(_, e) (_, f) -> collisionTime e `compare` collisionTime f) + -- filtered + -- in + -- if V.null filtered + -- then + -- playedCat + -- else + -- uncurry + -- (\(Cast c) cr -> collide playedCat c cr) + -- (oldCast V.! fst partner, snd partner) + -- walledCat = performWorldCollision castCat layer dt + -- affectedCat = walledCat + -- { pcEffects = pcEffects walledCat ++ + -- map puEffect (V.toList releasedEffects) + -- } + -- in Just $ move dt affectedCat performWorldCollision :: (Collidible c) diff --git a/src/Types.hs b/src/Types.hs index d9451bf..f82d92e 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -10,3 +10,4 @@ import Types.StageSet as T import Types.Player as T import Types.Util as T import Types.PowerUp as T +import Types.Tangible as T diff --git a/src/Types/Cast.hs b/src/Types/Cast.hs index 8251e20..9f8d4bb 100644 --- a/src/Types/Cast.hs +++ b/src/Types/Cast.hs @@ -4,5 +4,34 @@ module Types.Cast where -- internale imports import Classes.Actor +import Physics.Classes data Cast = forall a. Actor a => Cast a + +instance Show Cast where + + show (Cast a) = show a + +instance Mass Cast where + + mass (Cast a) = mass a + + acceleration (Cast a) = acceleration a + + accelerationUpdater (Cast a) = Cast . accelerationUpdater a + + velocity (Cast a) = velocity a + + velocityUpdater (Cast a) = Cast . velocityUpdater a + + position (Cast a) = position a + + positionUpdater (Cast a) = Cast . positionUpdater a + +instance Collidible Cast where + + boundary (Cast c) = boundary c + + collisionCheck dt (Cast c1) c2 = collisionCheck dt c1 c2 + + collide (Cast c1) c2 res = Cast $ collide c1 c2 res diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 7db647d..7760edc 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -158,7 +158,11 @@ instance Mass Pituicat where } ) - velocity cat = pcVel cat + pcMoveVel cat + velocity cat = + let mvel@(V2 mx my) = pcMoveVel cat + nvel@(V2 x y) = pcVel cat + mvel + in + if abs x > abs mx then V2 (signum x * abs mx) y else nvel velocityUpdater cat = (\vel@(V2 vx vy) -> @@ -175,7 +179,7 @@ instance Mass Pituicat where ) in cat - { pcVel = nvel + { pcVel = vel } ) @@ -212,9 +216,7 @@ instance Collidible Pituicat where ) ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat)) grounded = - vy >= 0 && - vy < 200 && - diry == -1 + diry == -1 && abs (vy * ddt) < 2 in ncat { pcGrounded = grounded diff --git a/src/Types/Tangible.hs b/src/Types/Tangible.hs index 5d7516e..8958434 100644 --- a/src/Types/Tangible.hs +++ b/src/Types/Tangible.hs @@ -1,6 +1,76 @@ {-# LANGUAGE ExistentialQuantification #-} module Types.Tangible where -import Classes.Collectable (Collectable) +import Physics.Classes +import Types.Player +import Types.Cast +import Types.PowerUp +import Types.Map -data Tangible = forall a . Collectable a => Tangible a +-- wrapper type for everything that can be collided with. +data Tangible + = TPlayer Pituicat + | TCast Cast + | TPowerUp PowerUp + | TTile Tile + +instance Show Tangible where + + show (TPlayer a) = show a + show (TCast a) = show a + show (TPowerUp a) = show a + show (TTile a) = show a + +instance Mass Tangible where + + mass (TPlayer a) = mass a + mass (TCast a) = mass a + mass (TPowerUp a) = mass a + mass (TTile a) = mass a + + acceleration (TPlayer a) = acceleration a + acceleration (TCast a) = acceleration a + acceleration (TPowerUp a) = acceleration a + acceleration (TTile a) = acceleration a + + accelerationUpdater (TPlayer a) = TPlayer . accelerationUpdater a + accelerationUpdater (TCast a) = TCast . accelerationUpdater a + accelerationUpdater (TPowerUp a) = TPowerUp . accelerationUpdater a + accelerationUpdater (TTile a) = TTile . accelerationUpdater a + + velocity (TPlayer a) = velocity a + velocity (TCast a) = velocity a + velocity (TPowerUp a) = velocity a + velocity (TTile a) = velocity a + + velocityUpdater (TPlayer a) = TPlayer . velocityUpdater a + velocityUpdater (TCast a) = TCast . velocityUpdater a + velocityUpdater (TPowerUp a) = TPowerUp . velocityUpdater a + velocityUpdater (TTile a) = TTile . velocityUpdater a + + position (TPlayer a) = position a + position (TCast a) = position a + position (TPowerUp a) = position a + position (TTile a) = position a + + positionUpdater (TPlayer a) = TPlayer . positionUpdater a + positionUpdater (TCast a) = TCast . positionUpdater a + positionUpdater (TPowerUp a) = TPowerUp . positionUpdater a + positionUpdater (TTile a) = TTile . positionUpdater a + +instance Collidible Tangible where + + boundary (TPlayer c) = boundary c + boundary (TCast c) = boundary c + boundary (TPowerUp c) = boundary c + boundary (TTile c) = boundary c + + collisionCheck dt (TPlayer c1) c2 = collisionCheck dt c1 c2 + collisionCheck dt (TCast c1) c2 = collisionCheck dt c1 c2 + collisionCheck dt (TPowerUp c1) c2 = collisionCheck dt c1 c2 + collisionCheck dt (TTile c1) c2 = collisionCheck dt c1 c2 + + collide (TPlayer c1) c2 res = TPlayer $ collide c1 c2 res + collide (TCast c1) c2 res = TCast $ collide c1 c2 res + collide (TPowerUp c1) c2 res = TPowerUp $ collide c1 c2 res + collide (TTile c1) c2 res = TTile $ collide c1 c2 res diff --git a/src/Util.hs b/src/Util.hs index 4ce0b88..893567f 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -23,12 +23,8 @@ globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) = _ SDL.Pressed False - (SDL.Keysym SDL.ScancodeF11 _ mod) -> - if mod == SDL.fromNumber 0 - then - toggleScreen 0 - else - return () + (SDL.Keysym SDL.ScancodeF11 _ _) -> + toggleScreen 0 _ -> return () constG :: V2 Double