Commit before adjusting wall zoning

src/Dodge/Data.hs

@@ -948,6 +948,7 @@ data Block = Block
     , _blHP         :: Int
     , _blShadows    :: [Int]   -- a list of blocks/walls? that are not shown when this block exists
     , _blFootprint  :: [Point2]
+    , _blObstructs  :: [(Point2,Point2)]
     , _blPos        :: Point2
     , _blDir        :: Float
     , _blDraw       :: Block -> SPic
@@ -1408,8 +1409,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutCoord Point2
     | PutMod Modification
     | PutTrigger (World -> Bool)
-    | PutLineBlock {_putWall :: Wall , _putWidth :: Float
+    | PutLineBlock {_putWall :: Wall , _putStartPoint :: Point2, _putEndPoint :: Point2}
-        , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutSlideDr Door Wall Float Point2 Point2
     | PutDoor Color (World -> Bool) [(Point2,Point2)]

src/Dodge/Data/PathGraph.hs

@@ -10,7 +10,7 @@ data PathGraph = PathGraph
     { _pgGraph      :: Gr Point2 PathEdge
     , _pgNodeMap    :: Map Point2 Int
     , _pgNodeCount  :: Int
-    , _pgEdgeMap    :: Map (V2 Point2) Int2
+    , _pgEdgeMap    :: Map (V2 Point2) (Int,Int,PathEdge)
     }
 data PathEdge = PathEdge
     {_peStart :: Point2

src/Dodge/Default/Block.hs

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

src/Dodge/Path.hs

@@ -117,11 +117,12 @@ toPathEdge :: Point2 -> Point2 -> PathEdge
 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)
+    -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int 
+    -> (Gr Point2 b, Map (V2 Point2) (Int,Int,b))
 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)
+        , M.insert (V2 a b) (f a,f b,efunc a b) em)
     f a = nm M.! a
 
 insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)

src/Dodge/Placement/Instance/Wall.hs

@@ -35,23 +35,22 @@ singleBlock a =
     ]
 {-
 Places a line of blocks between two points.
-Width 9, also extends out from each point by 9.
  -}
 blockLine :: Point2 -> Point2 -> Placement
-blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
+blockLine a b = sps0 $ PutLineBlock baseBlockPane a b
 
 {-
 Places an breakable window between two points.
 Width 8, also extends out from each point by 8.
  -}
 windowLine :: Point2 -> Point2 -> Placement
-windowLine a b = sps0 $ PutLineBlock defaultWindow 8 8 a b
+windowLine a b = sps0 $ PutLineBlock defaultWindow a b
 {-
 Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
  -}
 crystalLine :: Point2 -> Point2 -> Placement
-crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 7 a b
+crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall a b
 --crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
 --  where
 --    ps = 
@@ -77,7 +76,7 @@ wallLine a b = sps0 $ PutWall ps defaultWall
     up   = vNormal left
 
 windowLineType :: Point2 -> Point2 -> PSType
-windowLineType = PutLineBlock defaultWindow 8 8
+windowLineType = PutLineBlock defaultWindow
 
 baseBlockPane :: Wall
 baseBlockPane = defaultWall
@@ -124,7 +123,7 @@ putBlockRect' w h = ps0jPushPS (aline tl tr)
     tr = V2 w h
     br = V2 w (-h)
     bl = V2 (-w) (-h)
-    aline = PutLineBlock baseBlockPane 9 9
+    aline = PutLineBlock baseBlockPane
 
 putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
 putBlockRect a x b y =

src/Dodge/Placement/PlaceSpot.hs

@@ -99,9 +99,9 @@ placeSpotID ps pt w = case pt of
     PutCoord    cp          -> plNewID   coordinates (doShift cp) w
     PutSlideDr  wl dr off  a   b 
                             -> plSlideDoor wl dr off (doShift a) (doShift b) w
-    PutBlock    bl wl  ps'  -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
+    PutBlock    bl wl  ps'  -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
                                     wl w
