tinkering with collision and movement

src/Classes/Physics/Collidible.hs

@@ -26,22 +26,22 @@ class (Show c, Mass c) => Collidible c where
     -> other  -- ^ second object
     -> Bool   -- ^ Do the objects collide?
   collisionCheck dt m1 m2 =
-    let (V2 m1x1 m1y1) = position m1 + fst (boundary m1) + delta1
-        (V2 m1x2 m1y2) = position m1 + snd (boundary m1) + delta1
-        (V2 m2x1 m2y1) = position m2 + fst (boundary m2) + delta2
-        (V2 m2x2 m2y2) = position m2 + snd (boundary m2) + delta2
+    let (V2 m1x1 m1y1) = position m1 + fst (boundary m1) -- + delta1
+        (V2 m1x2 m1y2) = position m1 + snd (boundary m1) -- + delta1
+        (V2 m2x1 m2y1) = position m2 + fst (boundary m2) -- + delta2
+        (V2 m2x2 m2y2) = position m2 + snd (boundary m2) -- + delta2
         delta1@(V2 vx1 vy1) = (dt *) <$> velocity m1
-        delta2 = (dt *) <$> velocity m2
+        delta2@(V2 vx2 vy2) = (dt *) <$> velocity m2
         dtx 0 = dt
         dtx vx =
           if vx > 0
-          then (m2x1 - m1x2) / vx
-          else (m1x1 - m2x2) / (-vx)
+          then ((m2x1 + vx2) - (m1x2 + vx1)) / vx
+          else ((m1x1 + vx1) - (m2x2 + vx2)) / (-vx)
         dty 0 = dt
         dty vy =
           if vy > 0
-          then (m2y1 - m1y2) / vy
-          else (m1y1 - m2y2) / (-vy)
+          then ((m2y1 + vy2) - (m1y2 + vy1)) / vy
+          else ((m1y1 + vy1) - (m2y2 + vy2)) / (-vy)
         posColl =
           or
           [ m1x1 < m2x2 && m1x1 > m2x1
@@ -55,11 +55,12 @@ class (Show c, Mass c) => Collidible c where
           , m2y2 < m1y2 && m2y2 > m1y1
           ]
     in
+      -- posColl || (dt > dtx vx1 || dt > dty vy1)
       -- (if vx1 == 0 then posColl else dt > dtx vx1)
-      (dt > dtx vx1 || posColl)
+      (posColl || dt > dtx vx1)
       &&
       -- (if vy1 == 0 then posColl else dt > dty vy1)
-      (dt > dty vy1 || posColl)
+      (posColl || dt > dty vy1)
 
   -- | This Function is called for every collision on both colliding objects.
   collide
@@ -67,7 +68,7 @@ class (Show c, Mass c) => Collidible c where
     => c     -- ^ Original object
     -> other -- ^ Collision partner
     -> c     -- ^ Updated original object
-  collide = elasticCollision 0.9
+  collide = elasticCollision 1
 
 -- | Implementation of a dampened elastic collision used as default collision
 -- implementation of the collision reaction
@@ -110,6 +111,8 @@ elasticCollision damping mo1 mo2 =
         then V2 0 0
         else (damping *) <$>
           if m2 == recip 0
-          then negate <$> velocity mo1
+          then if abs dy < abs dx
+            then (V2 (-v1x) v1y)
+            else (V2 v1x (-v1y))
           else (V2 v1x' v1y')
         )

src/Scenes/Test/EventHandler.hs

@@ -22,6 +22,18 @@ singleHandler
   -> Affection ()
 singleHandler level event = do
   let multiplier = if tmKeyMotion event == SDL.Pressed then 1 else 0
+      changeDirection cat state dirVel =
+          Just cat
+          { pcMoveState = if multiplier > 0 then Just state else Nothing
+          , pcVel = if multiplier > 0
+            then pcVel cat + V2 dirVel 0
+            else
+              let (V2 vx vy) = pcVel cat
+              in
+                if abs vx - dirVel < 0
+                then V2 0 vy
+                else V2 (vx - dirVel) vy
+          }
   liftIO $ atomically $ modifyTVar (testPlayer level) (\(Just pituicat) ->
     A.log Debug ("Grounded: " <> fromString (show $ pcGrounded pituicat)) $
     case tmAction event of
@@ -34,5 +46,7 @@ singleHandler level event = do
             )
         else
           Just pituicat
+      MoveRight -> changeDirection pituicat MoveRight catMoveVelocity
+      MoveLeft -> changeDirection pituicat MoveLeft (-catMoveVelocity)
       _ -> Just pituicat
     )

src/Scenes/Test/Load.hs

@@ -89,6 +89,7 @@ load level progress = do
         100
         tex
         False
+        Nothing
 
   unbind vertexArray
   unbind vertexBuffer

src/Scenes/Test/Update.hs

@@ -80,4 +80,4 @@ update level dt = liftIO $ do
                 )
               collidedCat
               layer
-        in Just $ move dt walledCat
+        in Just $ walledCat

src/Types/Player.hs

@@ -21,20 +21,25 @@ import Classes.Physics
 
 import Types.Graphics.VertexBuffer
 import Types.Texture
+import Types.Subsystems
+
+catMoveVelocity :: Double
+catMoveVelocity = 1
 
 data Pituicat = Pituicat
-  { pcPos  :: V2 Double
-  , pcVel :: V2 Double
-  , pcAcc :: V2 Double
-  , pcHealth :: Int
-  , pcTexture :: Texture
-  , pcGrounded :: Bool
+  { pcPos       :: V2 Double
+  , pcVel       :: V2 Double
+  , pcAcc       :: V2 Double
+  , pcHealth    :: Int
+  , pcTexture   :: Texture
+  , pcGrounded  :: Bool
+  , pcMoveState     :: Maybe Action
   }
   deriving (Eq, Show)
 
 instance Drawable Pituicat where
 
-  toVertices (Pituicat (V2 x y) _ _ _ _ _) =
+  toVertices (Pituicat (V2 x y) _ _ _ _ _ _) =
     ( V.fromList [0, 1, 2, 2, 3, 0]
     , V.fromList
       [ newVertex
@@ -69,11 +74,15 @@ instance Prop Pituicat where
 instance Actor Pituicat where
 
   perform dt p =
-    let physCat = (accelerate dt . gravitate constG)
+    let physCat = (move dt . accelerate dt . gravitate constG)
           (p {pcAcc = 0})
-        (V2 _ dy) = pcVel physCat
+        (V2 vx vy) = pcVel physCat
         finalCat = physCat
-          { pcGrounded = pcGrounded physCat || (dy < 0 && abs dy < 2)
+          { pcGrounded = pcGrounded physCat || (vy < 0 && abs vy < 2)
+          , pcVel = case pcMoveState physCat of
+            Just MoveRight -> V2 (min catMoveVelocity vx) vy
+            Just MoveLeft -> V2 (min (-catMoveVelocity) vx) vy
+            _ -> V2 vx vy
           }
     in
       (A.log Debug ("moving with " <> fromString (show $ pcVel finalCat))) finalCat
@@ -122,6 +131,6 @@ instance Collidible Pituicat where
            (V2 _ dy) = pcVel ncat
       in
         ncat
-          { pcGrounded = dy > 0 && abs dy < 2
+          { pcGrounded = dy > 0 && abs dy < 10
           }
         )