Move button data

src/Dodge/Button/Draw.hs

@@ -0,0 +1,36 @@
+module Dodge.Button.Draw where
+import Dodge.Data.Button
+import Geometry
+import Color
+import ShapePicture
+import Shape
+
+drawButton :: ButtonDraw -> Button -> SPic
+drawButton bd = case bd of
+    DefaultDrawButton col -> defaultDrawButton col
+    DefaultDrawSwitch col1 col2 -> drawSwitch col1 col2
+    DrawNoButton -> const mempty
+
+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 . upperPrismPoly 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10
+        , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperPrismPoly 2 $ reverse
+            $ rectNSWE 10 0 (-2) 2
+        ]   
+        , mempty)
+
+defaultDrawButton :: Color -> Button -> SPic
+defaultDrawButton col bt =
+    ( translateSHz 15 . colorSH col $ upperPrismPoly 5 buttonGeometry
+    , mempty
+    )
+  where
+    buttonGeometry
+        | _btState bt == BtOff = reverse $ rectNSWE 10 (-1) (-width) width
+        | otherwise = reverse $ rectNSWE 2 (-1) (-width) width
+    width = 8

src/Dodge/Button/Event.hs

@@ -0,0 +1,33 @@
+module Dodge.Button.Event where
+import Dodge.Data
+import Dodge.SoundLogic
+import Dodge.Placement.Instance.Terminal
+
+import Dodge.WorldEffect
+import Control.Lens
+
+doButtonEvent :: ButtonEvent -> Button -> World -> World
+doButtonEvent be = case be of
+    ButtonDoNothing -> const id
+    ButtonPress newstate newevent thesound f -> \b -> doWorldEffect f
+        . set (buttons . ix (_btID b) . btState) newstate
+        . set (buttons . ix (_btID b) . btEvent) newevent
+        . soundStart (LeverSound 0) (_btPos b) thesound Nothing
+    --ButtonSwitch onstate onevent onsound oneff offstate offevent offsound offeff -> undefined
+    ButtonSimpleSwith oneff offeff -> flipSwitch oneff offeff
+    ButtonAccessTerminal -> accessTerminal . _btTermMID
+
+flipSwitch :: WorldEffect -> WorldEffect -> Button -> World -> World
+flipSwitch oneff offeff bt 
+    | _btState bt == BtOff = doWorldEffect oneff . dosound
+        . over (buttons . ix (_btID bt)) turnon
+    | otherwise = doWorldEffect offeff . dosound
+        . over (buttons . ix (_btID bt)) turnoff
+  where
+    turnon  = (btState .~ BtOn ) .  (btText .~ "SWITCH\\")
+    turnoff = (btState .~ BtOff) .  (btText .~ "SWITCH/")
+    dosound = soundFromGeneral (LeverSound 0) (const $ _btPos bt) click1S Nothing
+--    switchEffect b = case _btState b of
+--        BtOff -> effOn  . (buttons . ix (_btID b) %~ turnOn )
+--        BtOn  -> effOff . (buttons . ix (_btID b) %~ turnOff)
+--        _ -> error "Trying to switch a button with no label"

src/Dodge/Data.hs

@@ -10,6 +10,8 @@ circular imports are probably not a good idea.
 {-# LANGUAGE DerivingStrategies #-}
 module Dodge.Data 
     ( module Dodge.Data
+    , module Dodge.Data.WorldEffect
+    , module Dodge.Data.Button
     , module Dodge.Data.Item.Params
     , module Dodge.Data.Beam
     , module Dodge.Data.Targeting
@@ -68,6 +70,8 @@ module Dodge.Data
     , module Dodge.Data.RadarBlip
     , module Dodge.Data.PathGraph
     ) where
+import Dodge.Data.WorldEffect
+import Dodge.Data.Button
 import Dodge.Data.Item.Params
 import Dodge.Data.Beam
 import Dodge.Data.Targeting
@@ -382,18 +386,6 @@ data Intention = Intention
     , _mvToPoint    :: Maybe Point2
     , _viewPoint    :: Maybe Point2
     }