-    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
+    PutLineBlock wl a b     -> plLineBlock wl (doShift a) (doShift b) w
     PutWall     qs  wl      -> (0,placeWallPoly (map doShift qs) wl w)
     PutNothing              -> (0,w)
     PutID i                 -> (i, w)

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -1,7 +1,7 @@
 {- | Creation, update and destruction of destructible walls.  -}
 module Dodge.Placement.PlaceSpot.Block 
-    ( placeBlock
+    ( plBlock
-    , placeLineBlock
+    , plLineBlock
     )
     where
 import Dodge.Data
@@ -16,46 +16,45 @@ import qualified IntMapHelp as IM
 import Control.Lens
 import qualified Data.IntSet as IS
 
-placeBlock 
+plBlock 
     :: [Point2]     -- ^ Block polygon
     -> Block
     -> Wall         -- ^ Base Pane
     -> World 
     -> (Int,World)
-placeBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
+plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
-placeBlock (p:ps) bl wl w = (,) blid $ w
+plBlock (p:ps) bl wl w = (,) blid $ w
     & flip (foldr insertWall) wls
-    & blocks %~ IM.insert blid bl 
+    & blocks . at blid ?~ bl 
-        {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[]
+        { _blID = blid
-            , _blFootprint = p:ps
+        , _blWallIDs = IS.fromList is
-            }
+        , _blShadows = []
+        , _blFootprint = p:ps
+        }
   where 
     blid = IM.newKey $ _blocks w
     lns = zip (p:ps) (ps ++ [p])
     i = IM.newKey $ _walls w
     is = [i.. i + length lns-1]
     wls = zipWith 
-        (\j (a,b) -> wl 
+        (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) 
-            { _wlLine = (a,b)
+        is 
-            , _wlID = j
+        lns 
-            , _wlStructure = BlockPart blid
-            }
-        ) is lns 
         
 {- | Splits a line into many four cornered blocks. -}
-placeLineBlock 
+plLineBlock 
     :: Wall     -- ^ Base pane
-    -> Float    -- ^ Block width
-    -> Float    -- ^ Block depth
     -> Point2   -- ^ Start point (symmetric)
     -> Point2   -- ^ End point (symmetric)
     -> World 
     -> (Int, World)
-placeLineBlock basePane blockWidth depth a b gw = ( 0 
+plLineBlock basePane a b gw = ( 0 
     , foldr insertWall (insertBlocks gw) listWalls
     )
   where 
-    psOnLine = divideLineOddNumPoints blockWidth a b
+    blwidth = 10
+    depth = 10
+    psOnLine = divideLineOddNumPoints blwidth a b
     halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
     blockCenPs = snd $ evenOddSplit psOnLine
     numBlocks = length blockCenPs
@@ -70,6 +69,7 @@ placeLineBlock basePane blockWidth depth a b gw = ( 0
         , _blHP = 1000, _blShadows = shadowsAt i
         , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
+        , _blObstructs = []
         , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
     ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]

src/Dodge/Room/Pillar.hs

@@ -24,13 +24,13 @@ blockPillar w' h' = ps0jPushPS (aline tl tr)
     $ ps0jPushPS (aline br bl)
     $ sps0 (aline bl tl)
   where
-    w = w' - 9
+    w = w' - 10
-    h = h' - 9
+    h = h' - 10
     tl = V2 (-w) h
     tr = V2 w h
     br = V2 w (-h)
     bl = V2 (-w) (-h)
-    aline = PutLineBlock baseBlockPane 9 9
+    aline = PutLineBlock baseBlockPane
 
 smallPillar :: PSType
 smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5
@@ -39,9 +39,9 @@ crossPillar :: Float -> Float -> Placement
 crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
     $ sps0 (aline (V2 0 (-h)) (V2 0 h))
   where
-    w = w' - 9
+    w = w' - 10
-    h = h' - 9
+    h = h' - 10
-    aline = PutLineBlock baseBlockPane 9 9
+    aline = PutLineBlock baseBlockPane
 
 roomPillarsSquare :: RandomGen g => State g Room
 roomPillarsSquare = do