Store paths crossing block walls in block

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 = -- rmCrossPaths . 
+    over walls (placeWalls ps wl)
+--  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
-insertWall wl = (walls . at (_wlID wl) ?~ wl)
---    . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl)
+-- | Must be done after inserting the block
+insertWalls :: Int -> [Wall] -> World -> World
+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)