-data Button = Button 
-    { _btPict   :: Button -> SPic
-    , _btPos    :: Point2
-    , _btRot    :: Float
-    , _btEvent  :: Button -> World -> World
-    , _btID     :: Int
-    , _btText   :: String
-    , _btState  :: ButtonState
-    , _btTermMID :: Maybe Int
-    , _btName   :: String
-    , _btColor  :: Color
-    }
 data TerminalLine
     = TerminalLineDisplay
         {_tlPause :: Int
@@ -407,8 +399,6 @@ data TerminalLine
         {_tlPause :: Int
         ,_tlEffect :: Terminal -> World -> World
         }
-data ButtonState = BtOn | BtOff | BtNoLabel
-  deriving (Eq, Show)
 data PressPlate = PressPlate 
     { _ppPict :: Picture
     , _ppPos :: Point2
@@ -1083,7 +1073,6 @@ makeLenses ''Proj
 makeLenses ''Modification
 makeLenses ''Particle
 makeLenses ''PressPlate
-makeLenses ''Button
 makeLenses ''ActionPlan
 makeLenses ''Impulse
 makeLenses ''Action

src/Dodge/Data/Button.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.Button where
+import Dodge.Data.WorldEffect
+import Control.Lens
+import Geometry.Data
+import Sound.Data
+import Color
+
+data ButtonDraw = DefaultDrawButton Color
+    | DefaultDrawSwitch Color Color
+    | DrawNoButton
+data ButtonEvent = ButtonDoNothing
+    | ButtonPress
+        {_bpState :: ButtonState
+        ,_bpEvent :: ButtonEvent
+        ,_bpSound :: SoundID
+        ,_bpEff :: WorldEffect
+        }
+--    | ButtonSwitch
+--        {_bonState :: ButtonState
+--        ,_bonEvent :: ButtonEvent
+--        ,_bonSound :: SoundID
+--        ,_bonEff :: WorldEffect
+--        ,_boffState :: ButtonState
+--        ,_boffEvent :: ButtonEvent
+--        ,_boffSound :: SoundID
+--        ,_boffEff :: WorldEffect
+--        }
+    | ButtonSimpleSwith
+        {_bonEff :: WorldEffect
+        ,_boffEff :: WorldEffect
+        }
+    | ButtonAccessTerminal
+
+data Button = Button 
+    { _btPict   :: ButtonDraw --Button -> SPic
+    , _btPos    :: Point2
+    , _btRot    :: Float
+    , _btEvent  :: ButtonEvent --Button -> World -> World
+    , _btID     :: Int
+    , _btText   :: String
+    , _btState  :: ButtonState
+    , _btTermMID :: Maybe Int
+    , _btName   :: String
+    , _btColor  :: Color
+    }
+data ButtonState = BtOn | BtOff | BtNoLabel
+  deriving (Eq, Show)
+makeLenses ''Button

src/Dodge/Data/WorldEffect.hs

@@ -0,0 +1,8 @@
+module Dodge.Data.WorldEffect where
+import Geometry.Data
+
+data WorldEffect = NoWorldEffect
+    | SetTrigger Bool Int 
+    | WorldEffects [WorldEffect]
+    | SetLSCol Point3 Int
+    | AccessTerminal (Maybe Int)

src/Dodge/Default.hs

@@ -62,16 +62,6 @@ defaultMachine = Machine
     , _mcMounts = mempty
     , _mcCloseSound = Nothing
     }
-defaultDrawButton :: Color -> Button -> SPic
-defaultDrawButton col bt =
-    ( translateSHz 15 . colorSH col $ upperPrismPoly 5 buttonGeometry
-    , mempty
-    )
-  where
-    buttonGeometry
-        | _btState bt == BtOff = reverse $ rectNSWE 10 (-1) (-width) width
-        | otherwise = reverse $ rectNSWE 2 (-1) (-width) width
-    width = 8
 defaultTerminal :: Terminal
 defaultTerminal = Terminal 
     { _tmID = 0 
@@ -100,11 +90,10 @@ defaultTerminalInput = TerminalInput
 
 defaultButton :: Button
 defaultButton = Button
-    { _btPict = defaultDrawButton (dark red)
+    { _btPict = DefaultDrawButton (dark red)
     , _btPos = V2 0 0
     , _btRot = 0
-    , _btEvent = \b w -> set (buttons . ix (_btID b) . btState) BtNoLabel
+    , _btEvent = ButtonPress BtNoLabel ButtonDoNothing click1S NoWorldEffect
-        . soundStart (LeverSound 0) (_btPos b) click1S Nothing $ w
     , _btID = 0
     , _btText = "Button"
     , _btState = BtOff

src/Dodge/Event/Keyboard.hs

@@ -4,6 +4,7 @@ module Dodge.Event.Keyboard
     , handleTextInput
     , guardDisconnectedID
     ) where
+import Dodge.Button.Event
 import Dodge.Terminal
 import Dodge.InputFocus
 import Dodge.Base
@@ -128,7 +129,7 @@ spaceAction w = case _hudElement $ _hud w of
     DisplayCarte -> w & hud . carteCenter .~ theLoc
     DisplayInventory NoSubInventory -> case selectedCloseObject w of
         Just (_,Left flit) -> pickUpItem 0 flit w
-        Just (_,Right but) -> _btEvent but but w
+        Just (_,Right but) -> doButtonEvent (_btEvent but) but w
         _                  -> w
     DisplayInventory DisplayTerminal {} -> w & hud . hudElement .~ DisplayInventory NoSubInventory
     _ -> w & hud . hudElement .~ DisplayInventory NoSubInventory

src/Dodge/LevelGen/Switch.hs

@@ -16,32 +16,17 @@ import qualified IntMapHelp as IM
 import Control.Lens
 makeButton 
     :: Color 
-    -> (World -> World) -- ^ Effect when pressed
+    -> WorldEffect -- ^ Effect when pressed
     -> Button
 makeButton col eff = defaultButton
-    { _btPict = defaultDrawButton col
+    { _btPict = DefaultDrawButton col
-    , _btEvent = \b w -> eff 
+    , _btEvent = ButtonPress BtNoLabel ButtonDoNothing click1S eff
-        . over buttons (IM.adjust turnOn (_btID b))
-        . soundFromGeneral (LeverSound 0) (btpos b) click1S Nothing $ w
     , _btText = "Button"
     , _btState = BtOff
     }
   where
-    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 . upperPrismPoly 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10
-        , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperPrismPoly 2 $ reverse
-            $ rectNSWE 10 0 (-2) 2
-        ]   
-        , mempty)
 
 drawSwitchWire :: Color -> Color -> Button -> SPic
 drawSwitchWire col1 col2 bt
@@ -56,30 +41,23 @@ drawSwitchWire col1 col2 bt
         , mempty)
 
 makeSwitchSPic
-    :: (Button -> SPic)
+    :: ButtonDraw
-    -> (World -> World) -- ^ Switch on effect
+    -> WorldEffect -- ^ Switch on effect
-    -> (World -> World) -- ^ Switch off effect
+    -> WorldEffect -- ^ Switch off effect
     -> Button
 makeSwitchSPic dswitch effOn effOff = defaultButton
     { _btPict = dswitch
-    , _btEvent = flipSwitch
+    , _btEvent = ButtonSimpleSwith effOn effOff
     , _btText = "SWITCH/"
     , _btState = BtOff
     }
   where 
-    flipSwitch b = switchEffect b . soundFromGeneral (LeverSound 0) (bpos b) click1S Nothing
     bpos b w = _btPos $ _buttons w IM.! _btID b
-    switchEffect b = case _btState b of
-        BtOff -> effOn  . (buttons . ix (_btID b) %~ turnOn )
-        BtOn  -> effOff . (buttons . ix (_btID b) %~ turnOff)
-        _ -> error "Trying to switch a button with no label"
-    turnOn  = (btState .~ BtOn ) .  (btText .~ "SWITCH\\")
-    turnOff = (btState .~ BtOff) .  (btText .~ "SWITCH/")
     
 makeSwitch
     :: Color
     -> Color
-    -> (World -> World) -- ^ Switch on effect
+    -> WorldEffect -- ^ Switch on effect
-    -> (World -> World) -- ^ Switch off effect
+    -> WorldEffect -- ^ Switch off effect
     -> Button
-makeSwitch col1 col2 f1 = (btColor .~ col1) . makeSwitchSPic (drawSwitch col1 col2) f1
+makeSwitch col1 col2 f1 = makeSwitchSPic (DefaultDrawSwitch col1 col2) f1

src/Dodge/Placement/Instance/Button.hs

@@ -13,16 +13,15 @@ import ShapePicture
 import Data.Maybe
 import Control.Lens
 
-triggerSwitchSPic :: (Button -> SPic) -> PlacementSpot -> Placement
+triggerSwitchSPic :: ButtonDraw -> PlacementSpot -> Placement
 triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger False)
