Store paths crossing block walls in block

src/Dodge/Data.hs

@@ -151,6 +151,7 @@ data World = World
     , _pathGraph            :: Gr Point2 PathEdge
     , _pathGraphP           :: S.Set (Point2,Point2)
     , _pnZoning             :: Zoning [] (Int,Point2)
+    , _peZoning             :: Zoning [] (Int,Int,PathEdge)
     , _hud                  :: HUD
     , _lightSources         :: IM.IntMap LightSource
     , _tempLightSources     :: [TempLightSource]
@@ -951,6 +952,7 @@ data Block = Block
     , _blDir        :: Float
     , _blDraw       :: Block -> SPic
     , _blDeath      :: Block -> World -> World
+    , _blPaths      :: [(Int,Int,PathEdge)]
     }
 data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
   deriving (Eq,Ord,Show)

src/Dodge/Data/PathGraph.hs

@@ -27,3 +27,4 @@ data EdgeObstacle
   deriving (Eq,Ord,Show,Bounded,Enum)
 
 makeLenses ''PathGraph
+makeLenses ''PathEdge

src/Dodge/Default/Block.hs

@@ -15,6 +15,7 @@ defaultBlock = Block
     , _blDraw      = const mempty
     , _blDeath     = makeBlockDebris
     , _blObstructs = []
+    , _blPaths      = []
     }
 defaultDirtBlock :: Block
 defaultDirtBlock = defaultBlock & blHP .~ 50

src/Dodge/Default/World.hs

@@ -77,6 +77,7 @@ defaultWorld = World
     , _pathGraph = Data.Graph.Inductive.Graph.empty
     , _pathGraphP   = mempty
     , _pnZoning     = Zoning mempty wlZoneSize (zonePos snd)
+    , _peZoning     = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0

src/Dodge/Layout.hs

@@ -48,10 +48,10 @@ generateLevelFromRoomList gr' w = initWallZoning
         }
         & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
             (labNodes path))
---        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
---            (labEdges (_pgGraph path)))
+            (labEdges path))
   where
-    path = pairsToGraph 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

@@ -3,7 +3,8 @@ module Dodge.Path
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
-    , removePathsCrossing
+--    , removePathsCrossing
+    , obstructPathsCrossing
     , pairsToGraph
     , getNodePos
     , walkableNodeNear
@@ -96,7 +97,7 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --        [] -> return Nothing
 --        _  -> return $ Just $ ns !! i
 --
-pairsToGraph :: Set.Set (Point2,Point2) -> Gr Point2 PathEdge
+pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge)
 pairsToGraph pairs = addEdges nodemap gr $ S.each pairs
   where
     (nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs)
@@ -110,12 +111,29 @@ addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id
     f (nodemap,i,gr) p = case nodemap M.!? p of
         Just _  -> (nodemap,i,gr)
         Nothing -> (nodemap & at p ?~i ,i+1, insNode (i,p) gr)
-addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) -> Gr Point2 PathEdge
+addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) 
-addEdges nodemap gr = runIdentity . S.fold_ f gr id
+    -> (Map (V2 Point2) (Int,Int,PathEdge) , Gr Point2 PathEdge)
+addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
   where
-    f gr' (a,b) = insEdge (g a,g b,PathEdge a b (dist a b) mempty) gr'
+    f (edgemap,gr') (a,b) = (M.insert (V2 a b) theedge edgemap
+        , insEdge theedge gr'
+        )
+      where
+        theedge = (g a,g b,PathEdge a b (dist a b) mempty)
     g a = nodemap M.! a
 
+obstructPathsCrossing :: Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
+obstructPathsCrossing sp ep w = 
+    ( w & pathGraph %~ updateedges
+    , runIdentity $ S.toList_ edges
+    )
+  where
+    edges = S.filter edgecrosses $ nearSeg _peZoning sp ep w
+    edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe)
+    updateedges gr = runIdentity $ S.fold_ updateedge gr id edges
+    updateedge gr (x,y,pe) 
+        = insEdge (x,y,pe & peObstacles . at BlockObstacle .~ Just ()) $ delEdge (x,y) gr
+
 removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = w
 --    & pathGraph  .~ newGraph 

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)
+placeWallPoly ps wl = -- rmCrossPaths . 
-  where
+    over walls (placeWalls ps wl)
-    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+--  where
+--    rmCrossPaths w = foldr (uncurry obstructPathsCrossing) 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

@@ -25,13 +25,13 @@ plBlock
     -> (Int,World)
 plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
 plBlock (p:ps) bl wl w = (,) blid $ w
-    & flip (foldr insertWall) wls
     & blocks . at blid ?~ bl 
         { _blID = blid
         , _blWallIDs = IS.fromList is
         , _blShadows = []
         , _blFootprint = p:ps
         }
+    & insertWalls blid wls
   where 
     blid = IM.newKey $ _blocks w
     lns = zip (p:ps) (ps ++ [p])
@@ -51,7 +51,8 @@ plLineBlock
     -> World 
     -> (Int, World)
 plLineBlock basePane blwidth a b gw = ( 0 
-    , foldr insertWall (insertBlocks gw) listWalls
+--    , foldr insertWall (insertBlocks gw) listWalls
+    , insertBlocks gw
     )
   where 
     depth = blwidth
@@ -65,13 +66,17 @@ plLineBlock basePane blwidth a b gw = ( 0
     linesAt p = loopPairs $ cornersAt p
     wlid = IM.newKey $ _walls gw
     blid = IM.newKey $ _blocks gw
-    insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block 
+    insertBlock (i,p) = 
+        insertWalls (i + blid) (makeWallAt p i)
+        . (over blocks $ IM.insert (i+blid) Block 
         { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
         , _blHP = 1000, _blShadows = shadowsAt i
         , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
         , _blObstructs = []
+        , _blPaths = []
         , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
+        )
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
     ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
     visibilityAt i 
@@ -91,6 +96,12 @@ plLineBlock basePane blwidth a b gw = ( 0
         }
     listWalls = concat $ zipWith makeWallAt blockCenPs is
 
-insertWall :: Wall -> World -> World
+-- | Must be done after inserting the block
-insertWall wl = (walls . at (_wlID wl) ?~ wl)
+insertWalls :: Int -> [Wall] -> World -> World
---    . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl)
+insertWalls blid wls w = w' & blocks . ix blid . blPaths .~ concat paths
+  where
+    (w',paths) = mapAccumR (flip insertWall) w wls
+
+insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)])
+insertWall wl = uncurry obstructPathsCrossing (_wlLine wl)
+    . (walls . at (_wlID wl) ?~ wl)