Make buttons have shape, expose multiple bugs

src/Dodge/Default.hs

@@ -19,7 +19,7 @@ import Dodge.SoundLogic.LoadSound
 import Dodge.Picture.Layer
 import Geometry
 import Picture
---import ShapePicture
+import ShapePicture
 import Shape
 
 import Control.Lens
@@ -208,14 +208,22 @@ defaultIt = Consumable
     , _itHammer = HammerUp
     , _itAimStance = LeaveHolstered
     }
+defaultDrawButton :: Color -> Button -> SPic
+defaultDrawButton col bt
+    | _btState bt == BtOff = 
+        ( translateSHz 15 . colorSH col $ upperPrismPoly 5 $ rectNSEW 5 (-5) 10 (-10)
+        , mempty
+        )
+    | otherwise = 
+        ( translateSHz 15 . colorSH red $ upperPrismPoly 5 $ rectNSEW (-3) (-5) 10 (-10)
+        , mempty
+        )
 defaultButton :: Button
 defaultButton = Button
-    { _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10)
+    { _btPict = defaultDrawButton (dark red)
     , _btPos = V2 0 0
     , _btRot = 0
-    , _btEvent = \b w -> 
-        set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
-        . set (buttons . ix (_btID b) . btState) BtNoLabel
+    , _btEvent = \b w -> set (buttons . ix (_btID b) . btState) BtNoLabel
         . soundStart (LeverSound 0) (_btPos b) click1S Nothing $ w
     , _btID = 0
     , _btText = "Button"