-    $ \tp -> Just $ pContID ps (PutButton (makeSwitchSPic sdraw (oneff $ trigid tp) (offeff $ trigid tp))) 
+    $ \tp -> Just $ pContID ps (PutButton (makeSwitchSPic sdraw (SetTrigger True $ trigid tp) 
+        (SetTrigger False $ trigid tp))) 
                     (const Nothing)
   where
     trigid tp = fromJust $ _plMID tp
-    oneff  tid = triggers . ix tid .~ True
-    offeff tid = triggers . ix tid .~ False
 
-triggerSwitchSPicLight :: (Button -> SPic) -> PlacementSpot -> Placement
+triggerSwitchSPicLight :: ButtonDraw -> PlacementSpot -> Placement
 triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False)
     $ \tp -> Just $ pContID atFstLnkOut (PutLS thels)
     $ \lsid -> Just 
@@ -32,18 +31,16 @@ triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False)
     thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
     trigid tp = fromJust $ _plMID tp
     eff lsid tid b c = (triggers . ix tid .~ b)
-        . (lightSources . ix lsid . lsParam . lsCol .~ c)
+    oneff  lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
-    oneff  lsid tid = eff lsid tid True (V3 0 0.5 0) 
+    offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]
-    offeff lsid tid = eff lsid tid False (V3 0.5 0 0)
 
 triggerSwitch :: Color -> PlacementSpot -> Placement
 triggerSwitch col ps = psPtCont ps (PutTrigger False)
