reworking walking

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
+    => c                                          -- ^ Original object
-    -> other                            -- ^ Collision partner
+    -> [(other, CollisionResult Double (V2 Int))] -- ^ Collision partners and  results
-    -> CollisionResult Double (V2 Int) -- ^ Collision reaction
+    -> Double                                     -- ^ Timestep length
-    -> c                               -- ^ Updated original object
+    -> c                                          -- ^ Updated original object
-  collide = elasticCollision 1
+  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
+  -> (c2, CollisionResult Double (V2 Int))
-  -> CollisionResult Double (V2 Int)
+  -> Double                          -- ^ Timestep length
   -> c1
-elasticCollision _ mo1 _ NoCollision = mo1
+elasticCollision _ mo1 (_, NoCollision) _ = mo1
-elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx _)) =
+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)))
+      mo1
-       nvel
+      -- (positionUpdater mo1 (p1 + ((ddt *) <$> v1)))
+      nvel

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)

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 = 
+                    digest = map
-                      (\(pindex, presult) ->
+                      (\(pindex, presults) ->
+                        ( snd $ indexedTangibles V.! pindex
+                        , presults
+                        )
+                        )
+                      partners
+                    res =
+                      (\d ->
                         let inter =
                               collide
                                 aobject
-                                (snd $ indexedTangibles V.! pindex)
+                                d
-                                presult
+                                dt
                         in
                           inter
                         )
-                      partner
+                      digest
                 in
                   (aindex, res)
           in
@@ -219,34 +225,34 @@ update level dt = liftIO $ do
     --           }
     --     in Just $ move dt affectedCat
 
-performWorldCollision
+-- performWorldCollision
-  :: (Collidible c)
+--   :: (Collidible c)
-  => c      -- ^ Cast member to check
+--   => c      -- ^ Cast member to check
-  -> Layer  -- ^ The walk layer of the level
+--   -> Layer  -- ^ The walk layer of the level
-  -> Double -- ^ Tick length
+--   -> Double -- ^ Tick length
-  -> c      -- ^ Updated cast member
+--   -> c      -- ^ Updated cast member
-performWorldCollision c layer dt =
+-- performWorldCollision c layer dt =
-  let partner = V.foldl
+--   let partner = V.foldl
-        (\acc@(part, cr) tile ->
+--         (\acc@(part, cr) tile ->
-          let res = collisionCheck dt c tile
+--           let res = collisionCheck dt c tile
-              ret = if cr == NoCollision && res == NoCollision
+--               ret = if cr == NoCollision && res == NoCollision
-                then
+--                 then
-                  acc
+--                   acc
-                else
+--                 else
-                  if cr == NoCollision && res /= NoCollision
+--                   if cr == NoCollision && res /= NoCollision
-                  then (tile, res)
+--                   then (tile, res)
-                  else
+--                   else
-                    if cr /= NoCollision && res == NoCollision
+--                     if cr /= NoCollision && res == NoCollision
-                    then
+--                     then
-                      acc
+--                       acc
-                    else
+--                     else
-                      if collisionTime cr < collisionTime res
+--                       if collisionTime cr < collisionTime res
-                      then acc
+--                       then acc
-                      else (tile, res)
+--                       else (tile, res)
-          in
+--           in
-            ret
+--             ret
-          )
+--           )
-        (V.head layer, collisionCheck dt c $ V.head layer)
+--         (V.head layer, collisionCheck dt c $ V.head layer)
-        layer
+--         layer
-  in
+--   in
-    uncurry (collide c) partner
+--     (uncurry (collide c) partner) dt

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

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 =
+  velocity =
-    let mvel@(V2 mx _) = pcMoveVel cat
+    pcVel
-        nvel@(V2 x y) = pcVel cat + mvel
-    in
-      if abs x > abs mx then V2 (signum x * abs mx) y else nvel
 
   velocityUpdater cat =
-    \(V2 vx vy) ->
+    \vel -> cat
-      let
+      { pcVel = vel
-        (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
-          }
 
   position = pcPos
 
@@ -199,41 +187,43 @@ instance Collidible Pituicat where
       , V2 18 15
       )
 
-  collide cat _ NoCollision = cat
+  collide cat [] _ = cat
-  collide cat other collr@(Collision ddt (V2 dirx diry)) =
+    { pcXColl = False
-    let ncat = elasticCollision 0.3 cat other collr
+    }
-        nvel@(V2 _ vy) = pcVel ncat
+  collide cat collrs@((_, NoCollision):_) _ = cat
-        grounded = diry == -1 && abs (vy * ddt) < 2
+    { pcXColl = any
-        fact = fromIntegral <$> V2
+      (\(_, Collision _ (V2 cx _)) -> cx /= 0)
-          (1 - abs dirx)
+      (filter ((NoCollision /= ) . snd) collrs)
-          (if diry /= -1 && quadrance nvel > bounceThreshold then 1 else 0)
+    }
-    in
+  collide cat collrs@(collr@((other, Collision ddt (V2 dirx diry))):_) dt =
-      ncat
+    -- let ncat = elasticCollision 0.3 cat other collr
-        { pcVel = nvel * fact
+    --     nvel@(V2 _ vy) = pcVel ncat
-        , pcMoveVel = pcMoveVel ncat * fact
+    --     grounded = diry == -1 && abs (vy * ddt) < 2
-        , pcTMoveVel = pcTMoveVel ncat * fact
+    --     fact = fromIntegral <$> V2
-        , pcGrounded = grounded
+    --       (1 - abs dirx)
-        }
+    --       (if diry /= -1 && quadrance nvel > bounceThreshold then 1 else 0)
-    -- 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
     -- in
     --   ncat
-    --     { pcGrounded = grounded
+    --     { pcVel = nvel * fact
-    --     , pcMoveVel = pcMoveVel ncat *
+    --     , pcMoveVel = pcMoveVel ncat * fact
-    --       if dirx /= 0
+    --     , pcTMoveVel = pcTMoveVel ncat * fact
-    --       then V2 0 1
+    --     , pcGrounded = grounded
-    --       else V2 1 1
-    --     , pcVel = nvel *
-    --       if dirx /= 0
-    --       then V2 0 1
-    --       else V2 1 1
     --     }
+    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
+        }

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)) =
+  collide o (collr:_) dt =
-    let no = elasticCollision 0.5 o other collr
+    let no = elasticCollision 0.5 o collr dt
     in
       no
 

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 (TPlayer c1) res dt  = TPlayer $ collide c1 res dt
-  collide (TCast c1) c2 res = TCast $ collide c1 c2 res
+  collide (TCast c1) res dt    = TCast $ collide c1 res dt
-  collide (TPowerUp c1) c2 res = TPowerUp $ collide c1 c2 res
+  collide (TPowerUp c1) res dt = TPowerUp $ collide c1 res dt
-  collide (TTile c1) c2 res = TTile $ collide c1 c2 res
+  collide (TTile c1) res dt    = TTile $ collide c1 res dt