Cleanup and reorganise

src/Dodge/LevelGen/Block.hs

@@ -1,6 +1,7 @@
 {- | Creation, update and destruction of destructible walls.  -}
 module Dodge.LevelGen.Block 
     ( putBlock
+    , putLineBlock
     )
     where
 import Dodge.Data
@@ -60,3 +61,49 @@ putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock
     pairs = zip (p:ps) (ps ++ [p])
     wWithBlock = addBlock (p:ps) i c b is w
 putBlock _ _ _ _ _ _ = error "Trying to put a block with incomplete polygon"
+
+{- | Splits a line into many four cornered blocks. -}
+putLineBlock 
+    :: Wall     -- ^ Base pane
+    -> Float    -- ^ Block width
+    -> Float    -- ^ Block depth
+    -> Point2   -- ^ Start point (symmetric)
+    -> Point2   -- ^ End point (symmetric)
+    -> World 
+    -> (Int, World)
+putLineBlock basePane blockWidth depth a b w = (,) 0 
+    $ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
+  where 
+    d = dist a b
+    rot = argV (b -.- a)
+    psOnLine = divideLineOddNumPoints blockWidth a b
+    halfBlockWidth = d / fromIntegral (length psOnLine - 1)
+    blockCenPs = snd $ evenOddSplit psOnLine
+    numBlocks = length blockCenPs
+    is = [0.. numBlocks - 1]
+    cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
+    cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
+    linesAt p = makeLoopPairs $ cornersAt p
+    k = IM.newKey $ _walls w
+    blid = IM.newKey $ _blocks w
+    insertBlock i = over blocks $ IM.insert (i+blid) Block 
+        {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
+    insertBlocks = flip (foldr insertBlock) is
+    ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
+    visibilityAt i 
+        | i == 0             = [ True,True,False,True]
+        | i == numBlocks - 1 = [False,True, True,True]
+        | otherwise          = [False,True,False,True]
+    shadowsAt i
+        | i == 0             = ksAtI 1
+        | i == numBlocks - 1 = ksAtI $ numBlocks - 2
+        | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
+    makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
+    makePane i visStatus k' ps = basePane
+        {_wlID = k'
+        ,_wlBlockID = Just' $ i + blid
+        ,_wlLine = ps
+        ,_wlDraw = visStatus
+        }
+    listWalls = concat $ zipWith makeWallAt blockCenPs is
+    insertWall wl = over walls $ IM.insert (_wlID wl) wl