From 1abcf099e2644dfe6bb39076f9c7af9b300da6f6 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Wed, 29 Jun 2022 23:17:45 +0100
Subject: [PATCH] Fix leaky path graph creation

---
 src/Dodge/Data.hs                      |  4 +-
 src/Dodge/Data/PathGraph.hs            | 12 ++++++
 src/Dodge/Default/World.hs             |  3 +-
 src/Dodge/Layout.hs                    |  2 +-
 src/Dodge/Path.hs                      | 57 +++++++++++++++++---------
 src/Dodge/Placement/PlaceSpot.hs       |  7 ++--
 src/Dodge/Placement/PlaceSpot/Block.hs |  6 ++-
 src/Dodge/Render/ShapePicture.hs       |  2 +-
 8 files changed, 65 insertions(+), 28 deletions(-)
 create mode 100644 src/Dodge/Data/PathGraph.hs

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index cb82f08f7..a109594e2 100644
--- a/src/Dodge/Data.hs
+++ b/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
diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs
new file mode 100644
index 000000000..5b318938e
--- /dev/null
+++ b/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
diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs
index 1cf614096..fc237cf73 100644
--- a/src/Dodge/Default/World.hs
+++ b/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
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index 235f1d797..056f8df8a 100644
--- a/src/Dodge/Layout.hs
+++ b/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
diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index dd1517f17..f1ee3529c 100644
--- a/src/Dodge/Path.hs
+++ b/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'
diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs
index 5663cb04f..c793ceb37 100644
--- a/src/Dodge/Placement/PlaceSpot.hs
+++ b/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
diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs
index 671fcd3a1..abb72b7de 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/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
diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 62bdc0c30..8e2c7e2a0 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ 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