Add indicator light to switch doors

src/Dodge/Default.hs

@@ -272,7 +272,7 @@ defaultPP = PressPlate
 defaultLS :: LightSource
 defaultLS = LS
     { _lsID = 0
-    , _lsPos = 0
+    , _lsPos = V3 0 0 50
     , _lsDir = 0
     , _lsRad = 700
     , _lsIntensity = 0.6

src/Dodge/Floor.hs

@@ -14,7 +14,9 @@ import Dodge.Layout.Tree.Annotate
 import Dodge.Layout.Tree.Shift
 import Dodge.Creature
 import Dodge.LevelGen.Data
+import Dodge.LevelGen.Switch
 import Dodge.Item.Weapon.Launcher
+import Dodge.PlacementSpot
 import MonadHelp
 import Data.Tree
 import Color
@@ -34,7 +36,7 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk
     [[StartRoom]
     ,[ChainAnos 
         [[SetLabel 0 $ return $ roomRectAutoLinks 200 200 
-                    & rmExtPmnt ?~ triggerSwitch red 
+            & rmExtPmnt ?~ triggerSwitchSPicLight (drawSwitchWire red red)
                 (anyLnkInPS 5 & psLnkRoomEff .~ (putWireStart 0 . extractRoomPos) )
             & rmLinkEff .~ [putWireEnd 0]
          ]

src/Dodge/Layout.hs

@@ -14,6 +14,7 @@ import Dodge.Bounds
 import Dodge.Default.Wall
 import Dodge.Room.Link
 import Geometry
+import Geometry.Vector3D
 import Geometry.ConvexPoly
 import qualified IntMapHelp as IM
 import Tile
@@ -66,6 +67,12 @@ placeRoomWires rm w = IM.foldr ($) w
     $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm)
 
 placeWire :: Room -> RoomWire -> RoomWire -> World -> World
+placeWire rm (WallWire p a h) wr = placeWire rm wr (RoomWire p a) .
+    (foregroundShape %~ (colorSH red (barPP 1.5 (addZ h p') (addZ 80 p')) <>)
+    )
+  where
+    p' = shiftPointBy (_rmShift rm) p
+placeWire rm rw1 rw2@WallWire{} = placeWire rm rw2 rw1
 placeWire rm (RoomWire p _) (RoomWire q _) = foregroundShape 
     %~ ((col $ thinHighBarChain 80 $ map (shiftPointBy rs) doOrdering) <>)
   where
@@ -73,7 +80,7 @@ placeWire rm (RoomWire p _) (RoomWire q _) = foregroundShape
     --rmWalls = foldr cutWalls [] (_rmPolys rm)
     doOrdering = orderPolygonAround rmcen (p:q:ps)
     col | clockwise = colorSH red
-        | otherwise = colorSH orange
+        | otherwise = colorSH red
     rmps = concat $ _rmPolys rm
     rmcen = centroid rmps
     clockwise = isLHS rmcen p q

src/Dodge/LevelGen/Data.hs

@@ -83,6 +83,7 @@ data Room = Room
     }
 data RoomWire
     = RoomWire Point2 Float
+    | WallWire Point2 Float Float
 data RoomPos 
     = OutLink Int    Point2  Float
     | InLink  Point2 Float
@@ -104,20 +105,6 @@ makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement
 
--- TODO rename to any unused link facing out
-anyLnkOutPS :: PlacementSpot
-anyLnkOutPS = PSLnk f (const id) Nothing
-  where
-    f (UnusedLink p a) = Just $ PS p a
-    f _ = Nothing
-    
-
-anyLnkInPS :: Float -- ^ amount to shift inward
-    -> PlacementSpot
-anyLnkInPS x = PSLnk f (const id) Nothing
-  where
-    f (UnusedLink v a) = Just $ PS (v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)) (a+ pi)
-    f _ = Nothing
 
 spNoID :: PlacementSpot -> PSType -> Placement
 spNoID ps pst = Placement ps pst Nothing (const Nothing)

src/Dodge/LevelGen/Switch.hs

@@ -1,6 +1,8 @@
 module Dodge.LevelGen.Switch
     ( makeSwitch
     , makeButton
+    , makeSwitchSPic
+    , drawSwitchWire
     ) where
 import Dodge.Data
 import Dodge.Default
@@ -44,6 +46,50 @@ drawSwitch col1 col2 bt
         ]   
         , mempty)
 
