Implement moving wall push and crush

src/Dodge/Data.hs

@@ -128,6 +128,7 @@ data TempLightSource = TLS
 data Creature = Creature
     { _crPos        :: Point2
     , _crOldPos     :: Point2
+    , _crVel        :: Point2
     , _crDir        :: Float
     , _crID         :: Int
     , _crPict       :: Creature -> Picture

src/Dodge/Default.hs

@@ -52,6 +52,7 @@ defaultCreature :: Creature
 defaultCreature = Creature
     { _crPos    = (0,0)
     , _crOldPos = (0,0)
+    , _crVel    = (0,0)
     , _crDir    = 0
     , _crID     = 1
     , _crPict   = const $ onLayer CrLayer $ circleSolid 10

src/Dodge/Update.hs

@@ -76,7 +76,10 @@ updateParticles' w = set particles' (catMaybes ps) w'
 
 updateCreatures :: World -> World
 updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
-    where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w
+  where 
+    ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' (setOldPos cr)) (id,_randGen w) 
+                        $ _creatures w
+    setOldPos cr = cr & crOldPos .~ _crPos cr
 
 
 wallEvents :: World -> World

src/Dodge/WallCreatureCollisions.hs

@@ -14,19 +14,14 @@ colCrsWalls :: World -> World
 colCrsWalls w = over creatures (fmap (colCrWall w)) w
 
 colCrWall :: World -> Creature -> Creature
-colCrWall w c = pushOutFromWall w c
+colCrWall w c 
-
+    | p1 == p2  = pushOrCrush ls c
-pushOutFromWall :: World -> Creature -> Creature
+    | otherwise = c & crPos %~
-pushOutFromWall w c 
-    | p1 == p2 = c
-    | otherwise = over crPos ( 
         collideCorners rad p1 wallPoints
-                             . 
+        . collideWalls rad p1 ls 
-                               collideWalls rad p1 ls 
         . checkPushThroughs rad p1 ls 
-                             ) 
+  where 
-                       c 
+    rad = _crRad c + wallBuffer
-    where rad = _crRad c + wallBuffer
     p1  = _crOldPos c
     p2  = _crPos c
     ls  = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
@@ -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
+-- the following tests whether or not a point is on a wall, and if so pushes it
--- places the circle accordingly.
+-- out from the wall
--- It supposes that the circle will only interact with at most two walls.
+-- If the resultant push out is itself on another wall, the original point is
--- the reverse prevents the collision from happening again with the first wall,
+-- returned
--- when two walls are collided with
 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)
+pushOutFromWall :: Float -> Point2 -> [Point2] -> Maybe (Point2)
-collideWall rad cp1 cp2 (wp1:wp2:_) 
+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