Fix leaky path graph creation

src/Dodge/Data.hs

@@ -10,6 +10,7 @@ circular imports are probably not a good idea.
 {-# LANGUAGE DerivingStrategies #-}
 module Dodge.Data 
     ( module Dodge.Data
+    , module Dodge.Data.PathGraph
     , module Dodge.Data.Material
     , module Dodge.Data.LoadAction
     , module Dodge.Data.ForegroundShape
@@ -34,6 +35,7 @@ module Dodge.Data
     , module Dodge.Data.Room
     ) where
 import Dodge.Data.Room
+import Dodge.Data.PathGraph
 import Dodge.Data.Zoning
 import Dodge.Data.ForegroundShape
 import Dodge.Data.LoadAction
@@ -146,7 +148,7 @@ data World = World
     , _shapes               :: IM.IntMap ForegroundShape
     , _corpses              :: IM.IntMap Corpse
     , _clickMousePos        :: Point2
-    , _pathGraph            :: Gr Point2 Float
+    , _pathGraph            :: PathGraph
     , _pathGraphP           :: S.Set (Point2,Point2)
     , _phZoning             :: Zoning [] (Int,Point2)
     , _hud                  :: HUD

src/Dodge/Data/PathGraph.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.PathGraph where
+import Geometry.Data
+import Control.Lens
+import Data.Graph.Inductive
+data PathGraph = PathGraph
+    { _pgGraph      :: Gr Point2 Float
+    , _pgNodeMap    :: NodeMap Point2
+    }
+
+makeLenses ''PathGraph

src/Dodge/Default/World.hs

@@ -18,6 +18,7 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Graph.Inductive.Graph hiding ((&))
+import Data.Graph.Inductive.NodeMap
 --import qualified Data.Vector.Fusion.Stream.Monadic as VS
 defaultWorld :: World
 defaultWorld = World
@@ -72,7 +73,7 @@ defaultWorld = World
     --, _savedWorlds = M.empty
 --    , _menuLayers = []
     , _clickMousePos = V2 0 0
-    , _pathGraph = Data.Graph.Inductive.Graph.empty
+    , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty new
     , _pathGraphP   = mempty
     , _phZoning     = Zoning mempty phZoneSize (zonePos snd)
     , _hud = HUD

src/Dodge/Layout.hs

@@ -45,7 +45,7 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _pathGraphP   = pairPath
         }
   where
-    path = pairsToGraph dist pairPath
+    path = pairsToGraph'' pairPath
     pairPath = foldMap _rmPath rs
     rs = map doRoomShift $ IM.elems rs'
     rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w

src/Dodge/Path.hs

@@ -2,8 +2,9 @@ module Dodge.Path
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
-    , removePathsCrossing
+--    , removePathsCrossing
     , pairsToGraph
+    , pairsToGraph''
     , walkableNodeNear
     , nodesNearL
     , getNodePos
@@ -26,26 +27,28 @@ import StreamingHelp
 --import Data.Graph.Inductive.Graph hiding ((&))
 
 getNodePos :: Int -> World -> Maybe Point2
-getNodePos i w = _pathGraph w `lab` i
+getNodePos i w = _pgGraph (_pathGraph w) `lab` i
 
 makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     (na,_) <- walkableNodeNear a w
     (nb,_) <- walkableNodeNear b w
-    sp na nb (_pathGraph w)
+    sp na nb (_pgGraph $ _pathGraph w)
 
 walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
+{-# INLINE walkableNodeNear #-}
 walkableNodeNear p w = minStreamOn (dist p . snd) 
     . S.filter (flip (isWalkable p) w . snd) $ nodesNear p w
 
 nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
+{-# INLINE nodesNear #-}
 nodesNear = aroundPoint _phZoning
 
 nodesNearL :: Point2 -> World -> [(Int,Point2)]
 nodesNearL p = runIdentity . S.toList_ . nodesNear p
 
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
-makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
+makePathBetweenPs a b w = mapMaybe (lab $ _pgGraph $ _pathGraph w) <$> makePathBetween a b w
 
 pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
 pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w
@@ -93,19 +96,35 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --        [] -> return Nothing
 --        _  -> return $ Just $ ns !! i
 --
-pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
-pairsToGraph f pairs = 
-    let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
-        pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
-    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
 
-removePathsCrossing :: Point2 -> Point2 -> World -> World
-removePathsCrossing a b w = w
-    & pathGraph  .~ newGraph 
-    & pathGraphP .~ pg'
-    & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-        (labNodes newGraph)
-  where 
-    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
-   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
-    newGraph = pairsToGraph dist pg'
+pairsToGraph'' :: Set.Set (Point2,Point2) -> PathGraph
+pairsToGraph'' = uncurry PathGraph . pairsToGraph' dist
+
+pairsToGraph' :: Ord a => (a -> a -> b) -> Set.Set (a,a) -> (Gr a b, NodeMap a)
+pairsToGraph' f = runIdentity . S.fold_ g (Data.Graph.Inductive.empty,new) id . S.each
+  where
+    g grnm (x,y) = h' $ h x $ h y grnm
+      where
+        h' (gr,nm) = (insMapEdge nm (x,y,f x y) gr , nm)
+        h n (gr,nm) = (gr',nm')
+          where
+            (gr',nm',_) = insMapNode nm n gr
+
+pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
+pairsToGraph f pairs = undir
+    $ run_ Data.Graph.Inductive.empty 
+    $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
+  where
+    nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
+    pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
+
+--removePathsCrossing :: Point2 -> Point2 -> World -> World
+--removePathsCrossing a b w = w
+--    & pathGraph  .~ newGraph 
+--    & pathGraphP .~ pg'
+--    & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+--        (labNodes newGraph)
+--  where 
+--    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
+--   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
+--    newGraph = pairsToGraph'' dist pg'

src/Dodge/Placement/PlaceSpot.hs

@@ -120,9 +120,10 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
     (evaluatedType, g) = runState rgen (_randGen w)
 
 placeWallPoly :: [Point2] -> Wall -> World -> World
-placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
-  where
-    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+placeWallPoly ps wl = over walls (placeWalls ps wl)
+--placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
+--  where
+--    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
 
 placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
 placeWalls qs wl wls = foldl' (addPane wl) wls pairs

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -55,7 +55,8 @@ addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
 placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
 placeBlock poly bl wl w 
-    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+--    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+    = (0, wWithBlock)
   where 
     pairs = loopPairs poly
     wWithBlock = addBlock poly wl bl w
@@ -70,7 +71,8 @@ placeLineBlock
     -> World 
     -> (Int, World)
 placeLineBlock basePane blockWidth depth a b gw = ( 0 
-    , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
+    , (foldr insertWall (insertBlocks gw) listWalls)
+--    , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
     )
   where 
     psOnLine = divideLineOddNumPoints blockWidth a b

src/Dodge/Render/ShapePicture.hs

@@ -269,7 +269,7 @@ drawPathing w = setLayer DebugLayer $
         <> concatMap dispInc (graphToIncidence gr)
   where
     dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
-    gr = _pathGraph w
+    gr = _pgGraph $ _pathGraph w
 
 crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
 crDisplayInfo cfig w cr