Implement moving wall push and crush

src/Dodge/WallCreatureCollisions.hs

@@ -14,23 +14,18 @@ colCrsWalls :: World -> World
 colCrsWalls w = over creatures (fmap (colCrWall w)) w
 
 colCrWall :: World -> Creature -> Creature
-colCrWall w c = pushOutFromWall w c
-
-pushOutFromWall :: World -> Creature -> Creature
-pushOutFromWall w c 
-    | p1 == p2 = c
-    | otherwise = over crPos ( 
-                              collideCorners rad p1 wallPoints
-                             . 
-                               collideWalls rad p1 ls 
-                             . checkPushThroughs rad p1 ls 
-                             ) 
-                       c 
-    where rad = _crRad c + wallBuffer
-          p1  = _crOldPos c
-          p2  = _crPos c
-          ls  = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
-          wallPoints = nub $ concat ls
+colCrWall w c 
+    | p1 == p2  = pushOrCrush ls c
+    | otherwise = c & crPos %~
+        collideCorners rad p1 wallPoints
+        . collideWalls rad p1 ls 
+        . checkPushThroughs rad p1 ls 
+  where 
+    rad = _crRad c + wallBuffer
+    p1  = _crOldPos c
+    p2  = _crPos c
+    ls  = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
+    wallPoints = nub $ concat ls
 
 -- colCrPushThrough :: World -> Creature -> Creature
 -- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
@@ -43,23 +38,40 @@ pushOutFromWall w c
 -- the amount to push creatures out from walls, extra to their radius
 wallBuffer = 3
 
--- the following tests whether a moving circle crosses a list of walls, and
--- places the circle accordingly.
--- It supposes that the circle will only interact with at most two walls.
--- the reverse prevents the collision from happening again with the first wall,
--- when two walls are collided with
+-- the following tests whether or not a point is on a wall, and if so pushes it
+-- out from the wall
+-- If the resultant push out is itself on another wall, the original point is
+-- returned
 collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
 collideWalls rad cp1 walls cp2
-    = case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of
+    = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
             Nothing -> cp2
-            Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of
+            Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of
                                          Nothing -> cp3
-                                         Just cp4 -> cp4
+                                         Just cp4 -> cp1
+
+-- pushes a point out from a list of walls
+-- if multiple new points occur, chooses the one closest to the orignal pointjk
+pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2
+pushOutFromWalls rad walls p = 
+    fromMaybe p
+    . listToMaybe
+    . sortBy (compare `on` dist p)
+    $ mapMaybe (pushOutFromWall rad p) 
+    walls
+
+pushOrCrush :: [[Point2]] -> Creature -> Creature
+pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
+    []  -> cr
+    [p] -> cr & crPos .~ p
+    _   -> cr & crState . crDamage %~ ( (Blunt 50 cpos cpos cpos) :)
+  where
+    cpos = _crPos cr
 
 -- assumes that the wall is orientated
 -- assumes wall points are different
-collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
-collideWall rad cp1 cp2 (wp1:wp2:_) 
+pushOutFromWall :: Float -> Point2 -> [Point2] -> Maybe (Point2)
+pushOutFromWall rad cp2 (wp1:wp2:_) 
             | isOnWall  = Just newP -- +.+ (1 *.* norm))
             | otherwise = Nothing
     where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
@@ -70,6 +82,12 @@ collideWall rad cp1 cp2 (wp1:wp2:_)
           isJust Nothing = False
           isJust _       = True
 
+pushOutFromCorners :: World -> Creature -> Creature
+pushOutFromCorners w cr = cr & crPos .~ newPos
+  where
+    newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
+    ls  = nub . concat . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w
+
 collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2
 collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps