justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Reify block drawing

Browse Source
This commit is contained in:
justin
2022-07-25 01:27:39 +01:00
parent 486c203fa2
commit c3a5b9d5be
15 changed files with 85 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Placement/Instance/Block.hs
+5 -3
View File
@@ -8,11 +8,13 @@ import Shape
import Dodge.Default.Wall
import Dodge.Default.Block
decoratedBlock :: (Block -> Shape) -> Material -> Color -> Float -> [Point2] -> PSType
--decoratedBlock :: (Block -> Shape) -> Material -> Color -> Float -> [Point2] -> PSType
decoratedBlock :: BlSh -> Material -> Color -> Float -> [Point2] -> PSType
decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
where
bl = defaultBlock
& blDraw .~ (\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl'))
& blDraw .~ BlockDraws [BlockDrawColHeightPoss col h (reverse ps),BlockDrawBlSh decf]
--(\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl'))
& blHeight .~ h
& blMaterial .~ mat
wl = defaultWall
@@ -23,4 +25,4 @@ decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
& wlHeight .~ h
lowBlock :: Material -> Color -> Float -> [Point2] -> PSType
lowBlock = decoratedBlock (const mempty)
lowBlock = decoratedBlock BlShMempty