Simplify block drawing

src/Dodge/Block/Draw.hs

@@ -9,9 +9,4 @@ drawBlock bd = case bd of
     BlockDrawMempty -> const mempty
     BlockDraws bds -> \bl -> foldMap (`drawBlock` bl) bds
     BlockDrawColHeightPoss col h ps -> const $ noPic $ colorSH col (upperBox Medium Typical h ps)
-    BlockDrawBlSh x -> noPic . doBlSh x
+    BlockDrawBlSh x -> const $ noPic x
-
-doBlSh :: BlSh -> Block -> Shape
-doBlSh bs = case bs of
-    BlShMempty -> const mempty
-    BlShConst sh -> const sh

src/Dodge/Data/Block.hs

@@ -32,14 +32,13 @@ data Block = Block
 
 data BlockDraw
     = BlockDrawMempty
-    | BlockDrawBlSh BlSh
+    | BlockDrawBlSh Shape
     | BlockDraws [BlockDraw]
     | BlockDrawColHeightPoss Color Float [Point2]
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data BlSh
-    = BlShMempty
+    = BlShConst Shape
-    | BlShConst Shape
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 makeLenses ''Block

src/Dodge/Placement/Instance/Block.hs

@@ -1,5 +1,6 @@
 module Dodge.Placement.Instance.Block where
 
+import Shape.Data
 import Color
 import Dodge.Data.GenWorld
 import Dodge.Default.Block
@@ -7,7 +8,7 @@ import Dodge.Default.Wall
 import Geometry
 import LensHelp
 
-decoratedBlock :: BlSh -> Material -> Color -> Float -> [Point2] -> PSType
+decoratedBlock :: Shape -> Material -> Color -> Float -> [Point2] -> PSType
 decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
   where
     bl =
@@ -24,4 +25,4 @@ decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
             & wlHeight .~ h
 
 lowBlock :: Material -> Color -> Float -> [Point2] -> PSType
-lowBlock = decoratedBlock BlShMempty
+lowBlock = decoratedBlock mempty

src/Dodge/Placement/Instance/Tank.hs

@@ -20,7 +20,7 @@ tankSquareDec ::
 tankSquareDec dec = tankShape (reverse . orderPolygon $ square 20) (dec 20 20 31)
 
 tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement
-tankShape baseshape facade col col' = sps0 $ decoratedBlock (BlShConst $ facade col col') Metal col 31 baseshape
+tankShape baseshape facade col col' = sps0 $ decoratedBlock (facade col col') Metal col 31 baseshape
 
 roundTank :: Color -> Color -> Placement
 roundTank = tankShape (polyCirc 4 20) $

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -15,16 +15,8 @@ import Dodge.Path
 import Geometry
 import qualified IntMapHelp as IM
 
-plBlock ::
+plBlock :: [Point2] -> Block -> Wall -> GenWorld -> (Int, GenWorld)
-    -- | Block polygon
+plBlock ps bl wl w =
-    [Point2] ->
-    Block ->
-    -- | Base Pane
-    Wall ->
-    GenWorld ->
-    (Int, GenWorld)
-plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
-plBlock (p : ps) bl wl w =
     (,) blid $
         w
             & gwWorld . cWorld . lWorld . blocks . at blid
@@ -32,19 +24,18 @@ plBlock (p : ps) bl wl w =
                     { _blID = blid
                     , _blWallIDs = IS.fromList is
                     , _blShadows = []
-                    , _blFootprint = p : ps
+                    , _blFootprint = ps
                     }
             & gwWorld %~ insertWalls wls
   where
     blid = IM.newKey $ w ^. gwWorld . cWorld . lWorld . blocks
-    lns = zip (p : ps) (ps ++ [p])
     i = IM.newKey $ w ^. gwWorld . cWorld . lWorld . walls
-    is = [i .. i + length lns -1]
+    is = take (length ps) [i .. ]
     wls =
         zipWith
             (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid)
             is
-            lns
+            (loopPairs ps)
 
 -- | Splits a line into many four cornered blocks.
 plLineBlock ::

src/Dodge/Room/Tanks.hs

@@ -41,8 +41,7 @@ randEdgeTank = do
                         BlockDraws
                             [ bd
                             , BlockDrawBlSh
-                                ( BlShConst $
+                                ( colorSH
-                                    colorSH
                                         orange
                                         ( verticalPipe 80
                                             <> horPipe 80 0 (70 *.* cardVec edge)
@@ -72,8 +71,7 @@ randEdgeTanks i = do
                             BlockDraws
                                 [ bd
                                 , BlockDrawBlSh
-                                    ( BlShConst $
+                                    ( colorSH
-                                        colorSH
                                             orange
                                             ( verticalPipe 80
                                                 <> horPipe 80 0 (70 *.* cardVec edge)

src/Dodge/Room/Tutorial.hs

@@ -1,5 +1,6 @@
 module Dodge.Room.Tutorial where
 
+import Dodge.Room.Tanks
 import Dodge.Room.LongDoor
 import Dodge.Layout
 import Dodge.Item.Held.Utility
@@ -43,6 +44,7 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
+        , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , tToBTree "lastun" . return . cleatOnward <$> cenLasTur