Abstract out block placement

src/Dodge/Placement/Instance/Block.hs

@@ -0,0 +1,23 @@
+module Dodge.Placement.Instance.Block where
+import Dodge.Data
+import Geometry
+import Color
+import LensHelp
+import ShapePicture
+import Shape
+import Dodge.Default.Wall
+import Dodge.Default.Block
+
+lowBlock :: Material -> Color -> Float -> [Point2] -> PSType
+lowBlock mat col h ps = PutBlock bl wl $ reverse ps
+  where
+    bl = defaultBlock
+        & blDraw .~ const (noPic $ colorSH col (upperPrismPoly h $ reverse ps))
+        & blDeath .~ const id
+    wl = defaultWall 
+        & wlDraw .~ False 
+        & wlColor .~ col 
+        & wlRotateTo .~ False  
+        & wlOpacity .~ SeeAbove
+        & wlMaterial .~ mat
+        & wlHeight .~ h

src/Dodge/Placement/Instance/Wall.hs

@@ -1,6 +1,7 @@
 module Dodge.Placement.Instance.Wall
     where
 import Dodge.Data
+import Dodge.Placement.Instance.Block
 import Dodge.Default.Block
 --import Dodge.Block.Debris
 import Dodge.LevelGen.Data
@@ -14,26 +15,7 @@ import Data.List
 import Control.Lens
 
 heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
-heightWallPS spot h ps = psj spot (PutShape . colorSH col $ upperPrismPoly h ps)
-    $ sps spot $ PutWall ps theWall
-  where
-    col = _wlColor defaultWall
-    theWall = defaultWall
-        { _wlOpacity = SeeAbove
-        , _wlDraw = False
-        , _wlHeight = h
-        }
-
-heightWall :: Float -> [Point2] -> Placement
-heightWall h ps = ps0j (PutShape . colorSH col $ upperPrismPoly h ps)
-    $ sps0 $ PutWall ps theWall
-  where
-    col = _wlColor defaultWall
-    theWall = defaultWall
-        { _wlOpacity = SeeAbove
-        , _wlDraw = False
-        , _wlHeight = h
-        }
+heightWallPS spot h ps = spNoID spot $ lowBlock Stone (_wlColor defaultWall) h ps
 
 invisibleWall :: [Point2] -> Placement
 invisibleWall ps = sps0 $ PutWall ps $ defaultWall