Tweak creature cliff interaction, using updateCarriage

src/Dodge/Creature/State/WalkCycle.hs

@@ -2,8 +2,11 @@
 
 module Dodge.Creature.State.WalkCycle (updateCarriage) where
 
+import Dodge.Creature.Radius
+import Geometry
+import Dodge.Update.Camera.Rotate
+import qualified SDL
 import Dodge.WorldEvent.ThingsHit
-import Geometry.Polygon
 import Data.Maybe
 import Dodge.Creature.HandPos
 import Linear
@@ -19,16 +22,9 @@ updateCarriage cid w = fromMaybe w $ do
 
 updateCarriage' :: Int -> Creature -> World -> Carriage -> World
 updateCarriage' cid cr w = \case
-    Walking -> case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
-        (Just x,Just ff) | x >= strideLength cr -> w
-            & soundMultiFrom
-                [FootstepSound i | i <- [0 .. 10]]
-                (cr ^. crPos . _xy)
-                (chooseFootSound ff)
-                Nothing
-            & over (cWorld . lWorld . creatures . ix cid . crType) resetStride
-         & tocr . crPos . _xy +~ 0.5 *^ (cr ^. crOldPos - oop) ^. _xy
-        _ -> w & tocr . crPos . _xy +~ 0.5 *^ (cr ^. crOldPos - oop) ^. _xy
+    Walking -> maybeTakeStep cid cr w 
+        & tocr . crPos . _xy +~ 0.5 *^ (cr ^. crOldPos - oop) ^. _xy
+        & chasmTestCliffPush walkCliffPush cr
     Floating -> w
     Flying {_zSpeed = dz, _flyInertia = x} ->
           w & tocr . crPos . _xy +~ x *^ f (cr ^. crOldPos . _xy - oop ^. _xy)
@@ -47,12 +43,96 @@ updateCarriage' cid cr w = \case
             else w & cWorld . lWorld . creatures . ix cid . crPos .~ ep
     OnGround {} -> w
         & tocr . crPos . _xy +~ 0.8 *^ (cr ^. crOldPos . _xy - oop ^. _xy)
+        & chasmTestCliffPush groundCliffPush cr
   where
     tocr = cWorld . lWorld . creatures . ix cid
     oop = cr ^. crOldOldPos
     f v | norm v > 10 = 10 *^ signorm v
         | otherwise = v
 
+pushAgainst :: Point2 -> Point2 -> Point2
+pushAgainst x y
+    | a > norm y = 0
+    | a > 0 = y - project y x
+    | otherwise = y
+  where
+    -- project y x is the projection of x onto y
+    a = dotV (normalize y) (project y x)
+
+walkCliffPush :: Creature -> [(Point2,Point2)] -> Point2
+walkCliffPush cr xs = pushAgainst (cr ^. crOldPos . _xy - cr ^. crOldOldPos . _xy) (-h xs)
+  where
+    cxy = cr ^. crPos . _xy
+    h = circSegsInside cxy (cr ^. crType . to crRad)
+
+groundCliffPush :: Creature -> [(Point2,Point2)] -> Point2
+groundCliffPush cr xs = x *^ h xs
+  where
+    --x = max 0.05 $ 0.05 + 0.05 * (1 - dist cxy p / (2*r))
+    x = max 0 $ 0.25 * (1 - dist cxy p / (2*r)) ** 2
+    cxy = cr ^. crPos . _xy
+    r = cr ^. crType . to crRad
+    h = circSegsInside cxy r
+    p = circSegsInside' cxy r xs
+
+circSegsInside' :: Point2 -> Float -> [(Point2,Point2)] -> Point2
+circSegsInside' p r = \case
+    [x,y] -> fromJust (uncurry (uncurry intersectLineLine (f x)) (f y))
+    ((x,y):_) -> closestPointOnLine x y p + r *^ normalizeV (vNormal (x-y))
+    _ -> error "circSegsInside"
+  where
+    r' = r+0.5
+    f (x,y) = (x+r'*^n,y+r'*^n)
+      where
+        n = normalizeV (vNormal (x-y))
+
+circSegsInside :: Point2 -> Float -> [(Point2,Point2)] -> Point2
+circSegsInside p r = \case
+    [x,y] -> normalize $ fromJust (uncurry (uncurry intersectLineLine (f x)) (f y)) - p
+    ((x,y):_) -> normalizeV (vNormal (x-y))
+    _ -> error "circSegsInside"
+  where
+    r' = r+0.5
+    f (x,y) = (x+r'*^n,y+r'*^n)
+      where
+        n = normalizeV (vNormal (x-y))
+
+--circTwoLineCorner :: Float -> Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+--circTwoLineCorner r x y a b = intersectLineLine x y a b
+
+chasmTestCliffPush :: (Creature -> [(Point2,Point2)] -> Point2) -> Creature -> World -> World
+chasmTestCliffPush f' cr w
+    | (xy:xys) <- filter g (w ^. cWorld . cliffs) =
+        w
+            & soundContinue (CrChasm (_crID cr)) (cr ^. crPos . _xy) debrisS (Just 100)
+            & tocr . crPos . _xy +~ f' cr (xy:xys) -- (f cr (xy:xys)) *^ h xy xys
+            & chasmRotate cr (uncurry (-) xy)
+    | any f (w ^. cWorld . chasms) = w & tocr . crStance . carriage .~ Falling -- %~ startFalling
+    | otherwise = w
+  where
+    cxy = cr ^. crPos . _xy
+    tocr = cWorld . lWorld . creatures . ix (_crID cr)
+    g = uncurry $ crOnSeg cr
+    f = pointInPoly cxy
+
+chasmRotate :: Creature -> Point2 -> World -> World
+chasmRotate cr v w
+    | t = rotateTo8 (argV v) w
+    | otherwise = w
+  where
+    t = cr ^. crID == 0 && null (w ^? input . mouseButtons . ix SDL.ButtonRight)
+
+maybeTakeStep :: Int -> Creature -> World -> World
+maybeTakeStep cid cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+    (Just x,Just ff) | x >= strideLength cr ->
+        soundMultiFrom
+            [FootstepSound i | i <- [0 .. 10]]
+            (cr ^. crPos . _xy)
+            (chooseFootSound ff)
+            Nothing
+        . over (cWorld . lWorld . creatures . ix cid . crType) resetStride
+    _ -> id
+
 
 resetStride :: CreatureType -> CreatureType
 resetStride ct = case ct ^? footForward of