Hack solution to path graph space leak: evaluate all edge obstacles

src/Dodge/Debug/Picture.hs

@@ -209,11 +209,12 @@ drawPathBetween u = concat $ do
     let nodepos = (`getNodePos` w)
         nodelist = makePathBetween sp ep w
     return . setLayer DebugLayer $
-             color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
+             --color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
+             color rose (foldMap (arrowPath . map nodepos) nodelist)
             <> drawCrossCol green sp
             <> drawCrossCol cyan ep
-            <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
-            <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
+            <> foldMap (color green . arrow sp) (nodepos <$> walkableNodeNear w sp)
+            <> foldMap (color cyan . flip arrow ep) (nodepos <$> walkableNodeNear w ep)
             <> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
   where
     w = u ^. uvWorld
@@ -403,14 +404,11 @@ drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls
 drawPathing :: Config -> World -> Picture
 drawPathing cfig w = setLayer DebugLayer $ ifoldMap f $ w ^. cWorld . incGraph
   where
-    inodes = w ^. cWorld . incNode
-    --f i = foldMap (g i)
-    --g i (j,se) = edgeToPic (screenPolygon cfig (w ^.wCam)) 
-    --    (inodes ^?! ix i) (inodes ^?! ix j) (se ^. seObstacles)
+    inode i = w ^?! cWorld . incNode . ix i
     f :: Int -> IM.IntMap SimpleEdge -> Picture
     f i = ifoldMap (g i)
     g i j se = edgeToPic (screenPolygon cfig (w ^.wCam)) 
-        (inodes ^?! ix i) (inodes ^?! ix j) (se ^. seObstacles)
+        (inode i) (inode j) (se ^. seObstacles)
 
 edgeToPic :: [Point2] -> Point2 -> Point2 -> S.Set EdgeObstacle -> Picture
 edgeToPic poly sp ep pe

src/Dodge/Path.hs

@@ -8,7 +8,7 @@ module Dodge.Path (
     walkableNodeNear,
     snapToGrid,
     pairsToIncGraph,
-    updateEdge,
+--    updateEdge,
     getEdgesCrossing,
 ) where
 
@@ -35,16 +35,8 @@ import Geometry
 import qualified IntMapHelp as IM
 import Linear
 
-getNodePos :: Int -> World -> Maybe Point2
-getNodePos i w = w ^? cWorld . incNode . ix i
-
---getEdgesCrossingPoly :: [Point2] -> World -> [(Int,Int)]
---getEdgesCrossingPoly ps w = filter tcross $ zonesExtract (w ^. incEdgeZoning)
---    $ Set.toList $ foldMap (uncurry $ zoneOfSegSet peZoneSize) $ pairs
---  where
---    pairs = loopPairs ps
---    tcross (i,j) = any (isJust . uncurry (intersectSegSeg (f i) (f j))) pairs
---    f i = w ^?! cWorld . incNode . ix i
+getNodePos :: Int -> World -> Point2
+getNodePos i w = w ^?! cWorld . incNode . ix i
 
 getEdgesCrossing :: Point2 -> Point2 -> World -> [(Int,Int)]
 getEdgesCrossing s e w = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w
@@ -67,10 +59,6 @@ makePathUsing t s e w = do
     let h i = distance (getn nb) (getn i)
     (na :) . snd <$> AS.aStarAssoc getes h (== nb) na
   where
---    g (i, SimpleEdge c o)
---        | t o = Just (i, c)
---        | otherwise = Nothing
-    --getes i = mapMaybe g $ w ^?! cWorld . incGraph . ix i
     getes i = IM.toList 
         . IM.map (^. seDist)
         . IM.filter (^. seObstacles . to t) $ w ^?! cWorld . incGraph . ix i
@@ -98,7 +86,7 @@ smallSnailInt2 =
         [V2 x y | x <- [-2 .. 2], y <- [-2 .. 2]]
 
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
-makePathBetweenPs a b w = traverse (`getNodePos` w) =<< makePathBetween a b w
+makePathBetweenPs a b w = fmap (`getNodePos` w) <$> makePathBetween a b w
 
 -- assumes that pathfinding is symmetric
 pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2

