Commit before placement refactor

src/Dodge/LightSources.hs

@@ -5,6 +5,7 @@ module Dodge.LightSources
     , colorLightAt
     , lampPic
     , lampCover
+    , lampCoverWhen
     , doubleLampCover
     , verticalLampCover
     )
@@ -76,6 +77,16 @@ lampCover h = ShapeProp
     , _pjRot = 0
     , _pjUpdate = rotateProp 0.15
     , _prDraw = drawLampCover h
+    , _prToggle = True
+    }
+lampCoverWhen :: (World -> Bool) -> Float -> Prop
+lampCoverWhen cond h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = setToggle cond `chain` rotateProp 0.15
+    , _prDraw = drawLampCover h
+    , _prToggle = True
     }
 
 doubleLampCover :: Float -> Prop
@@ -85,6 +96,7 @@ doubleLampCover h = ShapeProp
     , _pjRot = 0
     , _pjUpdate = rotateProp 0.15
     , _prDraw = drawDoubleLampCover h
+    , _prToggle = True
     }
 
 -- on the current (27/9/21) version of shadow stencilling, this glitches
@@ -96,14 +108,23 @@ verticalLampCover h = ShapeProp
     , _pjRot = 0
     , _pjUpdate = rotateProp 0.15
     , _prDraw = drawVerticalLampCover h
+    , _prToggle = True
     }
 
 rotateProp :: Float -> Prop -> World -> World
 rotateProp rotAmount pr w = w
     & props . ix (_pjID pr) . pjRot +~ rotAmount
 
+setToggle :: (World -> Bool) -> Prop -> World -> World
+setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w
+
+-- TODO check whether this is simply the reader monad, flipped
+chain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b
+chain f g x = f x . g x
+
 drawLampCover :: Float -> Prop -> SPic
-drawLampCover h pr =
+drawLampCover h pr | not (_prToggle pr) = mempty
+                   | otherwise =
     ( translateSHz (h-2.5) . uncurryV translateSHf pos 
         $ rotateSH a $ mconcat
         [ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
@@ -111,7 +132,7 @@ drawLampCover h pr =
         , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
         , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
         --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
-        , upperPrismPoly 1 $ [V2 2 2,V2 (-1) 2,V2 2 (-1)]
+        , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
         ]
     , mempty
     )
@@ -126,7 +147,7 @@ drawDoubleLampCover h pr =
         [ upperPrismPoly 5 $ rectNSEW 6 5       6 (-6)
         , upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6)
         , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
-        , upperPrismPoly 1 [V2 0 (1),V2 (-6) (-5),V2 6 (-5)]
+        , upperPrismPoly 1 [V2 0   1 ,V2 (-6) (-5),V2 6 (-5)]
         ]
     , mempty
     )