Improve xIntercepts (still not perfect)

src/Dodge/Update.hs

@@ -3,6 +3,11 @@
 
 module Dodge.Update (updateUniverse) where
 
+import Dodge.Zoning.Pathing
+import Dodge.Debug.Picture
+import Dodge.Zoning.Base
+import Dodge.Path
+import Data.Foldable
 import qualified Data.Set as S
 import Color
 import Control.Applicative
@@ -247,7 +252,8 @@ functionalUpdate =
         . over uvWorld updateCreatureSoundPositions
         . colCrsWalls
         . over uvWorld simpleCrSprings
-        . over uvWorld (updateIMl' (_doors . _lWorld . _cWorld) updateDoor)
+--        . over uvWorld (updateIMl' (_doors . _lWorld . _cWorld) updateDoor)
+        . over uvWorld updateDoors
         . over uvWorld doWorldEvents
         . over uvWorld updateDelayedEvents
         . over
@@ -307,6 +313,27 @@ updateAimPos u =
     u & uvWorld . cWorld . lWorld . lAimPos
         .~ mouseWorldPos (u ^. uvWorld . input) (u ^. uvWorld . wCam)
 
+updateEdgesWall :: S.Set (Int,Int) -> World -> World
+updateEdgesWall = flip $ foldl' updateEdgeWallObs
+
+updateEdgeWallObs :: World -> (Int,Int) -> World
+updateEdgeWallObs w (i,j) = fromMaybe w $ do
+    s <- getNodePos i w
+    e <- getNodePos i w
+    let wls = snd <$> wlsHitUnsorted s e w
+    return $ w & cWorld . incGraph %~ updateEdge (f wls) (i,j)
+  where
+    f wls = at DoorObstacle ?~ ()
+--        | all _wlWalkable wls = (at BlockObstacle .~ Nothing) . (at DoorObstacle .~ Nothing)
+--        | otherwise = at DoorObstacle ?~ ()
+
+updateDoors :: World -> World
+updateDoors w = let (is,w') = foldrM doDrWdWd' w (w ^. cWorld . lWorld . doors)
+    in updateEdgesWall (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is) w'
+        & cWorld . lWorld . flares <>~ foldMap (drawZoneCol green peZoneSize) is
+--updateDoors w = uncurry updateEdgesWall .
+--    over _1 (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList)) $ foldrM doDrWdWd' w (w ^. cWorld . lWorld . doors)
+
 updateDoor :: Door -> World -> World
 updateDoor dr = doDrWdWd (_drMech dr) dr
 
@@ -534,6 +561,14 @@ updateIMl fim fup w = alaf Endo foldMap (dbArg fup) (fim w) w
 updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
 updateIMl' fim fup w = alaf Endo foldMap fup (fim w) w
 
+updateAccum :: (Foldable f, Monoid m) 
+    => (World -> f a) 
+    -> (a -> World -> (m, World))
+    -> World 
+    -> (m, World)
+updateAccum fim fup w = foldrM fup w (fim w)
+    --alaf Endo foldMap fup (fim w) w
+
 updateCreatureGroups :: World -> World
 updateCreatureGroups w =
     w & cWorld . lWorld . creatureGroups