-    $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp))) 
+    $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (SetTrigger True $ trigid tp) 
+        (SetTrigger False $ trigid tp))) 
                     (const Nothing)
   where
     trigid tp = fromJust $ _plMID tp
-    oneff  tid = triggers . ix tid .~ True
-    offeff tid = triggers . ix tid .~ False
 
 putLitButOnPos :: Color 
     -> PlacementSpot 
@@ -53,7 +50,7 @@ putLitButOnPos col theps subpl
     $ \plmnt -> jps0' (PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)) {_btPos = V2 0 (-1), _btRot = pi})
                 subpl <&> plSpot .~ _plSpot plmnt
   where
-    changeLight lsid = lightSources . ix lsid . lsParam . lsCol .~ V3 0 0.5 0
+    changeLight lsid = SetLSCol (V3 0 0.5 0) lsid
     ls = lsRadCol 75 (V3 0.5 0 0)
 
 -- creates a lit external trigger, passes the trigger placement forward
@@ -85,11 +82,11 @@ putLitButOnPosExtTrig' col thePS cnt
     = psPtCont thePS (PutTrigger False)
     $ \tp -> Just $ plSpot .~ _plSpot tp $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
     $ \plmnt -> jps0' (PutButton 
-            (makeButton col (changeLight (fromJust $ _plMID plmnt) . oneff (trigid tp))) 
+            (makeButton col (WorldEffects [changeLight (fromJust $ _plMID plmnt), oneff (trigid tp)])) 
                 {_btPos = V2 0 (-1), _btRot = pi})
             (cnt tp plmnt) <&> plSpot .~ _plSpot plmnt
   where
     trigid tp = fromJust $ _plMID tp
-    oneff tid = triggers . ix tid .~ True
+    oneff tid = SetTrigger True tid
-    changeLight lsid = lightSources . ix lsid . lsParam . lsCol .~ V3 0 0.5 0
+    changeLight = SetLSCol (V3 0 0.5 0)
     ls = lsRadCol 75 (V3 0.5 0 0)

src/Dodge/Placement/Instance/Door.hs

@@ -63,7 +63,8 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
         . IM.filter isAnimate . _creatures
 
 switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
-switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id)
+switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) 
+    (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
     $ \btid -> jsps0J (doorbetween btid dra drc)
     $          sps0   (doorbetween btid drb drc)
   where

src/Dodge/Placement/Instance/Terminal.hs

@@ -5,6 +5,7 @@ module Dodge.Placement.Instance.Terminal
     , simpleTermMessage
     , terminalColor
     , terminalSPic
+    , accessTerminal
     ) where
 import Dodge.Data
 import Dodge.LevelGen.Data
@@ -52,10 +53,10 @@ putMessageTerminal col = putTerminal $ defaultMachine
 
 termButton :: Button
 termButton = Button
