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

@@ -50,19 +50,20 @@ defaultDoor = Door { _wlLine = [(0,0),(50,0)]
                    }
 defaultCreature :: Creature
 defaultCreature = Creature
-    { _crPos = (0,0)
+    { _crPos    = (0,0)
     , _crOldPos = (0,0)
-    , _crDir = 0
+    , _crVel    = (0,0)
-    , _crID = 1
+    , _crDir    = 0
-    , _crPict = const $ onLayer CrLayer $ circleSolid 10
+    , _crID     = 1
+    , _crPict   = const $ onLayer CrLayer $ circleSolid 10
     , _crUpdate = \ w f cr -> (f , Just cr)
-    , _crRad = 10
+    , _crRad    = 10
-    , _crMass = 10
+    , _crMass   = 10
-    , _crHP = 100
+    , _crHP     = 100
-    , _crMaxHP = 150
+    , _crMaxHP  = 150
-    , _crInv = IM.empty
+    , _crInv    = IM.empty
     , _crInvSel = 0
-    , _crState = defaultState
+    , _crState  = defaultState
     , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
     , _crIsAnimate = True
     }

src/Dodge/Update.hs

@@ -45,7 +45,7 @@ update w
                              . wallEvents
                              . set worldEvents id 
                              $ _worldEvents w1 w1
-    where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
+  where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
           --               w
           -- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
           --                   = insertIMInZone x y wlid wl
@@ -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,23 +14,18 @@ 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 
+        collideCorners rad p1 wallPoints
-    | p1 == p2 = c
+        . collideWalls rad p1 ls 
-    | otherwise = over crPos ( 
+        . checkPushThroughs rad p1 ls 
-                              collideCorners rad p1 wallPoints
+  where 
-                             . 
+    rad = _crRad c + wallBuffer
-                               collideWalls rad p1 ls 
+    p1  = _crOldPos c
-                             . checkPushThroughs rad p1 ls 
+    p2  = _crPos c
-                             ) 
+    ls  = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
-                       c 
+    wallPoints = nub $ concat 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
+-- 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