Make obstacles block pathing

src/Dodge/Config/Data.hs

@@ -45,6 +45,7 @@ data DebugBool
     | Show_select
     | Inspect_wall
     | Show_nodes_near_select
+    | Show_path_between
   deriving (Generic, Eq,Ord,Bounded, Enum, Show)
 data ResFactor = FullRes | HalfRes | QuarterRes
   deriving (Generic, Show, Eq, Ord, Enum, Bounded)

src/Dodge/Data/PathGraph.hs

@@ -22,6 +22,7 @@ data EdgeObstacle
     = BlockObstacle
     | DoorObstacle
     | AutoDoorObstacle
+    | WallObstacle
   deriving (Eq,Ord,Show,Bounded,Enum)
 
 makeLenses ''PathGraph

src/Dodge/Default/World.hs

@@ -19,7 +19,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 Data.Graph.Inductive.NodeMap
 --import qualified Data.Vector.Fusion.Stream.Monadic as VS
 defaultWorld :: World
 defaultWorld = World

src/Dodge/Path.hs

@@ -3,7 +3,6 @@ module Dodge.Path
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
-    , removePathsCrossing
     , pairsToGraph
     , pairsToGraph''
     , walkableNodeNear
@@ -38,7 +37,9 @@ 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 (second pathDist $ _pgGraph $ _pathGraph w)
+    sp na nb (second pathDist $ efilter noobstacle $ _pgGraph $ _pathGraph w)
+  where
+    noobstacle (_,_,PathEdge _ _ s) = null s
 
 pathDist :: PathEdge -> Float
 pathDist pe = dist (_peStart pe) (_peEnd pe)
@@ -170,33 +171,6 @@ addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2
     -> World
     -> World
 addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
-  where
-    paths = S.filter f $ nearSeg _peZoning a b w
-    f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
-
-removePathsCrossing :: Point2 -> Point2 -> World -> World
-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
-    thegr = _pgGraph (_pathGraph w)
-    ns = nearSeg _pnZoning 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]

src/Dodge/Placement/PlaceSpot.hs

@@ -123,7 +123,7 @@ placeWallPoly :: [Point2] -> Wall -> World -> World
 --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
+    rmCrossPaths w = foldr (uncurry (addObstacleCrossing' WallObstacle)) 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

@@ -71,8 +71,8 @@ placeLineBlock
     -> World 
     -> (Int, World)
 placeLineBlock basePane blockWidth depth a b gw = ( 0 
-    , (foldr insertWall (insertBlocks gw) listWalls)
---    , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
+--    , (foldr insertWall (insertBlocks gw) listWalls)
+    , addObstacleCrossing' BlockObstacle a b (foldr insertWall (insertBlocks gw) listWalls)
     )
   where 
     psOnLine = divideLineOddNumPoints blockWidth a b

src/Dodge/Render/ShapePicture.hs

@@ -30,7 +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 qualified Data.Set as Set
 import Control.Lens
 import Data.Maybe
 import qualified Streaming.Prelude as S
@@ -113,21 +113,26 @@ debugDraw' cfig w bl = case bl of
     Walls_info              -> Right $ drawWlIDs cfig w
     Pathing                 -> Right $ drawPathing cfig w
     Show_nodes_near_select  -> Right $ drawNodesNearSelect w
+    Show_path_between       -> Right $ drawPathBetween w
 
 drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 
+drawPathBetween :: World -> Picture
+drawPathBetween w = color yellow 
+    $ foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w)
+  where
+    sp = _lSelect w
+    ep = _rSelect w
+
 drawNodesNearSelect :: World -> Picture
 drawNodesNearSelect w = setLayer DebugLayer $
      runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
     <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
     <> color green (drawCross sp)
     <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
-    <> color yellow (foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w))
   where
     sp = _lSelect w
-    ep = _rSelect w
-
 
 drawInspectWalls :: World -> Picture
 drawInspectWalls w = foldMap (drawInspectWall w)