Simplify block drawing

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 ::
-    -- | Block polygon
-    [Point2] ->
-    Block ->
-    -- | Base Pane
-    Wall ->
-    GenWorld ->
-    (Int, GenWorld)
-plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
-plBlock (p : ps) bl wl w =
+plBlock :: [Point2] -> Block -> Wall -> GenWorld -> (Int, GenWorld)
+plBlock 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 ::