Reallow different line block sizes

src/Dodge/Data.hs

@@ -1406,7 +1406,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutMod Modification
     | PutTrigger (World -> Bool)
     | PutLineBlock {_putWall :: Wall , _putWidth :: Float
-        , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
+        , _putStartPoint :: Point2, _putEndPoint :: Point2}
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutSlideDr Door Wall Float Point2 Point2
     | PutDoor Color (World -> Bool) [(Point2,Point2)]

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 9 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 8 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 7 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 8
 
 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 9
 
 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 wdth a b     -> plLineBlock wl wdth (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
@@ -17,63 +17,45 @@ import Control.Lens
 import Data.List
 import qualified Data.IntSet as IS
 
-addBlock 
+plBlock 
     :: [Point2]     -- ^ Block polygon
-    -> Wall         -- ^ Base Pane
     -> Block
+    -> Wall         -- ^ Base Pane
     -> World 
-    -> World
+    -> (Int,World)
-addBlock (p:ps) wl bl w = w
+plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
-    & wlZoning . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
+plBlock (p:ps) bl wl w = (,) blid $ w
-    & walls  %~ IM.union panes
+    & 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]
-    panes = IM.fromList $ zipWith 
+    wls = zipWith 
-        (\j (a,b) -> (,) j wl 
+        (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) 
-            { _wlLine = (a,b)
+        is 
-            , _wlID = j
+        lns 
-            , _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"
         
-placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
-placeBlock poly bl wl w 
-    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
-  where 
-    pairs = loopPairs poly
-    wWithBlock = addBlock poly wl bl w
-
 {- | Splits a line into many four cornered blocks. -}
-placeLineBlock 
+plLineBlock 
     :: Wall     -- ^ Base pane
-    -> Float    -- ^ Block width
+    -> Float
-    -> Float    -- ^ Block depth
     -> Point2   -- ^ Start point (symmetric)
     -> Point2   -- ^ End point (symmetric)
     -> World 
     -> (Int, World)
-placeLineBlock basePane blockWidth depth a b gw = ( 0 
+plLineBlock basePane blwidth a b gw = ( 0 
-    , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
+    , foldr insertWall (insertBlocks gw) listWalls
     )
   where 
-    psOnLine = divideLineOddNumPoints blockWidth a b
+    depth = blwidth
+    psOnLine = divideLineOddNumPoints blwidth a b
     halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
     blockCenPs = snd $ evenOddSplit psOnLine
     numBlocks = length blockCenPs
@@ -108,4 +90,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/Room/Pillar.hs

@@ -30,7 +30,7 @@ blockPillar 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 9
 
 smallPillar :: PSType
 smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5
@@ -41,7 +41,7 @@ crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
   where
     w = w' - 9
     h = h' - 9
-    aline = PutLineBlock baseBlockPane 9 9
+    aline = PutLineBlock baseBlockPane 9
 
 roomPillarsSquare :: RandomGen g => State g Room
 roomPillarsSquare = do