src/Dodge/TestString.hs

@@ -29,9 +29,11 @@ import qualified IntMapHelp as IM
 import qualified Data.Map.Strict as M
 import NewInt
 import Data.Foldable
+import Data.Monoid
 
 testStringInit :: Universe -> [String]
-testStringInit _ = [] 
+testStringInit u = [show $ foldMap (foldMap (Sum . length . (^. seObstacles))) 
+    $ u ^. uvWorld . cWorld . incGraph]
     -- foldMap prettyShort $ u ^? uvWorld . cWorld . lWorld . machines . ix 0 . mcType . _McProxSensor
 --testStringInit u = foldMap prettyShort $ u ^.. uvWorld . cWorld . lWorld . machines
 

src/Dodge/Update/WallDamage.hs

@@ -1,47 +1,41 @@
 module Dodge.Update.WallDamage (updateWallDamages, updateEdgesWall) where
 
-import Dodge.Wall.Pathing
-import Geometry.Data
 import Control.Lens
 import Data.Foldable
 import Data.Maybe
 import qualified Data.Set as S
 import Dodge.Data.World
-import Dodge.Path
 import Dodge.Wall.Damage
+import Dodge.Wall.Pathing
 import Dodge.WorldEvent.ThingsHit
 import Dodge.Zoning.Base
+import Geometry.Data
 import qualified IntMapHelp as IM
 
 updateWallDamages :: World -> World
 updateWallDamages w =
-    let (is, w') =
-            IM.foldlWithKey' f (mempty, w) (w ^. cWorld . lWorld . wallDamages)
-     in updateEdgesWall is
-            w'
-            & cWorld . lWorld . wallDamages .~ IM.empty
+    let (is, w') = IM.foldlWithKey' f (mempty, w) (w ^. cWorld . lWorld . wallDamages)
+     in updateEdgesWall is w' & cWorld . lWorld . wallDamages .~ IM.empty
   where
     f isw k dams = fromMaybe isw $ do
         wl <- isw ^? _2 . cWorld . lWorld . walls . ix k
         return $ foldl' (flip (`damageWall` wl)) isw dams
 
 updateEdgesWall :: S.Set Int2 -> World -> World
-updateEdgesWall is w = updateEdgesWall'
-            (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is) w
+updateEdgesWall is w =
+    updateEdgesWall'
+        (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is)
+        w
 
 updateEdgesWall' :: S.Set (Int, Int) -> World -> World
 updateEdgesWall' = flip $ foldl' updateEdgeWallObs
 
---updateEdgeWallObs :: World -> (Int, Int) -> World
---updateEdgeWallObs w (i, j) = w
-
 updateEdgeWallObs :: World -> (Int, Int) -> World
-updateEdgeWallObs w (i, j) = fromMaybe w $ do
-    s <- getNodePos i w
-    e <- getNodePos j w
-    let wlflags = foldMap (^. _2 . to getWallPathing) $ wlsHitUnsorted s e w
-    return $ w & cWorld . incGraph %~ updateEdge (f wlflags) (i, j)
+updateEdgeWallObs w (i, j) = w & cWorld . incGraph . ix i . ix j . seObstacles %~ f wlflags
   where
---    f x _ = S.map WallObstacle x 
-    f x y = S.map WallObstacle x `S.union` 
-        (y S.\\ (S.fromList $ map WallObstacle [minBound..maxBound]))
+    s = w ^?! cWorld . incNode . ix i
+    e = w ^?! cWorld . incNode . ix j
+    wlflags = foldMap (^. _2 . to getWallPathing) $ wlsHitUnsorted s e w
+    f x =
+        (`S.union` S.map WallObstacle x)
+            . (S.\\ (S.fromList $ map WallObstacle [minBound .. maxBound]))