Move button data

2022-07-21 18:22:08 +01:00
parent aabd8a2cb8
commit b58444f931
16 changed files with 185 additions and 89 deletions
@@ -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
@@ -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"
@@ -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,7 +70,9 @@ module Dodge.Data
    , module Dodge.Data.RadarBlip
    , module Dodge.Data.PathGraph
    ) where
-import  Dodge.Data.Item.Params
+import Dodge.Data.WorldEffect
+import Dodge.Data.Button
+import Dodge.Data.Item.Params
 import Dodge.Data.Beam
 import Dodge.Data.Targeting
 import Dodge.Data.ItEffect
@@ -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
@@ -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
@@ -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)
@@ -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
-        . soundStart (LeverSound 0) (_btPos b) click1S Nothing $ w
+    , _btEvent = ButtonPress BtNoLabel ButtonDoNothing click1S NoWorldEffect
    , _btID = 0
    , _btText = "Button"
    , _btState = BtOff
@@ -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
@@ -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
-    , _btEvent = \b w -> eff 
-        . over buttons (IM.adjust turnOn (_btID b))
-        . soundFromGeneral (LeverSound 0) (btpos b) click1S Nothing $ w
+    { _btPict = DefaultDrawButton col
+    , _btEvent = ButtonPress BtNoLabel ButtonDoNothing click1S eff
    , _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)
-    -> (World -> World) -- ^ Switch on effect
-    -> (World -> World) -- ^ Switch off effect
+    :: ButtonDraw
+    -> WorldEffect -- ^ Switch on 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
-    -> (World -> World) -- ^ Switch off effect
+    -> WorldEffect -- ^ Switch on 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
@@ -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 
@@ -31,19 +30,17 @@ triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False)
  where
    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 = eff lsid tid True (V3 0 0.5 0) 
-    offeff lsid tid = eff lsid tid False (V3 0.5 0 0)
+    eff lsid tid b c = (triggers . ix tid .~ b)
+    oneff  lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
+    offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]

 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
-    changeLight lsid = lightSources . ix lsid . lsParam . lsCol .~ V3 0 0.5 0
+    oneff tid = SetTrigger True tid
+    changeLight = SetLSCol (V3 0 0.5 0)
    ls = lsRadCol 75 (V3 0.5 0 0)
@@ -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
@@ -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
@@ -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)
@@ -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)
@@ -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)))
@@ -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))
        ]
@@ -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