From b58444f9317f01e8cc8e117c7074f82f982e6a08 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 21 Jul 2022 18:22:08 +0100 Subject: [PATCH] Move button data --- src/Dodge/Button/Draw.hs | 36 +++++++++++++++++ src/Dodge/Button/Event.hs | 33 ++++++++++++++++ src/Dodge/Data.hs | 21 +++------- src/Dodge/Data/Button.hs | 50 ++++++++++++++++++++++++ src/Dodge/Data/WorldEffect.hs | 8 ++++ src/Dodge/Default.hs | 15 +------ src/Dodge/Event/Keyboard.hs | 3 +- src/Dodge/LevelGen/Switch.hs | 42 +++++--------------- src/Dodge/Placement/Instance/Button.hs | 29 ++++++-------- src/Dodge/Placement/Instance/Door.hs | 3 +- src/Dodge/Placement/Instance/Terminal.hs | 5 ++- src/Dodge/Render/ShapePicture.hs | 3 +- src/Dodge/Room/Airlock.hs | 10 ++--- src/Dodge/Room/LongDoor.hs | 2 +- src/Dodge/Room/Procedural.hs | 2 +- src/Dodge/WorldEffect.hs | 12 ++++++ 16 files changed, 185 insertions(+), 89 deletions(-) create mode 100644 src/Dodge/Button/Draw.hs create mode 100644 src/Dodge/Button/Event.hs create mode 100644 src/Dodge/Data/Button.hs create mode 100644 src/Dodge/Data/WorldEffect.hs create mode 100644 src/Dodge/WorldEffect.hs diff --git a/src/Dodge/Button/Draw.hs b/src/Dodge/Button/Draw.hs new file mode 100644 index 000000000..d97ba82e8 --- /dev/null +++ b/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 diff --git a/src/Dodge/Button/Event.hs b/src/Dodge/Button/Event.hs new file mode 100644 index 000000000..ca01088e0 --- /dev/null +++ b/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" diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index db4d40ed0..1e3def273 100644 --- a/src/Dodge/Data.hs +++ b/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,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 diff --git a/src/Dodge/Data/Button.hs b/src/Dodge/Data/Button.hs new file mode 100644 index 000000000..84cda039b --- /dev/null +++ b/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 diff --git a/src/Dodge/Data/WorldEffect.hs b/src/Dodge/Data/WorldEffect.hs new file mode 100644 index 000000000..c844d7254 --- /dev/null +++ b/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) diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 96518fd58..1b4bed8aa 100644 --- a/src/Dodge/Default.hs +++ b/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 - . soundStart (LeverSound 0) (_btPos b) click1S Nothing $ w + , _btEvent = ButtonPress BtNoLabel ButtonDoNothing click1S NoWorldEffect , _btID = 0 , _btText = "Button" , _btState = BtOff diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 64009a481..e2dfe7f8c 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/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 diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs index 5bb5742c1..bbb457f98 100644 --- a/src/Dodge/LevelGen/Switch.hs +++ b/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 - , _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 diff --git a/src/Dodge/Placement/Instance/Button.hs b/src/Dodge/Placement/Instance/Button.hs index 694fc5f20..127474e6c 100644 --- a/src/Dodge/Placement/Instance/Button.hs +++ b/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 @@ -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) diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index f6ac97e1c..fe5573d96 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/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 diff --git a/src/Dodge/Placement/Instance/Terminal.hs b/src/Dodge/Placement/Instance/Terminal.hs index a55e83adf..1c0df34d0 100644 --- a/src/Dodge/Placement/Instance/Terminal.hs +++ b/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 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 22abc3904..c2db7b6d1 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/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) diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 6f0908150..1bfba70e0 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/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) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 86112ea46..388a6bb8f 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/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))) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index f35a4aab8..f92d8c5ba 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/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)) ] diff --git a/src/Dodge/WorldEffect.hs b/src/Dodge/WorldEffect.hs new file mode 100644 index 000000000..a6739bedb --- /dev/null +++ b/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