Abstract out block placement

2022-06-27 13:38:46 +01:00
parent c8710fe92a
commit fec72cdf48
14 changed files with 105 additions and 55 deletions
@@ -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