diff --git a/src/Physics/Classes/Collidible.hs b/src/Physics/Classes/Collidible.hs index 50ea17c..72e4509 100644 --- a/src/Physics/Classes/Collidible.hs +++ b/src/Physics/Classes/Collidible.hs @@ -195,11 +195,11 @@ class (Show c, Mass c) => Collidible c where -- | This Function is called for every collision on both colliding objects. collide :: (Collidible other) - => c -- ^ Original object - -> other -- ^ Collision partner - -> CollisionResult Double (V2 Int) -- ^ Collision reaction - -> c -- ^ Updated original object - collide = elasticCollision 1 + => c -- ^ Original object + -> [(other, CollisionResult Double (V2 Int))] -- ^ Collision partners and results + -> Double -- ^ Timestep length + -> c -- ^ Updated original object + collide coll1 collrs = elasticCollision 0.9 coll1 (head collrs) -- | Implementation of a dampened elastic collision used as default collision -- implementation of the collision reaction @@ -207,11 +207,11 @@ elasticCollision :: (Collidible c1, Collidible c2) => Double -> c1 - -> c2 - -> CollisionResult Double (V2 Int) + -> (c2, CollisionResult Double (V2 Int)) + -> Double -- ^ Timestep length -> c1 -elasticCollision _ mo1 _ NoCollision = mo1 -elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx _)) = +elasticCollision _ mo1 (_, NoCollision) _ = mo1 +elasticCollision damping mo1 (mo2, (Collision ddt (V2 dirx _))) _ = let v1@(V2 v1x v1y) = velocity mo1 (V2 v2x v2y) = velocity mo2 p1 = position mo1 @@ -230,5 +230,6 @@ elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx _)) = else V2 v1x' v1y' in velocityUpdater - (positionUpdater mo1 (p1 + ((ddt *) <$> v1))) - nvel + mo1 + -- (positionUpdater mo1 (p1 + ((ddt *) <$> v1))) + nvel diff --git a/src/Scenes/Test/Load.hs b/src/Scenes/Test/Load.hs index 73d85e5..a8e6523 100644 --- a/src/Scenes/Test/Load.hs +++ b/src/Scenes/Test/Load.hs @@ -84,6 +84,7 @@ load level progress = do Nothing ViewRight [] + False oil = PowerUp (realToFrac <$> (startpos + V2 200 0)) (V2 0 0) diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index 320f39a..9dffa26 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -68,25 +68,31 @@ update level dt = liftIO $ do then iacc else iacc `V.snoc` ( index - , head - (sortOn (collisionTime . snd) (V.toList partners)) + , sortOn (collisionTime . snd) (V.toList partners) ) ) V.empty indexedTangibles - updater (aindex, partner) = + updater (aindex, partners) = let aobject = (snd $ indexedTangibles V.! aindex) - res = - (\(pindex, presult) -> + digest = map + (\(pindex, presults) -> + ( snd $ indexedTangibles V.! pindex + , presults + ) + ) + partners + res = + (\d -> let inter = collide aobject - (snd $ indexedTangibles V.! pindex) - presult + d + dt in inter ) - partner + digest in (aindex, res) in @@ -219,34 +225,34 @@ update level dt = liftIO $ do -- } -- in Just $ move dt affectedCat -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@(part, cr) tile -> - let res = collisionCheck dt c tile - ret = if cr == NoCollision && res == NoCollision - then - acc - else - if cr == NoCollision && res /= NoCollision - then (tile, res) - else - if cr /= NoCollision && res == NoCollision - then - acc - else - if collisionTime cr < collisionTime res - then acc - else (tile, res) - in - ret - ) - (V.head layer, collisionCheck dt c $ V.head layer) - layer - in - uncurry (collide c) partner +-- 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@(part, cr) tile -> +-- let res = collisionCheck dt c tile +-- ret = if cr == NoCollision && res == NoCollision +-- then +-- acc +-- else +-- if cr == NoCollision && res /= NoCollision +-- then (tile, res) +-- else +-- if cr /= NoCollision && res == NoCollision +-- then +-- acc +-- else +-- if collisionTime cr < collisionTime res +-- then acc +-- else (tile, res) +-- in +-- ret +-- ) +-- (V.head layer, collisionCheck dt c $ V.head layer) +-- layer +-- in +-- (uncurry (collide c) partner) dt diff --git a/src/Types/Cast.hs b/src/Types/Cast.hs index 9f8d4bb..da5ba98 100644 --- a/src/Types/Cast.hs +++ b/src/Types/Cast.hs @@ -34,4 +34,4 @@ instance Collidible Cast where collisionCheck dt (Cast c1) c2 = collisionCheck dt c1 c2 - collide (Cast c1) c2 res = Cast $ collide c1 c2 res + collide (Cast c1) res dt = Cast $ collide c1 res dt diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 5ace2c0..af8e82f 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -41,6 +41,7 @@ data Pituicat = Pituicat , pcMoveState :: Maybe Action , pcViewDirection :: ViewDirection , pcEffects :: [EffectHolder] + , pcXColl :: Bool } deriving (Eq, Show) @@ -49,7 +50,7 @@ data ViewDirection = ViewLeft | ViewRight instance Drawable Pituicat where - toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ vd _) = + toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ vd _ _) = ( V.fromList [0, 1, 2, 2, 3, 0] , V.fromList [ newVertex @@ -116,6 +117,9 @@ instance Actor Pituicat where { pcMoveVel = 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 , pcEffects = foldl (\acc eff -> @@ -155,29 +159,13 @@ instance Mass Pituicat where { pcAcc = accel } - velocity cat = - let mvel@(V2 mx _) = pcMoveVel cat - nvel@(V2 x y) = pcVel cat + mvel - in - if abs x > abs mx then V2 (signum x * abs mx) y else nvel + velocity = + pcVel velocityUpdater cat = - \(V2 vx vy) -> - let - (V2 mx my) = pcMoveVel cat - nvel = V2 - (if abs mx > abs vx - then 0 - else signum vx * (abs vx - abs mx) - ) - (if abs my > abs vy - then 0 - else signum vy * (abs vy - abs my) - ) - in - cat - { pcVel = nvel - } + \vel -> cat + { pcVel = vel + } position = pcPos @@ -199,41 +187,43 @@ instance Collidible Pituicat where , V2 18 15 ) - collide cat _ NoCollision = cat - collide cat other collr@(Collision ddt (V2 dirx diry)) = - let ncat = elasticCollision 0.3 cat other collr - nvel@(V2 _ vy) = pcVel ncat - grounded = diry == -1 && abs (vy * ddt) < 2 - fact = fromIntegral <$> V2 - (1 - abs dirx) - (if diry /= -1 && quadrance nvel > bounceThreshold then 1 else 0) - in - ncat - { pcVel = nvel * fact - , pcMoveVel = pcMoveVel ncat * fact - , pcTMoveVel = pcTMoveVel ncat * fact - , pcGrounded = grounded - } - -- let ncat = (elasticCollision 0.3 cat other collr) - -- vel@(V2 vx vy) = velocity ncat - -- moveVel@(V2 mx my) = pcMoveVel cat - -- nvel = V2 - -- (if abs mx > abs vx - -- then 0 - -- else (signum vx) * (abs vx - abs mx) - -- ) - -- ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat)) - -- grounded = - -- diry == -1 && abs (vy * ddt) < 2 + collide cat [] _ = cat + { pcXColl = False + } + collide cat collrs@((_, NoCollision):_) _ = cat + { pcXColl = any + (\(_, Collision _ (V2 cx _)) -> cx /= 0) + (filter ((NoCollision /= ) . snd) collrs) + } + collide cat collrs@(collr@((other, Collision ddt (V2 dirx diry))):_) dt = + -- let ncat = elasticCollision 0.3 cat other collr + -- nvel@(V2 _ vy) = pcVel ncat + -- grounded = diry == -1 && abs (vy * ddt) < 2 + -- fact = fromIntegral <$> V2 + -- (1 - abs dirx) + -- (if diry /= -1 && quadrance nvel > bounceThreshold then 1 else 0) -- in -- ncat - -- { pcGrounded = grounded - -- , pcMoveVel = pcMoveVel ncat * - -- if dirx /= 0 - -- then V2 0 1 - -- else V2 1 1 - -- , pcVel = nvel * - -- if dirx /= 0 - -- then V2 0 1 - -- else V2 1 1 + -- { pcVel = nvel * fact + -- , pcMoveVel = pcMoveVel ncat * fact + -- , pcTMoveVel = pcTMoveVel ncat * fact + -- , pcGrounded = grounded -- } + let ncat = elasticCollision 0.3 cat collr dt + vel@(V2 vx vy) = velocity ncat + moveVel@(V2 mx my) = pcMoveVel cat + nvel = V2 + (if abs mx > abs vx + then 0 + else signum vx * (abs vx - abs mx) + ) + ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat)) + grounded = + diry == -1 && abs (vy * ddt) < 2 + in + ncat + { pcGrounded = grounded + , pcXColl = any + (\(_, Collision _ (V2 cx _)) -> cx /= 0) + (filter ((NoCollision /=) . snd) collrs) || dirx /= 0 + } diff --git a/src/Types/PowerUp.hs b/src/Types/PowerUp.hs index deb1dd3..c722343 100644 --- a/src/Types/PowerUp.hs +++ b/src/Types/PowerUp.hs @@ -106,10 +106,11 @@ instance Collidible PowerUp where , V2 20 20 ) - collide o _ NoCollision = o + collide o ((_, NoCollision):_) _ = o + collide o [] _ = o - collide o other collr@(Collision ddr (V2 dirx diry)) = - let no = elasticCollision 0.5 o other collr + collide o (collr:_) dt = + let no = elasticCollision 0.5 o collr dt in no diff --git a/src/Types/Tangible.hs b/src/Types/Tangible.hs index 8958434..2689869 100644 --- a/src/Types/Tangible.hs +++ b/src/Types/Tangible.hs @@ -70,7 +70,7 @@ instance Collidible Tangible where 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 + collide (TPlayer c1) res dt = TPlayer $ collide c1 res dt + collide (TCast c1) res dt = TCast $ collide c1 res dt + collide (TPowerUp c1) res dt = TPowerUp $ collide c1 res dt + collide (TTile c1) res dt = TTile $ collide c1 res dt