-    { _btPict   = const mempty
+    { _btPict   = DrawNoButton
     , _btPos    = 0
     , _btRot    = 0
-    , _btEvent  = accessTerminal . _btTermMID
+    , _btEvent  = ButtonAccessTerminal
     , _btID     = 0
     , _btText   = "TERMINAL"
     , _btState  = BtOff

src/Dodge/Render/ShapePicture.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
     ) where
+import Dodge.Button.Draw
 import Dodge.LightSource.Draw
 import Dodge.Targeting.Draw
 import Dodge.Beam.Draw
@@ -299,7 +300,7 @@ floorItemSPic flit = uncurryV translateSPf (_flItPos flit)
 
 btSPic :: Button -> SPic
 btSPic bt = uncurryV translateSPf (_btPos bt)
-    $ rotateSP (_btRot bt) (_btPict bt bt)
+    $ rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
 mcSPic :: Machine -> SPic
 mcSPic bt = uncurryV translateSPf (_mcPos bt)
     $ rotateSP (_mcDir bt) (_mcDraw bt bt)

src/Dodge/Room/Airlock.hs

@@ -26,7 +26,7 @@ airlock0 = defaultRoom
     , _rmLinks = muout lnks ++ muin [last lnks]
     , _rmPath  = foldMap doublePairSet [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
     , _rmPmnts    = 
-        [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
+        [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
             $ \btid -> Just $ putDoubleDoorThen DoorObstacle thewall (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2
                 $ \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (cond' btid) (V2 0 80) (V2 40 80) 2
         , invisibleWall $ rectNSWE 60 40 (-40) (-30)
@@ -59,7 +59,7 @@ airlockSimple = defaultRoom
     , _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
     , _rmPath  = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
     , _rmPmnts = 
-        [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
+        [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
             $ \btid -> airlockDoubleDoor 0 (V2 180 0) col (cond btid) outDoorps inDoorps
 --            jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps)
 --            $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps)
@@ -86,7 +86,7 @@ airlockZ = defaultRoom
 --         ,(V2 40 0,V2 0 40)
 --         ]
     , _rmPmnts = 
-        [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
+        [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
             $ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (cond btid) outDoorps inDoorps
 --            jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps)
 --            $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps)
@@ -121,7 +121,7 @@ airlock90 = defaultRoom
     , _rmLinks = muout[(V2 0 40,pi/2)] ++ muin[(V2 40 0,pi) ]
     , _rmPath  = doublePairSet (V2 0 40,V2 40 0)
     , _rmPmnts    = 
-        [ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id)
+        [ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
             $ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (cond btid) pss
         , mntLS vShape (V2 35 35) (V3 70 70 50)
         ]
@@ -146,7 +146,7 @@ airlockCrystal = defaultRoom
     , _rmLinks = muout[(V2 20 130,0) ] ++ muin[(V2 20  0 ,pi) ]
     , _rmPath  = mempty
     , _rmPmnts    = 
-        [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
+        [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
             $ \btid -> jsps0 $ airlockDoor col (cond btid) pss
         , crystalLine (V2 0 70) (V2 40 70)
         , mntLS vShape (V2 150 70) (V3 110 70 70)

src/Dodge/Room/LongDoor.hs

@@ -45,7 +45,7 @@ twinSlowDoorRoom w h x = defaultRoom
         ++ [uncurry inLink (V2 0 (-h), pi) ]
     , _rmPath   = mempty
     , _rmPmnts     = 
-        [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
+        [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col NoWorldEffect)
             $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h))
             $ ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-x) 1) (V2 (-x) h))
             $ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampheight)))

src/Dodge/Room/Procedural.hs

@@ -266,7 +266,7 @@ centerVaultRoom w h d = return $ defaultRoom
   where
     col = dim $ dim $ bright red
     theDoor = 
-        [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
+        [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
             $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-21) 0) (V2 0 0))
             $          sPS   (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2   21  0) (V2 0 0))
         ]

src/Dodge/WorldEffect.hs

@@ -0,0 +1,12 @@
+module Dodge.WorldEffect where
+import Dodge.Data
+import Dodge.Placement.Instance.Terminal
+
+import Control.Lens
+
+doWorldEffect :: WorldEffect -> World -> World
+doWorldEffect we = case we of
+    NoWorldEffect -> id
+    SetTrigger bool tid -> triggers . ix tid .~ bool
+    SetLSCol col lsid -> lightSources . ix lsid . lsParam . lsCol .~ col
+    AccessTerminal mtmid -> accessTerminal mtmid