+drawSwitchWire :: Color -> Color -> Button -> SPic
+drawSwitchWire 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)
+
+makeSwitchSPic
+    :: (Button -> SPic)
+    -> (World -> World) -- ^ Switch on effect
+    -> (World -> World) -- ^ Switch off effect
+    -> Button
+makeSwitchSPic dswitch effOn effOff = Button
+    { _btPict = dswitch
+    , _btPos = V2 0 0
+    , _btRot = 0
+    , _btEvent = flipSwitch
+    , _btID = 0
+    , _btText = "SWITCH/"
+    , _btState = BtOff
+    }
+  where 
+    flipSwitch b w = switchEffect b . soundFromGeneral (LeverSound 0) (bpos b) click1S Nothing $ w
+    bpos b w = _btPos $ _buttons w IM.! _btID b
+    switchEffect b = case _btState b of
+        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"
+    turnOn :: Button -> Button
+    turnOn bt = bt 
+        { _btState = BtOn
+        , _btText = "SWITCH\\"
+        }
+    turnOff :: Button -> Button
+    turnOff bt = bt 
+        { _btState = BtOff
+        , _btText = "SWITCH/"
+        }
+    
+
 makeSwitch 
     :: Color
     -> Color

src/Dodge/PlacementSpot.hs

@@ -0,0 +1,23 @@
+module Dodge.PlacementSpot where
+import Dodge.LevelGen.Data
+import Geometry
+
+-- TODO rename to any unused link facing out
+anyLnkOutPS :: PlacementSpot
+anyLnkOutPS = PSLnk f (const id) Nothing
+  where
+    f (UnusedLink p a) = Just $ PS p a
+    f _ = Nothing
+    
+fstLnkOut :: PlacementSpot
+fstLnkOut = PSLnk f (const id) Nothing
+  where
+    f (OutLink 0 p a) = Just $ PS p a
+    f _ = Nothing
+
+anyLnkInPS :: Float -- ^ amount to shift inward
+    -> PlacementSpot
+anyLnkInPS x = PSLnk f (const id) Nothing
+  where
+    f (UnusedLink v a) = Just $ PS (v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)) (a+ pi)
+    f _ = Nothing

src/Dodge/Placements/Button.hs

@@ -7,10 +7,35 @@ import Dodge.LevelGen.Data
 import Dodge.Default
 import Dodge.LevelGen.Switch
 import Dodge.Placements.LightSource
+import Dodge.PlacementSpot
+import ShapePicture
 
 import Data.Maybe
 import Control.Lens
 
+triggerSwitchSPic :: (Button -> SPic) -> PlacementSpot -> Placement
+triggerSwitchSPic sdraw ps = plCont ps (PutTrigger (const False))
+    $ \tp -> Just $ pContID ps (PutButton (makeSwitchSPic sdraw (oneff $ trigid tp) (offeff $ trigid tp))) 
+                    (const Nothing)
+  where
+    trigid tp = fromJust $ _plMID tp
+    oneff  tid = triggers . ix tid .~ const True
+    offeff tid = triggers . ix tid .~ const False
+
+triggerSwitchSPicLight :: (Button -> SPic) -> PlacementSpot -> Placement
+triggerSwitchSPicLight sdraw ps = plCont ps (PutTrigger (const False))
+    $ \tp -> Just $ pContID fstLnkOut (PutLS thels)
+    $ \lsid -> Just 
+        $ pContID ps (PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp))) 
+                    (const Nothing)
+  where
+    thels = defaultLS {_lsIntensity = V3 0.5 0 0, _lsPos = V3 0 0 78, _lsRad = 75}
+    trigid tp = fromJust $ _plMID tp
+    eff lsid tid b c = (triggers . ix tid .~ const b)  
+        . (lightSources . ix lsid . lsIntensity .~ c)
+    oneff  lsid tid = eff lsid tid True (V3 0 0.5 0) 
+    offeff lsid tid = eff lsid tid False (V3 0.5 0 0)
+
 triggerSwitch :: Color -> PlacementSpot -> Placement
 triggerSwitch col ps = plCont ps (PutTrigger (const False))
     $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp))) 

src/Dodge/Room/Foreground.hs

@@ -142,6 +142,13 @@ girder = girderCol orange
 robotArm :: Shape
 robotArm = undefined
 
+barPP :: Float -> Point3 -> Point3 -> Shape
+barPP w a b = prismPoly
+    (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
+    (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
+  where
+    z1 = b -.-.- a
+
 pipePP :: Float -> Point3 -> Point3 -> Shape
 pipePP w a b = prismPoly
     (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)

src/Dodge/Wire.hs

@@ -9,4 +9,4 @@ putWireEnd :: Int -> (Point2,Float) -> Room -> Room
 putWireEnd i pos = rmEndWires %~ IM.insert i (uncurry RoomWire pos)
 
 putWireStart :: Int -> (Point2,Float) -> Room -> Room
-putWireStart i pos = rmStartWires %~ IM.insert i (uncurry RoomWire pos)
+putWireStart i pos = rmStartWires %~ IM.insert i (uncurry WallWire pos 10)