Add objects based on walls, called machines

src/Dodge/LevelGen/Block.hs

@@ -1,6 +1,6 @@
 {- | Creation, update and destruction of destructible walls.  -}
 module Dodge.LevelGen.Block 
-    ( putBlock
+    ( placeBlock
     , putLineBlock
     )
     where
@@ -20,13 +20,13 @@ addBlock
     :: [Point2]     -- ^ Block polygon
     -> Int          -- ^ First layer of health
     -> Color 
-    -> Bool         -- ^ Is the block see through?
+    -> Opacity         -- ^ Is the block see through?
     -> [Int]        -- ^ Extra layers of health
     -> World 
     -> World
-addBlock (p:ps) hp col isSeeThrough hps w 
+addBlock (p:ps) hp col opacity hps w 
     | hp <= 0 && null hps = w
-    | hp <= 0 = addBlock (p:ps) (head hps + hp) col isSeeThrough (tail hps) w
+    | hp <= 0 = addBlock (p:ps) (head hps + hp) col opacity (tail hps) w
     | otherwise = w
         & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
         & walls  %~ IM.union panes
@@ -41,8 +41,9 @@ addBlock (p:ps) hp col isSeeThrough hps w
             { _wlLine = (a,b)
             , _wlID = j
             , _wlColor = col
-            , _wlIsSeeThrough = isSeeThrough
-            , _wlBlockID = Just' blid
+            , _wlOpacity = opacity
+            , _wlStructure = BlockPart blid
+            , _wlFireThrough = True
             }
         ) is lns
     wallInZone wl 
@@ -55,12 +56,11 @@ addBlock (p:ps) hp col isSeeThrough hps w
         ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
 addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
-putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> (Int,World)
-putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+placeBlock :: [Point2] -> Int -> Color -> Opacity -> [Int] -> World -> (Int,World)
+placeBlock poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
   where 
-    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"
+    pairs = loopPairs poly
+    wWithBlock = addBlock poly i c opac is w
 
 {- | Splits a line into many four cornered blocks. -}
 putLineBlock 
@@ -83,7 +83,7 @@ putLineBlock basePane blockWidth depth a b w = (,) 0
     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
+    linesAt p = loopPairs $ cornersAt p
     k = IM.newKey $ _walls w
     blid = IM.newKey $ _blocks w
     insertBlock i = over blocks $ IM.insert (i+blid) Block 
@@ -101,7 +101,7 @@ putLineBlock basePane blockWidth depth a b w = (,) 0
     makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
     makePane i visStatus k' ps = basePane
         {_wlID = k'
-        ,_wlBlockID = Just' $ i + blid
+        ,_wlStructure = BlockPart $ i + blid
         ,_wlLine = ps
         ,_wlDraw = visStatus
         }

src/Dodge/LevelGen/Data.hs

@@ -11,6 +11,7 @@ import Control.Lens
 import Control.Monad.State
 import System.Random
 data PSType = PutCrit {_unPutCrit :: Creature}
+    | PutMachine Color [Point2] Machine
     | PutLS LightSource
     | PutButton Button
     | PutProp Prop

src/Dodge/LevelGen/TriggerDoor.hs

@@ -72,7 +72,7 @@ putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
         , _wlID = wlid
         , _wlColor = col
         , _wlSeen = False
-        , _wlIsSeeThrough = False
+        , _wlOpacity = Opaque
         , _wlPathable = False
         }
 -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
@@ -146,9 +146,9 @@ putSingleDoor isPathable col cond a b speed w = (drid, addWalls w
         { _wlLine = wlps
         , _wlID = wlid
         , _wlColor = col
-        , _wlSeen = False
-        , _wlIsSeeThrough = False
-        , _wlPathable = isPathable
+        , _wlSeen       = False
+        , _wlOpacity    = Opaque
+        , _wlPathable   = isPathable
         }
     pairs = rectanglePairs 9 a b
     shiftedPairs = map (bimap shiftLeft shiftLeft) pairs