Make buttons have shape, expose multiple bugs

src/Dodge/LevelGen/Switch.hs

@@ -1,11 +1,13 @@
 module Dodge.LevelGen.Switch
     where
 import Dodge.Data
+import Dodge.Default
 import Dodge.Data.SoundOrigin
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
-import Dodge.Picture.Layer
 import Picture
+import ShapePicture
+import Shape
 import Geometry
 --import Geometry.Data
 
@@ -15,8 +17,8 @@ makeButton
     :: Color 
     -> (World -> World) -- ^ Effect when pressed
     -> Button
-makeButton c eff = Button
-    { _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
+makeButton col eff = Button
+    { _btPict = defaultDrawButton col
     , _btPos = V2 0 0
     , _btRot = 0
     , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
@@ -27,17 +29,28 @@ makeButton c eff = Button
     , _btState = BtOff
     }
   where
-    turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = const id}
-    onPict = setLayer 0 $ onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
+    turnOn bt = bt {_btState = BtNoLabel, _btEvent = const id}
     btpos b w' = _btPos $ _buttons w' IM.! _btID b
 
+drawSwitch :: Color -> Color -> Button -> SPic
+drawSwitch col1 col2 bt
+    | _btState bt == BtOff = flick $ pi/4
+    | otherwise = flick (negate (pi/4))
+  where
+    flick a = ( mconcat
+        [ colorSH col1 . translateSHz 10 . upperPrismPoly 10 $ rectNSEW (-2) (-5) 10 (-10)
+        , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 $ rectNSEW 10 (0) 2 (-2)
+        ]   
+        , mempty)
+
 makeSwitch 
-    :: Color 
+    :: Color
+    -> Color
     -> (World -> World) -- ^ Switch on effect
     -> (World -> World) -- ^ Switch off effect
     -> Button
-makeSwitch c effOn effOff = Button
-    { _btPict = offPict
+makeSwitch col1 col2 effOn effOff = Button
+    { _btPict = drawSwitch col1 col2
     , _btPos = V2 0 0
     , _btRot = 0
     , _btEvent = flipSwitch
@@ -52,24 +65,14 @@ makeSwitch c effOn effOff = Button
         BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
         BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))
         _ -> error "Trying to switch a button with no label"
-    offPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
-                              polygon $ rectNSEW (-2) (-5) (-10) 10
-                              ,polygon $ map toV2 [(-2,-5),(-10,4),(-6,4),(2,-5)]
-                             ]
-    onPict  = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
-                              polygon $ rectNSEW (-2) (-5) (-10) 10
-                              ,polygon $ map toV2 [(-2,-5), (6,4),( 10,4),(2,-5)]
-                             ]
     turnOn :: Button -> Button
     turnOn bt = bt 
         { _btState = BtOn
-        , _btPict = onPict
         , _btText = "SWITCH\\"
         }
     turnOff :: Button -> Button
     turnOff bt = bt 
         { _btState = BtOff
-        , _btPict = offPict
         , _btText = "SWITCH/"
         }
 

src/Dodge/LevelGen/TriggerDoor.hs

@@ -52,7 +52,7 @@ addSwitchDoor c btp btr a b speed w = over buttons (IM.insert bid bt)
   where 
     bid = IM.newKey $ _buttons w
     cond w' = BtOn == _btState (_buttons w' IM.! bid)
-    bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
+    bt = (makeSwitch c red openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
     (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) 
                                              $ _pathGraphP w
     newGraph = pairsToGraph dist newGraphPairs