Improve wall crushing

src/Dodge/WallCreatureCollisions.hs

@@ -1,8 +1,11 @@
 -- | Deals with moving creature wall collisions.
-module Dodge.WallCreatureCollisions (colCrsWalls,
-    wlWlCrush
-    ) where
+module Dodge.WallCreatureCollisions (colCrsWalls) where
 
+--import Control.Applicative
+--import Data.Monoid
+import Dodge.Door.DoorLerp
+import Dodge.ShiftPoint
+import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Data.Foldable
@@ -26,7 +29,7 @@ colCrWall :: World -> Creature -> Creature
 colCrWall w c = cornpush . wallpush $ pushthrough c
   where
     cornpush = crPos . _xy %~ pushOutFromCorners r ls'
-    wallpush = pushCr wls
+    wallpush = pushCr (w ^. cWorld . lWorld) wls
     pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
     r = crRad (c ^. crType) + wallBuffer
     p1 = c ^. crOldPos . _xy
@@ -37,34 +40,60 @@ colCrWall w c = cornpush . wallpush $ pushthrough c
     notff x = x ^. wlMaterial /= ForceField
 
 -- might want to check angled crushing
-pushCr :: IM.IntMap Wall -> Creature -> Creature
-pushCr wls cr
-    | (dist ep sp > r && dist ep ap > r)
-        || wlsCrush twls
-            =
+pushCr :: LWorld -> IM.IntMap Wall -> Creature -> Creature
+pushCr w wls cr
+--    | (dist ep sp > r && dist ep ap > r)
+--        || wlsCrush' w (cr ^. crPos . _xy) twls =
+    | wlsCrush' w (cr ^. crPos . _xy) twls =
         ecr
             & crDamage <>~ [Crushing 1000 0]
             & crPos . _xy .~ ap
+--    | Just s <- wlsCrush w (cr ^. crPos . _xy) twls =
+--        ecr
+--            & crDamage <>~ [Crushing 1000 0]
+--            & crPos . _xy .~ ap
+--            & crName .~ s
     | otherwise = ecr
   where
 --    stwls = IM.filter (\wl -> uncurry circOnSegNoEndpoints (wl ^. wlLine) sp r) wls
     twls = IM.elems $ IM.restrictKeys wls (ecr ^. crWallTouch) -- `IM.union` stwls
-    ep = ecr ^. crPos . _xy
+--    ep = ecr ^. crPos . _xy
     ap = cr ^. crOldPos . _xy
-    sp = cr ^. crPos . _xy
+--    sp = cr ^. crPos . _xy
     ecr = foldl' f (cr & crWallTouch .~ mempty) wls
     r = crRad (cr ^. crType)
     f acr wl = case pushOutFromWall r (acr ^. crPos . _xy) (wl ^. wlLine) of
         Just p -> acr & crPos . _xy .~ p & crWallTouch %~ IS.insert (wl ^. wlID)
         Nothing -> acr
 
-wlsCrush :: [Wall] -> Bool
-wlsCrush [] = False
-wlsCrush (x:xs) = any (wlWlCrush x) xs || wlsCrush xs
+wallMovement :: LWorld -> Point2 -> Wall -> Point2
+wallMovement w p wl = fromMaybe 0 $ do
+    drid <- w ^? walls . ix (wl ^. wlID) . wlStructure . wsDoor 
+    dr <- w ^? doors . ix drid
+    let oldp = shiftPointBy (doDoorLerp dr (dr ^. drOldLerp)) 
+            $ invShiftPointBy (doDoorLerp dr (dr ^. drLerp)) p
+    return $ p - oldp
 
-wlWlCrush :: Wall -> Wall -> Bool
-wlWlCrush w1 w2 = norm (f w1 + f w2) < 0.2
+--wlsCrush :: LWorld -> Point2 -> [Wall] -> Maybe String
+--wlsCrush _ _ [] = Nothing
+--wlsCrush w p (x:xs) = getFirst (foldMap (First . wlWlCrush w p x) xs) <|> wlsCrush w p xs
+
+wlsCrush' :: LWorld -> Point2 -> [Wall] -> Bool
+wlsCrush' _ _ [] = False
+wlsCrush' w p (x:xs) = any (wlWlCrush' w p x) xs || wlsCrush' w p xs
+
+--wlWlCrush :: LWorld -> Point2 -> Wall -> Wall -> Maybe String
+--wlWlCrush w p w1 w2 
+--    | wlWlCrush' w p w1 w2 = Just $ show (w1 ^. wlID) <> ":" <> show (w2 ^. wlID)
+--    | otherwise = Nothing
+
+wlWlCrush' :: LWorld -> Point2 -> Wall -> Wall -> Bool
+wlWlCrush' w p w1 w2 = (t w1 w2 || t w2 w1) -- test either wall is moving towards the other
+        && norm (f w1 + f w2) < 0.2 -- test walls are facing each other
   where
+--    t wl = dotV (vNormal (normalizeV (uncurry (-) (wl ^. wlLine)))) (wallMovement w p wl) > 0
+    t x y = dotV (vNormal (normalizeV (uncurry (-) (x ^. wlLine))))
+        (wallMovement w p x - wallMovement w p y) > 0
     f = normalizeV . uncurry (-) . (^. wlLine)
 
 -- the amount to push creatures out from walls, extra to their radius