Make buttons have shape, expose multiple bugs

src/Dodge/LightSources.hs

@@ -5,6 +5,8 @@ module Dodge.LightSources
     , colorLightAt
     , lampPic
     , lampCover
+    , doubleLampCover
+    , verticalLampCover
     )
     where
 import Dodge.Data
@@ -72,22 +74,72 @@ lampCover h = ShapeProp
     { _pjPos = V2 0 0
     , _pjID  = 0
     , _pjRot = 0
-    , _pjUpdate = updateLampCover
+    , _pjUpdate = rotateProp 0.15
     , _prDraw = drawLampCover h
     }
 
-updateLampCover :: Prop -> World -> World
-updateLampCover pr w = w
-    & props . ix (_pjID pr) . pjRot +~ 0.15
+doubleLampCover :: Float -> Prop
+doubleLampCover h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = rotateProp 0.15
+    , _prDraw = drawDoubleLampCover h
+    }
+
+-- on the current (27/9/21) version of shadow stencilling, this glitches
+-- slightly when the shadow rotates towards the screen
+verticalLampCover :: Float -> Prop
+verticalLampCover h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = rotateProp 0.15
+    , _prDraw = drawVerticalLampCover h
+    }
+
+rotateProp :: Float -> Prop -> World -> World
+rotateProp rotAmount pr w = w
+    & props . ix (_pjID pr) . pjRot +~ rotAmount
 
 drawLampCover :: Float -> Prop -> SPic
 drawLampCover h pr =
     ( translateSHz (h-2.5) . uncurryV translateSHf pos 
         $ rotateSH a $ mconcat
-        [ upperPrismPoly 5 $ rectNSEW 6 5    6 (-4)
-        , upperPrismPoly 5 $ rectNSEW 6 (-4) 6 5
+        [ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
+        , translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
+        , 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 5 5,V2 (-4) 5,V2 5 (-4)]
+        , upperPrismPoly 1 $ [V2 2 2,V2 (-1) 2,V2 2 (-1)]
+        ]
+    , mempty
+    )
+  where
+    a = _pjRot pr
+    pos = _pjPos pr
+
+drawDoubleLampCover :: Float -> Prop -> SPic
+drawDoubleLampCover h pr =
+    ( translateSHz (h-2.5) . uncurryV translateSHf pos 
+        $ rotateSH a $ mconcat
+        [ 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)]
+        ]
+    , mempty
+    )
+  where
+    a = _pjRot pr
+    pos = _pjPos pr
+
+drawVerticalLampCover :: Float -> Prop -> SPic
+drawVerticalLampCover h pr =
+    ( translateSHz h . uncurryV translateSHf pos 
+        $ rotateSHx a $ mconcat
+        [ 
+        translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5)
         ]
     , mempty
     )