Sometimes crush creatures when doors close on them

src/Dodge/WallCreatureCollisions.hs

@@ -6,6 +6,7 @@ module Dodge.WallCreatureCollisions (
     crOnWall,
 ) where
 
+import Data.Foldable
 import Linear
 import Dodge.Creature.Radius
 import Control.Lens
@@ -25,30 +26,64 @@ noclipCheck cfig w c
     | otherwise = colCrWall w c
 
 colCrWall :: World -> Creature -> Creature
-colCrWall w c
+colCrWall w c -- = cornpush . wallpush $ pushthrough c
     | p1 == p2 = pushOrCrush ls c
-    --    | _crPos c' == _crPos c'' = c'
-    --    | otherwise = c & crPos .~ _crOldPos c
-    | otherwise = c'
+    | otherwise = cornpush . wallpush $ pushthrough c
+--    | otherwise = wallpush $ pushthrough c
+--    | otherwise = c'
   where
-    --    c'' = c' & crPos %~ pushOutFromWalls rad ls
-    --c'  = c & crPos %~ pushOutFromWalls' rad (reverse ls)
-    c' =
-        c & crPos . _xy
-            %~ pushOutFromCorners r ls'
-                . pushOutFromWalls r ls'
-                . fst
-                . flip (collidePoint p1) wls -- check push throughs
-                --        . flip (collidePointWalls' p1) wls  -- check push throughs
+    cornpush = crPos . _xy %~ pushOutFromCorners r ls'
+    --wallpush = crPos . _xy %~ pushOutFromWalls r ls'
+    wallpush = pushCr' wls
+    pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
+--    c' = c & crPos . _xy
+--            %~ pushOutFromCorners r ls'
+--                . pushOutFromWalls r ls'
+--                . fst
+--                . flip (collidePoint p1) wls -- check push throughs
     r = crRad (c ^. crType) + wallBuffer
     p1 = c ^. crOldPos . _xy
     p2 = c ^. crPos . _xy
     ls = _wlLine <$> wls
     ls' = filter (uncurry $ isLHS p1) ls
-    --wls = filter notff $ wlsNearRect (p2 + V2 r r) (p2 - V2 r r) w
     wls = filter notff $ wlsNearCirc p2 r w
     notff x = x ^. wlMaterial /= ForceField
 
+pushCr' :: [Wall] -> Creature -> Creature
+pushCr' wls cr 
+    | dist ep sp > r 
+        && dist ep ap > r = ecr & crDamage <>~ [Crushing 1000 10]
+            & crPos . _xy +~ r *^ ep - ap
+    | otherwise = ecr
+  where
+    ep = ecr ^. crPos . _xy
+    ap = cr ^. crOldPos . _xy
+    sp = cr ^. crPos . _xy
+    ecr = foldl' f (cr & crCrushTimers .~ mempty) wls
+    r = crRad (cr ^. crType)
+    f acr wl = case pushOutFromWall r (acr ^. crPos . _xy) (wl ^. wlLine) of
+        Just p -> acr & crPos . _xy .~ p & crCrushTimers . at (_wlID wl) ?~ 0
+        Nothing -> acr
+
+--apushCr :: [Wall] -> Creature -> Creature
+--apushCr wls cr = case wallPushList r wls cp of
+--a    [] -> cr
+--a    [(p,wl)] -> cr & crPos . _xy .~ p
+--a--    [(p1,w1),(p2,w2)] | dd p1 p2 >= 0 -> 
+--a    [(p1,w1),(p2,w2)] -> 
+--a        let v1 = p1 - cp
+--a            v2 = p2 - cp
+--a            mp = intersectLineLine p1 (p1 + vNormal v1) p2 (p2 + vNormal v2)
+--a            --p = fromMaybe (cr ^. crOldPos . _xy) mp
+--a            p = (cr ^. crOldPos . _xy)
+--a        in  cr & crPos . _xy .~ p
+--a--    [(p1,w1),(p2,w2)] -> cr & crPos . _xy .~ p1
+--a    xs -> cr
+--a  where
+--a    dd p1 p2 = dotV (p1 - cp) (p2 - cp)
+--a    r = crRad (cr ^. crType)
+--a    cp = cr ^. crPos . _xy
+
 -- the amount to push creatures out from walls, extra to their radius
 wallBuffer :: Float
 wallBuffer = 0
@@ -65,6 +100,14 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall
     Nothing -> p1
     Just p2 -> pushOutFromWalls rad (tail wls) p2
 
+--wallPushList :: Float -> [Wall] -> Point2 -> [(Point2, Wall)]
+--wallPushList rad wls p1 = mapMaybe f wls
+--  where
+--    f :: Wall -> Maybe (Point2,Wall)
+--    f wl = case pushOutFromWall rad p1 (wl ^. wlLine) of
+--        Nothing -> Nothing
+--        Just p -> Just (p,wl)
+
 -- possible improvement: choose between the closer of p2 and "p3" to p1
 
 --pushOutFromWalls' :: Float -> [(Point2,Point2)] -> Point2 -> Point2
@@ -76,6 +119,7 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall
 pushOrCrush :: [(Point2, Point2)] -> Creature -> Creature
 pushOrCrush wls cr = case mapMaybe (pushOutFromWall (crRad (cr ^. crType)) cpos) wls of
     [] -> cr
+    --(p : _) -> cr & crPos . _xy .~ p & crDamage <>~ [Crushing 1000 0]
     (p : _) -> cr & crPos . _xy .~ p
   where
     --    (_:p:_)   -> cr
@@ -102,9 +146,9 @@ pushOutFromWall rad cp2 (wp1, wp2)
     | isOnWall = Just newP
     | otherwise = Nothing
   where
-    n = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
-    wp1' = wp1 +.+ rad *.* n
-    wp2' = wp2 +.+ rad *.* n
+    n = errorNormalizeV 61 $ vNormal (wp1 - wp2)
+    wp1' = wp1 + rad *^ n
+    wp2' = wp2 + rad *^ n
     newP = errorClosestPointOnLine 5 wp1' wp2' cp2
     isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
 
@@ -115,4 +159,4 @@ pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst)
 squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
 squashIntersectCirclePoint rad p cCen
     | dist cCen p > rad = cCen
-    | otherwise = p +.+ (rad *.* squashNormalizeV (cCen -.- p))
+    | otherwise = p + (rad *^ squashNormalizeV (cCen - p))