Tweak pathfinding

src/Dodge/Data.hs

@@ -76,7 +76,7 @@ import GHC.Generics
 import Control.Lens
 import Control.Monad.State
 import System.Random
-import Data.Graph.Inductive
+--import Data.Graph.Inductive
 import qualified Data.Set as S
 import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM

src/Dodge/Layout.hs

@@ -5,6 +5,7 @@ module Dodge.Layout
 import Data.Tile
 import Dodge.Data
 import Dodge.Path
+import Dodge.Zone.Update
 import Dodge.ShiftPoint
 import Dodge.Placement.PlaceSpot
 --import Dodge.LevelGen.Data
@@ -21,6 +22,7 @@ import qualified IntMapHelp as IM
 import Tile
 import RandomHelp
 
+import Data.Graph.Inductive (labNodes)
 import Data.List (nubBy)
 import Data.Traversable
 import Control.Lens
@@ -44,6 +46,8 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _pathGraph    = path
         , _pathGraphP   = pairPath
         }
+        & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labNodes (_pgGraph path))
   where
     path = pairsToGraph'' pairPath
     pairPath = foldMap _rmPath rs

src/Dodge/Path.hs

@@ -1,8 +1,9 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Path 
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
---    , removePathsCrossing
+    , removePathsCrossing
     , pairsToGraph
     , pairsToGraph''
     , walkableNodeNear
@@ -101,14 +102,15 @@ 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
+pairsToGraph' f pairset = ngr'
   where
-    g grnm (x,y) = h' $ h x $ h y grnm
+    nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
-      where
+    getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
-        h' (gr,nm) = (insMapEdge nm (x,y,f x y) gr , nm)
+    ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
-        h n (gr,nm) = (gr',nm')
+    ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
-          where
+    insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
-            (gr',nm',_) = insMapNode nm n gr
+    insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
+    fstsnd (a,b,_) = (a,b)
 
 pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
 pairsToGraph f pairs = undir
@@ -118,13 +120,30 @@ pairsToGraph f pairs = undir
     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 :: Point2 -> Point2 -> World -> World
---removePathsCrossing a b w = w
+removePathsCrossing a b w = w
+--    & pathGraph . pgGraph %~ deleteEdges
+--    & pathGraphP %~ deletePairs
 --    & pathGraph  .~ newGraph 
 --    & pathGraphP .~ pg'
 --    & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
 --        (labNodes newGraph)
---  where 
+  where
+    thegr = _pgGraph (_pathGraph w)
+    ns = nearSeg _phZoning a b w
+    pairs = S.filter testEdge $ S.for ns (nodePairs thegr)
+    testEdge ((_,p),(_,q)) = isJust $ intersectSegSeg a b p q
+    deleteEdges gr = runIdentity $ S.fold_ deleteEdge gr id pairs
+    deleteEdge gr ((x,_),(y,_)) = delEdge (x,y) $ delEdge (y,x) gr
+--    deletePairs s = runIdentity $ S.fold_ deletePair s id pairs
+--    deletePair s (x,y) = Set.delete (x,y) $ Set.delete (y,x) s
+
+nodePairs :: Gr a b -> (Int,a) -> StreamOf ((Int,a),(Int,a))
+nodePairs gr (n,p) = S.mapMaybe (fmap ((n,p),) . nodeLabel gr) . S.each $ neighbors gr n
+
+nodeLabel :: Gr a b -> Int -> Maybe (Int, a)
+nodeLabel gr n = (n,) <$> lab gr n
+
 --    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,10 +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 = over walls (placeWalls ps wl)
+--placeWallPoly ps wl = over walls (placeWalls ps wl)
---placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
+placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
---  where
+  where
---    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+    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,8 +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)
+--    = (0, wWithBlock)
   where 
     pairs = loopPairs poly
     wWithBlock = addBlock poly wl bl w

src/Dodge/Render/ShapePicture.hs

@@ -30,6 +30,7 @@ import Geometry.ConvexPoly
 --import Data.Foldable
 import qualified Data.IntMap.Strict as IM -- Lazy?
 import qualified Data.Map.Strict as M
+import qualified Data.Set as Set
 import Control.Lens
 import Data.Maybe
 import qualified Streaming.Prelude as S
@@ -266,6 +267,7 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
 drawPathing :: World -> Picture
 drawPathing w = setLayer DebugLayer $ 
         (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
+        --(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w)
         <> concatMap dispInc (graphToIncidence gr)
   where
     dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n

src/Dodge/Zone.hs

@@ -3,6 +3,7 @@ module Dodge.Zone
     , zoneAroundPoint
     , aroundPoint
     , nearPoint
+    , nearSeg
     , wlsNearPoint
     , crsNearPoint
     , clsNearPoint