Correctly set obstacle when creating block

src/Dodge/Path.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Path 
     ( pointTowardsImpulse
     , makePathBetween
@@ -118,7 +118,7 @@ toPathEdge sp' ep = PathEdge sp' ep mempty
 
 insertEdges :: (Point2 -> Point2 -> b) 
     -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int -> (Gr Point2 b,Map (V2 Point2) Int2)
-insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ (S.each pairset)
+insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ S.each pairset
   where
     insertedge (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
         , M.insert (V2 a b) (V2 (f a) (f b)) em)

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -9,23 +9,22 @@ import Dodge.Path
 import Dodge.Block.Debris
 --import Dodge.LevelGen.LevelStructure
 import Dodge.Base
-import Dodge.Zone
+--import Dodge.Zone
 import Geometry
 import qualified IntMapHelp as IM
 
 import Control.Lens
-import Data.List
 import qualified Data.IntSet as IS
 
-addBlock 
+placeBlock 
     :: [Point2]     -- ^ Block polygon
-    -> Wall         -- ^ Base Pane
     -> Block
+    -> Wall         -- ^ Base Pane
     -> World 
-    -> World
-addBlock (p:ps) wl bl w = w
-    & wlZoning . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
-    & walls  %~ IM.union panes
+    -> (Int,World)
+placeBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
+placeBlock (p:ps) bl wl w = (,) blid $ w
+    & flip (foldr insertWall) wls
     & blocks %~ IM.insert blid bl 
         {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[]
             , _blFootprint = p:ps
@@ -35,32 +34,14 @@ addBlock (p:ps) wl bl w = w
     lns = zip (p:ps) (ps ++ [p])
     i = IM.newKey $ _walls w
     is = [i.. i + length lns-1]
-    panes = IM.fromList $ zipWith 
-        (\j (a,b) -> (,) j wl 
+    wls = zipWith 
+        (\j (a,b) -> wl 
             { _wlLine = (a,b)
             , _wlID = j
             , _wlStructure = BlockPart blid
             }
-        ) is lns
-    wallInZone wl'
-        | uncurry dist (_wlLine wl') <= 2*wlZoneSize 
-            = insertIMInZone x y wlid wl'
-        | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips
-      where 
-        V2 x y = wlZoneOfPoint $ uncurry midPoint (_wlLine wl)
-        wlid  = _wlID wl
-        ips = map (unv2 . wlZoneOfPoint) $ uncurry (divideLine (2*wlZoneSize)) (_wlLine wl)
-        unv2 (V2 x' y') = (x',y')
-addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
+        ) is lns 
         
-placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
-placeBlock poly bl wl w 
-    = (0, foldr (uncurry (addObstacleCrossing' BlockObstacle)) wWithBlock pairs)
---    = (0, wWithBlock)
-  where 
-    pairs = loopPairs poly
-    wWithBlock = addBlock poly wl bl w
-
 {- | Splits a line into many four cornered blocks. -}
 placeLineBlock 
     :: Wall     -- ^ Base pane
@@ -71,8 +52,7 @@ placeLineBlock
     -> World 
     -> (Int, World)
 placeLineBlock basePane blockWidth depth a b gw = ( 0 
---    , (foldr insertWall (insertBlocks gw) listWalls)
-    , addObstacleCrossing' BlockObstacle a b (foldr insertWall (insertBlocks gw) listWalls)
+    , foldr insertWall (insertBlocks gw) listWalls
     )
   where 
     psOnLine = divideLineOddNumPoints blockWidth a b
@@ -109,4 +89,7 @@ placeLineBlock basePane blockWidth depth a b gw = ( 0
         ,_wlDraw = visStatus
         }
     listWalls = concat $ zipWith makeWallAt blockCenPs is
-    insertWall wl = over walls $ IM.insert (_wlID wl) wl
+
+insertWall :: Wall -> World -> World
+insertWall wl = (walls . at (_wlID wl) ?~ wl)
+    . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl)

src/Dodge/Render/ShapePicture.hs

@@ -35,6 +35,7 @@ import Control.Lens
 import Data.Maybe
 import qualified Streaming.Prelude as S
 import qualified Data.Graph.Inductive as FGL
+import qualified Data.Set as Set
 
 -- TODO only filter out shapes outside the range of the furthest shown light source
 worldSPic :: Configuration -> World -> SPic
@@ -119,9 +120,13 @@ 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)
+drawPathBetween w = setLayer DebugLayer
+    $  color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist)
+    <> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0)
+    <> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just)
   where
+    nodepos = (`getNodePos` w)
+    nodelist = makePathBetween sp ep w
     sp = _lSelect w
     ep = _rSelect w
 
@@ -274,17 +279,21 @@ edgeToPic :: [Point2] -> PathEdge -> Picture
 edgeToPic poly pe
     | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
     | null $ _peObstacles pe 
-                = color green $ arrow sp ep
-    | otherwise = color red   $ arrow sp ep
+                = anarrow green
+    | hasobstacle BlockObstacle  
+                = anarrow red
+    | hasobstacle AutoDoorObstacle = anarrow yellow
+    | otherwise = anarrow cyan
   where
+    hasobstacle = (`Set.member` _peObstacles pe)
+    anarrow col = color col $ arrow sp ep
     sp = _peStart pe
     ep = _peEnd pe
 
 drawPathing :: Configuration -> World -> Picture
-drawPathing cfig w = setLayer DebugLayer $ 
-        (foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) $ FGL.labEdges gr)
-        --(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w)
-        <> concatMap dispInc (graphToIncidence gr)
+drawPathing cfig w = setLayer DebugLayer
+    $  foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
+    <> concatMap dispInc (graphToIncidence gr)
   where
     dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
     gr = _pgGraph $ _pathGraph w

src/Picture.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns  #-}
+--{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE BangPatterns  #-}
 module Picture
     ( module Picture.Data
     , module Picture.Base