From d219d8d889358019ecc18cd5e46bae0bcfaff1c5 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 25 Jul 2022 00:45:15 +0100 Subject: [PATCH] Broken: refactor terminals --- src/Dodge/Button/Event.hs | 2 +- src/Dodge/Data.hs | 66 +---- src/Dodge/Data/Button.hs | 6 +- src/Dodge/Data/Corpse.hs | 4 +- src/Dodge/Data/ForegroundShape.hs | 2 +- src/Dodge/Data/Machine.hs | 4 +- src/Dodge/Data/Sensor.hs | 6 +- src/Dodge/Data/Terminal.hs | 99 +++++++ src/Dodge/Data/WorldEffect.hs | 11 +- src/Dodge/Default.hs | 27 +- src/Dodge/Default/Terminal.hs | 32 +++ src/Dodge/Event.hs | 17 +- src/Dodge/Item/Weapon/TriggerType.hs | 3 +- src/Dodge/LevelGen/Switch.hs | 10 +- src/Dodge/Machine/Destroy.hs | 4 +- src/Dodge/Placement/Instance/LightSource.hs | 3 - src/Dodge/Placement/Instance/Terminal.hs | 23 +- src/Dodge/Prop/Draw.hs | 2 +- src/Dodge/Room/Warning.hs | 3 +- src/Dodge/Terminal.hs | 277 +++++--------------- src/Dodge/TerminalCommandEffect.hs | 4 + src/Dodge/TmTm.hs | 9 + src/Dodge/TmWdWd.hs | 6 + src/Dodge/Update.hs | 13 +- src/Dodge/WorldEffect.hs | 236 ++++++++++++++++- 25 files changed, 505 insertions(+), 364 deletions(-) create mode 100644 src/Dodge/Data/Terminal.hs create mode 100644 src/Dodge/Default/Terminal.hs create mode 100644 src/Dodge/TerminalCommandEffect.hs create mode 100644 src/Dodge/TmTm.hs create mode 100644 src/Dodge/TmWdWd.hs diff --git a/src/Dodge/Button/Event.hs b/src/Dodge/Button/Event.hs index ca01088e0..6bf549e8c 100644 --- a/src/Dodge/Button/Event.hs +++ b/src/Dodge/Button/Event.hs @@ -17,7 +17,7 @@ doButtonEvent be = case be of ButtonSimpleSwith oneff offeff -> flipSwitch oneff offeff ButtonAccessTerminal -> accessTerminal . _btTermMID -flipSwitch :: WorldEffect -> WorldEffect -> Button -> World -> World +flipSwitch :: WdWd -> WdWd -> Button -> World -> World flipSwitch oneff offeff bt | _btState bt == BtOff = doWorldEffect oneff . dosound . over (buttons . ix (_btID bt)) turnon diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 300e1ccf6..152e91987 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -86,7 +86,9 @@ module Dodge.Data , module Dodge.Data.MountedObject , module Dodge.Data.Machine , module Dodge.Data.GenParams + , module Dodge.Data.Terminal ) where +import Dodge.Data.Terminal import Dodge.Data.GenParams import Dodge.Data.Machine import Dodge.Data.MountedObject @@ -255,8 +257,8 @@ data World = World , _randGen :: StdGen , _modifications :: IM.IntMap Modification , _yourID :: Int - , _worldEvents :: [WorldEffect] - , _delayedEvents :: [(Int,WorldEffect)] + , _worldEvents :: [WdWd] + , _delayedEvents :: [(Int,WdWd)] , _pressPlates :: IM.IntMap PressPlate , _buttons :: IM.IntMap Button , _toPlaySounds :: M.Map SoundOrigin Sound @@ -355,19 +357,6 @@ data MenuOption { _moKey :: Scancode , _moEff :: Universe -> IO (Maybe Universe) } -data TerminalLine - = TerminalLineDisplay - {_tlPause :: Int - ,_tlString :: World -> (String, Color) - } - | TerminalLineTerminalEffect - {_tlPause :: Int - ,_tlTermEffect :: Terminal -> Terminal - } - | TerminalLineEffect - {_tlPause :: Int - ,_tlEffect :: Terminal -> World -> World - } data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int} deriving (Eq,Ord,Show,Read) @@ -402,49 +391,6 @@ type HitEffect' = Flame -> (World,Maybe Flame) data Either3 a b c = E3x1 a | E3x2 b | E3x3 c -data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady - deriving (Eq,Ord,Show) -data TerminalInput = TerminalInput - { _tiText :: T.Text - , _tiFocus :: Bool - , _tiSel :: (Int,Int) - } -data Terminal = Terminal - { _tmID :: Int - , _tmBootProgram :: Terminal -> World -> [TerminalLine] - , _tmButtonID :: Int - , _tmMachineID :: Int - , _tmName :: String - , _tmDisplayedLines :: [(String,Color)] - , _tmFutureLines :: [TerminalLine] - , _tmMaxLines :: Int - , _tmTitle :: String - , _tmInput :: TerminalInput - , _tmScrollCommands :: [TerminalCommand] - , _tmWriteCommands :: [TerminalCommand] - , _tmDeathEffect :: Terminal -> World -> World - , _tmStatus :: TerminalStatus - , _tmCommandHistory :: [String] - , _tmToggles :: M.Map String TerminalToggle - } -data TerminalToggle = TerminalToggle - { _ttTriggerID :: Int - , _ttDeathEffect :: Bool -> Bool - } - -data EffectArguments - = NoArguments {_cmdEffect :: [TerminalLine]} - | OneArgument - {_argType :: String - ,_argList :: M.Map String [TerminalLine] - } - -data TerminalCommand = TerminalCommand - { _tcString :: String - , _tcAlias :: [String] - , _tcHelp :: String - , _tcEffect :: Terminal -> World -> EffectArguments - } ---- ROOM DATATYPES data PSType = PutCrit {_unPutCrit :: Creature} @@ -547,16 +493,12 @@ data InPlacement = InPlacement makeLenses ''World makeLenses ''FloorItem --makeLenses ''Particle -makeLenses ''Terminal makeLenses ''Universe makeLenses ''GunBarrels makeLenses ''Nozzle -makeLenses ''TerminalLine makeLenses ''Equipment makeLenses ''ScreenLayer makeLenses ''WorldBeams -makeLenses ''TerminalCommand -makeLenses ''TerminalInput ----- ROOM LENSES makeLenses ''Room diff --git a/src/Dodge/Data/Button.hs b/src/Dodge/Data/Button.hs index 84cda039b..1fc76102c 100644 --- a/src/Dodge/Data/Button.hs +++ b/src/Dodge/Data/Button.hs @@ -15,7 +15,7 @@ data ButtonEvent = ButtonDoNothing {_bpState :: ButtonState ,_bpEvent :: ButtonEvent ,_bpSound :: SoundID - ,_bpEff :: WorldEffect + ,_bpEff :: WdWd } -- | ButtonSwitch -- {_bonState :: ButtonState @@ -28,8 +28,8 @@ data ButtonEvent = ButtonDoNothing -- ,_boffEff :: WorldEffect -- } | ButtonSimpleSwith - {_bonEff :: WorldEffect - ,_boffEff :: WorldEffect + {_bonEff :: WdWd + ,_boffEff :: WdWd } | ButtonAccessTerminal diff --git a/src/Dodge/Data/Corpse.hs b/src/Dodge/Data/Corpse.hs index 920e43ef3..36363b043 100644 --- a/src/Dodge/Data/Corpse.hs +++ b/src/Dodge/Data/Corpse.hs @@ -5,9 +5,8 @@ import ShapePicture.Data import Geometry.Data import Control.Lens - data CorpseResurrection = NoResurrection - + deriving (Eq,Ord,Show,Read) data Corpse = Corpse { _cpID :: Int , _cpPos :: Point2 @@ -15,4 +14,5 @@ data Corpse = Corpse , _cpSPic :: SPic , _cpRes :: CorpseResurrection } + deriving (Eq,Ord,Show,Read) makeLenses ''Corpse diff --git a/src/Dodge/Data/ForegroundShape.hs b/src/Dodge/Data/ForegroundShape.hs index 9f25a4af9..5fe9a936f 100644 --- a/src/Dodge/Data/ForegroundShape.hs +++ b/src/Dodge/Data/ForegroundShape.hs @@ -12,5 +12,5 @@ data ForegroundShape = ForegroundShape , _fsRad :: Float -- This should probably be a bounding box , _fsSPic :: SPic } - deriving () + deriving (Eq,Ord,Show,Read) makeLenses ''ForegroundShape diff --git a/src/Dodge/Data/Machine.hs b/src/Dodge/Data/Machine.hs index 8e10773dd..d8c2fad52 100644 --- a/src/Dodge/Data/Machine.hs +++ b/src/Dodge/Data/Machine.hs @@ -20,6 +20,7 @@ data MachineDraw = MachineDrawMempty | MachineDrawTerminal | MachineDrawTurret | MachineDrawDamageSensor Float (PaletteColor,DecorationShape) + deriving (Eq,Ord,Show,Read) data Machine = Machine { _mcID :: Int , _mcWallIDs :: IS.IntSet @@ -36,6 +37,7 @@ data Machine = Machine , _mcName :: String , _mcCloseSound :: Maybe SoundID } + deriving (Eq,Ord,Show,Read) data MachineType = StaticMachine | Turret @@ -44,6 +46,6 @@ data MachineType , _tuFireTime :: Int , _tuMCrID :: Maybe Int } - + deriving (Eq,Ord,Show,Read) makeLenses ''Machine makeLenses ''MachineType diff --git a/src/Dodge/Data/Sensor.hs b/src/Dodge/Data/Sensor.hs index 0449e6413..32d59dde9 100644 --- a/src/Dodge/Data/Sensor.hs +++ b/src/Dodge/Data/Sensor.hs @@ -17,13 +17,13 @@ data Sensor = NoSensor , _proxRequirement :: ProximityRequirement , _sensToggle :: Bool } - deriving (Eq,Ord) + deriving (Eq,Ord,Show,Read) data ProximityRequirement = RequireHealth {_proxReqMinHealth :: Int} | RequireEquipment {_proxReqEquipment :: ItemBaseType} | RequireImpossible - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Read) data CloseToggle = NotClose | IsClose - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Read) makeLenses ''Sensor makeLenses ''ProximityRequirement diff --git a/src/Dodge/Data/Terminal.hs b/src/Dodge/Data/Terminal.hs new file mode 100644 index 000000000..0edcf66dd --- /dev/null +++ b/src/Dodge/Data/Terminal.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data.Terminal + where +import Dodge.Data.WorldEffect +import Color +import Control.Lens +import qualified Data.Text as T +import qualified Data.Map.Strict as M +data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady + deriving (Eq,Ord,Show,Read) +data TerminalInput = TerminalInput + { _tiText :: T.Text + , _tiFocus :: Bool + , _tiSel :: (Int,Int) + } + deriving (Eq,Ord,Show,Read) +data TerminalBootProgram = TerminalBootMempty + | TerminalBootLines [TerminalLine] + deriving (Eq,Ord,Show,Read) +data Terminal = Terminal + { _tmID :: Int + , _tmBootProgram :: TerminalBootProgram -- Terminal -> World -> [TerminalLine] + , _tmButtonID :: Int + , _tmMachineID :: Int + , _tmName :: String + , _tmDisplayedLines :: [(String,Color)] + , _tmFutureLines :: [TerminalLine] + , _tmMaxLines :: Int + , _tmTitle :: String + , _tmInput :: TerminalInput + , _tmScrollCommands :: [TerminalCommand] + , _tmWriteCommands :: [TerminalCommand] + , _tmDeathEffect :: TmWdWd -- Terminal -> World -> World + , _tmStatus :: TerminalStatus + , _tmCommandHistory :: [String] + , _tmToggles :: M.Map String TerminalToggle + } + deriving (Eq,Ord,Show,Read) +data TerminalLineString = TerminalLineConst String Color + deriving (Eq,Ord,Show,Read) +data TmTm = TmId + | TmTmClearDisplayedLines + | TmTmSetStatus TerminalStatus + deriving (Eq,Ord,Show,Read) +data TerminalLine + = TerminalLineDisplay + {_tlPause :: Int + ,_tlString :: TerminalLineString -- World -> (String, Color) + } + | TerminalLineTerminalEffect + {_tlPause :: Int + ,_tlTermEffect :: TmTm -- Terminal -> Terminal + } + | TerminalLineEffect + {_tlPause :: Int + ,_tlEffect :: TmWdWd --Terminal -> World -> World + } + deriving (Eq,Ord,Show,Read) +data TerminalToggle = TerminalToggle + { _ttTriggerID :: Int + , _ttDeathEffect :: BlBl + } + deriving (Eq,Ord,Show,Read) +data BlBl = BlNegate + | BlConst Bool + | BlId + deriving (Eq,Ord,Show,Read) + +data EffectArguments + = NoArguments {_cmdEffect :: [TerminalLine]} + | OneArgument + {_argType :: String + ,_argList :: M.Map String [TerminalLine] + } + deriving (Eq,Ord,Show,Read) + +data TerminalCommandEffect = TerminalCommandArguments EffectArguments + | TerminalCommandEffectDamageCoding + | TerminalCommandEffectSensorParameter + | TerminalCommandEffectLinkedObject + | TerminalCommandEffectHelp + | TerminalCommandEffectNoArgumentsStr String + | TerminalCommandEffectCommands + | TerminalCommandEffectSingleCommand WdWd [String] + | TerminalCommandEffectNone + deriving (Eq,Ord,Show,Read) + +data TerminalCommand = TerminalCommand + { _tcString :: String + , _tcAlias :: [String] + , _tcHelp :: String + , _tcEffect :: TerminalCommandEffect -- Terminal -> World -> EffectArguments + } + deriving (Eq,Ord,Show,Read) +makeLenses ''Terminal +makeLenses ''TerminalLine +makeLenses ''TerminalCommand +makeLenses ''TerminalInput diff --git a/src/Dodge/Data/WorldEffect.hs b/src/Dodge/Data/WorldEffect.hs index 8256bf633..54b98695d 100644 --- a/src/Dodge/Data/WorldEffect.hs +++ b/src/Dodge/Data/WorldEffect.hs @@ -3,15 +3,16 @@ import Dodge.Data.CreatureEffect import Sound.Data import Geometry.Data import Dodge.Data.SoundOrigin -data WorldEffect = NoWorldEffect +data WdWd = NoWorldEffect | SetTrigger Bool Int - | WorldEffects [WorldEffect] + | WorldEffects [WdWd] | SetLSCol Point3 Int | AccessTerminal (Maybe Int) | UnlockInv Int | SoundStart SoundOrigin Point2 SoundID (Maybe Int) | MakeStartCloudAt Point3 | TorqueCr Float Int + | WdWdNegateTrig Int deriving (Eq,Ord,Show,Read) data WdP2 = WdP2Const Point2 | WdYouPos @@ -37,3 +38,9 @@ data DrWdWd = DrWdId | DrWdMechanismStepwise Int [Int] [(Point2,Point2)] | DoorMechanism deriving (Eq,Ord,Show,Read) +data TmWdWd = TmWdId + | TmWdWdDisconnectTerminal + | TmWdWdfromWdWd WdWd + | TmWdWdTermSound SoundID + | TmWdWdDoDeathTriggers + deriving (Eq,Ord,Show,Read) diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 757833aa7..5979d48dd 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -11,7 +11,9 @@ module Dodge.Default , module Dodge.Default.Weapon , module Dodge.Default.Wall , module Dodge.Default.Creature + , module Dodge.Default.Terminal ) where +import Dodge.Default.Terminal import Dodge.Default.Wall import Dodge.Default.Creature import Dodge.Default.Weapon @@ -58,31 +60,6 @@ defaultMachine = Machine , _mcMounts = mempty , _mcCloseSound = Nothing } -defaultTerminal :: Terminal -defaultTerminal = Terminal - { _tmID = 0 - , _tmBootProgram = \_ _ -> [] - , _tmButtonID = 0 - , _tmMachineID = 0 - , _tmName = "TESTTERMINAL" - , _tmDisplayedLines = [] - , _tmFutureLines = [] - , _tmMaxLines = 14 - , _tmTitle = "TERMINAL IN LOCATION" - , _tmInput = defaultTerminalInput - , _tmScrollCommands = [] - , _tmWriteCommands = [] - , _tmDeathEffect = const id - , _tmStatus = TerminalOff - , _tmCommandHistory = [] - , _tmToggles = M.empty - } -defaultTerminalInput :: TerminalInput -defaultTerminalInput = TerminalInput - { _tiText = T.pack "" - , _tiFocus = True - , _tiSel = (0,0) - } defaultButton :: Button defaultButton = Button diff --git a/src/Dodge/Default/Terminal.hs b/src/Dodge/Default/Terminal.hs new file mode 100644 index 000000000..cf917124d --- /dev/null +++ b/src/Dodge/Default/Terminal.hs @@ -0,0 +1,32 @@ +module Dodge.Default.Terminal + where +import Dodge.Data.WorldEffect +import Dodge.Data.Terminal +import qualified Data.Map.Strict as M +import qualified Data.Text as T +defaultTerminal :: Terminal +defaultTerminal = Terminal + { _tmID = 0 + , _tmBootProgram = TerminalBootMempty + , _tmButtonID = 0 + , _tmMachineID = 0 + , _tmName = "TESTTERMINAL" + , _tmDisplayedLines = [] + , _tmFutureLines = [] + , _tmMaxLines = 14 + , _tmTitle = "TERMINAL IN LOCATION" + , _tmInput = defaultTerminalInput + , _tmScrollCommands = [] + , _tmWriteCommands = [] + , _tmDeathEffect = TmWdId + , _tmStatus = TerminalOff + , _tmCommandHistory = [] + , _tmToggles = M.empty + } +defaultTerminalInput :: TerminalInput +defaultTerminalInput = TerminalInput + { _tiText = T.pack "" + , _tiFocus = True + , _tiSel = (0,0) + } + diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index cd815d81a..a3dd762d6 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -14,6 +14,7 @@ the simulation step; in particular see 'updatePressedButtons'. module Dodge.Event ( handleEvent ) where +import Dodge.Terminal import Dodge.Tweak import Dodge.HeldScroll import Dodge.InputFocus @@ -142,7 +143,7 @@ getArguments' :: TerminalCommand -> Terminal -> World -> [String] getArguments' tc tm = ("" :) . getArguments tc tm getArguments :: TerminalCommand -> Terminal -> World -> [String] -getArguments tc tm w = case _tcEffect tc tm w of +getArguments tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of NoArguments {} -> [] OneArgument _ m -> M.keys m @@ -153,7 +154,7 @@ nullCommand = TerminalCommand { _tcString = "" , _tcAlias = [] , _tcHelp = "" - , _tcEffect = \_ _ -> NoArguments [] + , _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments [] } scrollRBOption :: Float -> World -> World @@ -162,18 +163,6 @@ scrollRBOption y w | y > 0 = w & rbOptions . opSel %~ (max 0 . subtract 1) | otherwise = w --- nice idea, but the chain of setters and getters seems prohibitive ---scrollOver :: Foldable t --- => ASetter s s Int Int -- index setter --- -> Getting (First (t a)) s (t a) -- pointer to object of size --- -> Float -- direction --- -> s -> s ---scrollOver theset theget y w = case w ^? theget of --- Just t -> w & theset %~ ( (`mod` length t) . (subtract y')) --- Nothing -> w --- where --- y' = round $ signum y - moveTweakSel :: Int -> World -> World moveTweakSel i w = case yourItem w ^? _Just . itTweaks . tweakParams of Just l -> w & creatures . ix (_yourID w) . crInv . ix (crSel (you w)) diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index cd69a4c51..d2f5f4fd7 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -63,6 +63,7 @@ module Dodge.Item.Weapon.TriggerType , modClock , ammoHammerCheck ) where +import Dodge.Data.WorldEffect import Dodge.Data import Dodge.Base.Collide import Dodge.SoundLogic @@ -543,7 +544,7 @@ spreadLoaded eff item cr w = foldr f w dirs numBulLoaded = _laLoaded $ _itConsumption item sideEffectOnFrame :: Int - -> (Item -> Creature -> WorldEffect) + -> (Item -> Creature -> WdWd) -> ChainEffect sideEffectOnFrame i sf f it cr w = f it cr w & delayedEvents .:~ (i, sf it cr) diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs index b5b6049b9..e3d5a510c 100644 --- a/src/Dodge/LevelGen/Switch.hs +++ b/src/Dodge/LevelGen/Switch.hs @@ -14,7 +14,7 @@ import Geometry makeButton :: Color - -> WorldEffect -- ^ Effect when pressed + -> WdWd -- ^ Effect when pressed -> Button makeButton col eff = defaultButton { _btPict = DefaultDrawButton col @@ -38,8 +38,8 @@ drawSwitchWire col1 col2 bt makeSwitchSPic :: ButtonDraw - -> WorldEffect -- ^ Switch on effect - -> WorldEffect -- ^ Switch off effect + -> WdWd -- ^ Switch on effect + -> WdWd -- ^ Switch off effect -> Button makeSwitchSPic dswitch effOn effOff = defaultButton { _btPict = dswitch @@ -51,7 +51,7 @@ makeSwitchSPic dswitch effOn effOff = defaultButton makeSwitch :: Color -> Color - -> WorldEffect -- ^ Switch on effect - -> WorldEffect -- ^ Switch off effect + -> WdWd -- ^ Switch on effect + -> WdWd -- ^ Switch off effect -> Button makeSwitch col1 col2 = makeSwitchSPic (DefaultDrawSwitch col1 col2) diff --git a/src/Dodge/Machine/Destroy.hs b/src/Dodge/Machine/Destroy.hs index 933ce6c12..cb8ad2365 100644 --- a/src/Dodge/Machine/Destroy.hs +++ b/src/Dodge/Machine/Destroy.hs @@ -1,4 +1,6 @@ module Dodge.Machine.Destroy where +import Dodge.WorldEffect +import Dodge.Terminal import Dodge.Wall.Delete import Dodge.Data import Dodge.WorldEvent.Explosion @@ -19,7 +21,7 @@ mcKillTerm mc w = fromMaybe w $ do tmid <- mc ^? mcMounts . ix ObTerminal tm <- w ^? terminals . ix tmid return $ w - & _tmDeathEffect tm tm + & doTmWdWd (_tmDeathEffect tm) tm mcKillBut :: Machine -> World -> World mcKillBut mc w = fromMaybe w $ do diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index 04495bbe4..54491c794 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -24,10 +24,7 @@ propLSThen :: PropUpdate -> Placement propLSThen propf lsf ls prop cont = pt0 (PutLS ls) $ \lspl -> Just $ pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf,PropUpdateLS (fromJust $ _plMID lspl) lsf]) - -- theupdate (fromJust $ _plMID lspl)) $ cont lspl - where - --theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w moveLSThen :: WdP2f --(World -> (Point2,Float)) -> Point3 -- ^ light source offset diff --git a/src/Dodge/Placement/Instance/Terminal.hs b/src/Dodge/Placement/Instance/Terminal.hs index 3fe60be8d..14aaf5653 100644 --- a/src/Dodge/Placement/Instance/Terminal.hs +++ b/src/Dodge/Placement/Instance/Terminal.hs @@ -2,15 +2,14 @@ module Dodge.Placement.Instance.Terminal ( putMessageTerminal , putTerminal - , simpleTermMessage +-- , simpleTermMessage , terminalColor - , accessTerminal +-- , accessTerminal ) where import Dodge.Data import Dodge.LevelGen.Data import Dodge.Default import Dodge.SoundLogic -import Dodge.Terminal import Color import Geometry import LensHelp @@ -61,21 +60,3 @@ termButton = Button terminalColor :: Color terminalColor = dark magenta - - -accessTerminal :: Maybe Int -> World -> World -accessTerminal mtmid w = case mtmid of - Nothing -> w - Just tmid -> w & hud . hudElement .~ DisplayInventory (DisplayTerminal tmid) - & terminals . ix tmid . tmInput . tiFocus .~ True - & terminals . ix tmid %~ tryToBoot - where - tryToBoot tm = case _tmStatus tm of - TerminalReady -> tm - TerminalBusy -> tm - TerminalOff -> tm - & tmFutureLines .~ _tmBootProgram tm tm w - & tmStatus .~ TerminalBusy - -simpleTermMessage :: [String] -> Terminal -simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs diff --git a/src/Dodge/Prop/Draw.hs b/src/Dodge/Prop/Draw.hs index 6d43fdd01..b98ebd3b0 100644 --- a/src/Dodge/Prop/Draw.hs +++ b/src/Dodge/Prop/Draw.hs @@ -15,7 +15,7 @@ drawProp :: PropDraw -> Prop -> SPic drawProp pd = case pd of PropDrawSPic spic -> const spic PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (fst $ drawProp pd' pr) - PropDrawMovingShapeCol sh -> \pr -> drawMovingShapeCol pr sh + PropDrawMovingShapeCol sh -> (`drawMovingShapeCol` sh) PropDoubleLampCover h -> drawDoubleLampCover h PropVerticalLampCover h -> drawVerticalLampCover h PropLampCover h -> drawLampCover h diff --git a/src/Dodge/Room/Warning.hs b/src/Dodge/Room/Warning.hs index f654575eb..cd52256de 100644 --- a/src/Dodge/Room/Warning.hs +++ b/src/Dodge/Room/Warning.hs @@ -1,5 +1,6 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Room.Warning where +import Dodge.WorldEffect import Dodge.Cleat import Dodge.Terminal import Dodge.PlacementSpot @@ -44,7 +45,7 @@ addWarningTerminal str outplid = (rmName .++~ "warningTerm-") termMessages trpl = lineOutputTerminal (makeColorTermLine red "WARNING":makeTermPara str) & tmScrollCommands .:~ toggleCommand & tmToggles .~ M.fromList - [("DOOR",TerminalToggle (fromJust $ _plMID trpl) (const True))] + [("DOOR",TerminalToggle (fromJust $ _plMID trpl) (BlConst True))] moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2,Float) moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of diff --git a/src/Dodge/Terminal.hs b/src/Dodge/Terminal.hs index 00845babe..468eb15d9 100644 --- a/src/Dodge/Terminal.hs +++ b/src/Dodge/Terminal.hs @@ -1,5 +1,12 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Terminal where +import Dodge.SoundLogic +import Dodge.WorldEvent.Cloud +import Dodge.Data +import Dodge.Inventory.Lock +import Dodge.Placement.Instance.Terminal +import Dodge.Data.WorldEffect +import Dodge.Data.Terminal import Dodge.Data import Dodge.Default --import Dodge.Base @@ -18,75 +25,46 @@ import qualified IntMapHelp as IM import qualified Data.Text as T --import Text.Read +import System.Random +import Control.Lens + +basicTerminal :: Terminal +basicTerminal = defaultTerminal + {_tmDisplayedLines = [] + ,_tmFutureLines = [] + ,_tmMaxLines = 14 + ,_tmTitle = "TERMINAL" + ,_tmInput = defaultTerminalInput + ,_tmScrollCommands = [quitCommand] + ,_tmWriteCommands = [helpCommand,commandsCommand] + ,_tmBootProgram = TerminalBootLines connectionBlurb + , _tmDeathEffect = TmWdWdDoDeathTriggers + } + +connectionBlurbLines :: [TerminalLine] -> [TerminalLine] +connectionBlurbLines tls = + [termSoundLine computerBeepingS + ,TerminalLineDisplay 0 (TerminalLineConst "CONNECTING" termTextColor) + ,TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor) + ,TerminalLineDisplay 10 (TerminalLineConst "CONNECTED" termTextColor) + ] ++ tls ++ + [TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)] + quitCommand :: TerminalCommand quitCommand = TerminalCommand { _tcString = "QUIT" , _tcAlias = ["Q","EXIT","X","SHUTDOWN",""] , _tcHelp = "DISCONNECTS THE TERMINAL." - , _tcEffect = \_ _ -> NoArguments [TerminalLineEffect 0 disconnectTerminal] + , _tcEffect = TerminalCommandArguments $ NoArguments [TerminalLineEffect 0 TmWdWdDisconnectTerminal] } -disconnectTerminal :: Terminal -> World -> World -disconnectTerminal tm w = w - & terminals . ix (_tmID tm) . tmStatus .~ TerminalOff - & exitTerminalSubInv - & terminals . ix (_tmID tm) . tmFutureLines .~ - [ TerminalLineTerminalEffect 0 (tmDisplayedLines .~ []) ] - -exitTerminalSubInv :: World -> World -exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of - Just _ -> w & hud . hudElement . subInventory .~ NoSubInventory - _ -> w - -damageCodeCommand :: TerminalCommand -damageCodeCommand = TerminalCommand - { _tcString = "DAMAGECODE" - , _tcAlias = ["DCODE","DC"] - , _tcHelp = "DISPLAYS THE SHAPE AND COLOR ASSOCIATED WITH A GIVEN DAMAGE TYPE." - , _tcEffect = \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding - } -getDamageCoding :: World -> M.Map String [TerminalLine] -getDamageCoding = decodedtmap . _sensorCoding . _genParams - -decodedtmap :: M.Map DamageType (PaletteColor,DecorationShape) -> M.Map String [TerminalLine] -decodedtmap = M.mapKeys show . M.map ((:[]) . makeTermLine . show) - -sensorCommand :: TerminalCommand -sensorCommand = TerminalCommand - { _tcString = "SENSOR" - , _tcAlias = ["SEN"] - , _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR." - , _tcEffect = \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm - } -sensorInfoMap :: Terminal -> World -> M.Map String [TerminalLine] -sensorInfoMap tm w = M.fromList - [("REQUIREMENT", getSensor _proxRequirement tm w) - ,("DISTANCE", getSensor _proxDist tm w) - ,("CURRENTSTATUS", getSensor _proxStatus tm w) - ,("PASTSTATUS", getSensor _sensToggle tm w) - ] -getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine] -getSensor f tm w = maybe [] (makeTermPara . map toUpper . show . f) - (w ^? machines . ix (_tmMachineID tm) . mcSensor) - -toggleCommand :: TerminalCommand -toggleCommand = TerminalCommand - { _tcString = "TOGGLE" - , _tcAlias = ["TOG"] - , _tcHelp = "PERFORMS A REVERSABLE EFFECT." - , _tcEffect = \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) - } -togglesToEffects :: Terminal -> M.Map String [TerminalLine] -togglesToEffects = fmap f . _tmToggles - where - f tt = [TerminalLineEffect 0 $ \_ -> triggers . ix (_ttTriggerID tt) %~ not] - helpCommand :: TerminalCommand helpCommand = TerminalCommand { _tcString = "HELP" , _tcAlias = ["H","MAN"] , _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND." - , _tcEffect = \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm + , _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm } + getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine] getCommandsHelp tm w = foldr f mempty $ getCommands tm where @@ -100,20 +78,37 @@ getCommandsHelp tm w = foldr f mempty $ getCommands tm (arghelp,Just args) -> makeTermPara (_tcHelp tc ++ " " ++ arghelp) ++ [makeColorTermLine commandColor $ unwords args] ) +commandsCommand :: TerminalCommand +commandsCommand = TerminalCommand + { _tcString = "COMMANDS" + , _tcAlias = ["COMMAND","COM"] + , _tcHelp = "DISPLAYS AVAILABLE COMMANDS." + , _tcEffect = TerminalCommandEffectCommands + } + +connectionBlurb :: [TerminalLine] +connectionBlurb = + [termSoundLine computerBeepingS + ,TerminalLineDisplay 0 (TerminalLineConst "CONNECTING" termTextColor) + ,TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor) + ,TerminalLineDisplay 10 (TerminalLineConst "CONNECTED" termTextColor) + ,TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)] + +termSoundLine :: SoundID -> TerminalLine +termSoundLine sid = TerminalLineEffect 0 (TmWdWdTermSound sid) +-- where +-- termsound tm w = soundStart TerminalSound tpos sid Nothing w +-- where +-- tpos = fromMaybe 0 $ w ^? buttons . ix (_tmButtonID tm) . btPos + +termTextColor :: Color +termTextColor = greyN 0.9 + getCommands :: Terminal -> [TerminalCommand] getCommands tm = _tmScrollCommands tm ++ _tmWriteCommands tm -infoClearInput :: Terminal -> [TerminalLine] -> World -> World -infoClearInput tm tls = terminals . ix (_tmID tm) %~ - ( (tmInput .~ TerminalInput T.empty True (0,0)) - . (tmFutureLines ++.~ tls) - ) - -argumentHelp :: TerminalCommand -> Terminal -> World -> (String,Maybe [String]) -argumentHelp tc tm w = case _tcEffect tc tm w of - NoArguments {} -> ("ANY ARGUMENTS PROVIDED TO THIS COMMAND ARE IGNORED.",Nothing) - OneArgument argtype argm -> ("EXPECTS " ++ argtype ++ " AS ARGUMENT. AVAILABLE ARGUMENTS: " - , Just (M.keys argm) ) +makeTermLine :: String -> TerminalLine +makeTermLine = makeColorTermLine termTextColor makeTermPara :: String -> [TerminalLine] makeTermPara = map makeTermLine . makeParagraph 60 @@ -122,151 +117,7 @@ makeColorTermPara :: Color -> String -> [TerminalLine] makeColorTermPara col = map (makeColorTermLine col) . makeParagraph 60 makeColorTermLine :: Color -> String -> TerminalLine -makeColorTermLine col str = TerminalLineDisplay 0 $ const (str,col) - -makeTermLine :: String -> TerminalLine -makeTermLine = makeColorTermLine termTextColor - -termTextColor :: Color -termTextColor = greyN 0.9 - -termSoundLine :: SoundID -> TerminalLine -termSoundLine sid = TerminalLineEffect 0 termsound - where - termsound tm w = soundStart TerminalSound tpos sid Nothing w - where - tpos = fromMaybe 0 $ w ^? buttons . ix (_tmButtonID tm) . btPos - -infoCommand :: String -> TerminalCommand -infoCommand str = TerminalCommand - { _tcString = "INFORMATION" - , _tcAlias = ["INFO","I"] - , _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL." - , _tcEffect = \_ _ -> NoArguments (makeTermPara str) - } - -commandsCommand :: TerminalCommand -commandsCommand = TerminalCommand - { _tcString = "COMMANDS" - , _tcAlias = ["COMMAND","COM"] - , _tcHelp = "DISPLAYS AVAILABLE COMMANDS." - , _tcEffect = \tm _ -> NoArguments - ( makeTermLine "AVAILABLE COMMANDS:" - : makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm)) - ) - } +makeColorTermLine col str = TerminalLineDisplay 0 $ TerminalLineConst str col commandColor :: Color commandColor = yellow - -singleCommand :: [String] -> String -> [String] -> String -> (World -> World) -> TerminalCommand -singleCommand followingLines command aliases htext eff = TerminalCommand - {_tcString = command - ,_tcAlias = aliases - ,_tcHelp = htext - ,_tcEffect = \_ _ -> NoArguments $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines - } - -guardDisconnected :: Terminal -> World -> World -> World -guardDisconnected tm w w' = case _tmStatus tm of - TerminalOff -> w - TerminalBusy -> w - TerminalReady -> w' - -doTerminalEffectLB :: Terminal -> World -> World -doTerminalEffectLB tm w = guardDisconnected tm w $ fromMaybe w $ do - s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText - if null (words s) - then Just $ defocusTerminalInput w - else return $ terminalReturnEffect tm w - -terminalReturnEffect :: Terminal -> World -> World -terminalReturnEffect tm w = guardDisconnected tm w $ fromMaybe w $ do - s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText - return $ runTerminalString s tm $ w - & terminals . ix (_tmID tm) . tmFutureLines .~ [makeTermLine ('>':s)] - -commandFutureLines :: String -> Terminal -> World -> [TerminalLine] -commandFutureLines s tm w = fromMaybe [errline "^ INVALID COMMAND"] $ do - (str,args) <- safeUncons $ words s - command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm) - case _tcEffect command tm w of - NoArguments tls -> Just tls - OneArgument argtype m -> Just $ fromMaybe [errline $ "^ INVALID ARGUMENT: EXPECTS "++ argtype] - $ safeHead args >>= (m M.!?) - where - errline = makeColorTermLine red - -runTerminalString :: String -> Terminal -> World -> World -runTerminalString s tm w = w & terminals . ix (_tmID tm) %~ - ( (tmInput .~ TerminalInput T.empty True (0,0)) - . (tmFutureLines ++.~ commandFutureLines s tm w) - . (tmCommandHistory %~ take 10 . (s:)) - ) - -defocusTerminalInput :: World -> World -defocusTerminalInput w = fromMaybe w $ do - tmid <- w ^? hud . hudElement . subInventory . termID - return $ w & terminals . ix tmid . tmInput . tiFocus %~ const False - -doCommandInstant :: String -> Terminal -> World -> World -doCommandInstant arg tm w = doLineEffectsInstant tm w $ commandFutureLines arg tm w - --- doesn't do internal terminal effects -doLineEffectsInstant :: Terminal -> World -> [TerminalLine] -> World -doLineEffectsInstant tm = foldr f - where - f tl w = case tl of - TerminalLineEffect _ eff -> eff tm w - _ -> w - -basicTerminal :: Terminal -basicTerminal = defaultTerminal - {_tmDisplayedLines = [] - ,_tmFutureLines = [] - ,_tmMaxLines = 14 - ,_tmTitle = "TERMINAL" - ,_tmInput = defaultTerminalInput - ,_tmScrollCommands = [quitCommand] - ,_tmWriteCommands = [helpCommand,commandsCommand] - ,_tmBootProgram = \_ _ -> connectionBlurb - , _tmDeathEffect = doDeathTriggers - } - -lineOutputTerminal :: [TerminalLine] -> Terminal -lineOutputTerminal tls = defaultTerminal - {_tmDisplayedLines = [] - ,_tmFutureLines = [] - ,_tmMaxLines = 14 - ,_tmTitle = "TERMINAL" - ,_tmInput = defaultTerminalInput - ,_tmScrollCommands = [quitCommand] - ,_tmWriteCommands = [helpCommand,commandsCommand] - ,_tmBootProgram = \_ _ -> connectionBlurbLines tls - , _tmDeathEffect = doDeathTriggers - } - -doDeathTriggers :: Terminal -> World -> World -doDeathTriggers tm w = w - & triggers %~ flip (foldl' $ flip doDeathToggle) xs - where - xs = M.elems $ _tmToggles tm -doDeathToggle :: TerminalToggle -> IM.IntMap Bool -> IM.IntMap Bool -doDeathToggle (TerminalToggle trid f) = ix trid %~ f - -connectionBlurb :: [TerminalLine] -connectionBlurb = - [termSoundLine computerBeepingS - ,TerminalLineDisplay 0 (const ("CONNECTING",termTextColor)) - ,TerminalLineDisplay 10 (const ("...",termTextColor)) - ,TerminalLineDisplay 10 (const ("CONNECTED",termTextColor)) - ,TerminalLineTerminalEffect 0 (tmStatus .~ TerminalReady)] - -connectionBlurbLines :: [TerminalLine] -> [TerminalLine] -connectionBlurbLines tls = - [termSoundLine computerBeepingS - ,TerminalLineDisplay 0 (const ("CONNECTING",termTextColor)) - ,TerminalLineDisplay 10 (const ("...",termTextColor)) - ,TerminalLineDisplay 10 (const ("CONNECTED",termTextColor)) - ] ++ tls ++ - [TerminalLineTerminalEffect 0 (tmStatus .~ TerminalReady)] diff --git a/src/Dodge/TerminalCommandEffect.hs b/src/Dodge/TerminalCommandEffect.hs new file mode 100644 index 000000000..fa7e22e3f --- /dev/null +++ b/src/Dodge/TerminalCommandEffect.hs @@ -0,0 +1,4 @@ +module Dodge.TerminalCommandEffect + where +import Dodge.Data + diff --git a/src/Dodge/TmTm.hs b/src/Dodge/TmTm.hs new file mode 100644 index 000000000..78d688541 --- /dev/null +++ b/src/Dodge/TmTm.hs @@ -0,0 +1,9 @@ +module Dodge.TmTm + where +import Dodge.Data.Terminal +import Control.Lens +doTmTm :: TmTm -> Terminal -> Terminal +doTmTm tmtm = case tmtm of + TmTmClearDisplayedLines -> tmDisplayedLines .~ [] + TmTmSetStatus s -> tmStatus .~ s + diff --git a/src/Dodge/TmWdWd.hs b/src/Dodge/TmWdWd.hs new file mode 100644 index 000000000..b475cf8c6 --- /dev/null +++ b/src/Dodge/TmWdWd.hs @@ -0,0 +1,6 @@ +module Dodge.TmWdWd + where +import Dodge.Terminal +import Dodge.Data + + diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index b55881c71..28521d875 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -4,6 +4,9 @@ Module : Dodge.Update Description : Simulation update -} module Dodge.Update ( updateUniverse ) where +import Dodge.TmTm +import Dodge.Terminal +import Color import Dodge.DrWdWd import Dodge.TractorBeam.Update import Dodge.Prop.Update @@ -164,20 +167,24 @@ updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mous -- | _mcHP mc > 0 = _mcUpdate mc mc' -- | otherwise = destroyMachine mc +displayTerminalLineString :: TerminalLineString -> World -> (String,Color) +displayTerminalLineString tls = case tls of + TerminalLineConst str col -> const (str,col) + tmUpdate :: Terminal -> World -> World tmUpdate tm w = case w ^? terminals . ix (_tmID tm) . tmFutureLines . ix 0 of Nothing -> w Just tl | _tlPause tl > 0 -> w & pointTermParams . tmFutureLines . ix 0 . tlPause -~ 1 Just (TerminalLineDisplay _ f) -> w & pointTermParams %~ ( ( tmFutureLines %~ tail ) - . ( tmDisplayedLines .:~ f w ) + . ( tmDisplayedLines .:~ displayTerminalLineString f w ) ) Just (TerminalLineEffect _ eff) -> w & pointTermParams . tmFutureLines %~ tail - & eff tm + & doTmWdWd eff tm Just (TerminalLineTerminalEffect _ eff) -> w & pointTermParams . tmFutureLines %~ tail - & pointTermParams %~ eff + & pointTermParams %~ doTmTm eff where pointTermParams = terminals . ix (_tmID tm) diff --git a/src/Dodge/WorldEffect.hs b/src/Dodge/WorldEffect.hs index 0e7ac8fd2..97d6fc0dd 100644 --- a/src/Dodge/WorldEffect.hs +++ b/src/Dodge/WorldEffect.hs @@ -1,14 +1,34 @@ module Dodge.WorldEffect where +import Dodge.Terminal import Dodge.SoundLogic import Dodge.WorldEvent.Cloud import Dodge.Data import Dodge.Inventory.Lock import Dodge.Placement.Instance.Terminal +import Dodge.Data.WorldEffect +import Dodge.Data.Terminal +import Dodge.Data +import Dodge.Default +--import Dodge.Base +import Dodge.SoundLogic +import Color +import Justify +import LensHelp +import Sound.Data +import ListHelp (safeUncons,safeHead) + +import Data.Char +import Data.Maybe +import Data.Foldable +import qualified Data.Map.Strict as M +import qualified IntMapHelp as IM +import qualified Data.Text as T +--import Text.Read import System.Random import Control.Lens -doWorldEffect :: WorldEffect -> World -> World +doWorldEffect :: WdWd -> World -> World doWorldEffect we = case we of NoWorldEffect -> id SetTrigger bool tid -> triggers . ix tid .~ bool @@ -20,9 +40,223 @@ doWorldEffect we = case we of TorqueCr x cid -> torqueCr x cid SoundStart so p sid mi -> soundStart so p sid mi +accessTerminal :: Maybe Int -> World -> World +accessTerminal mtmid w = case mtmid of + Nothing -> w + Just tmid -> w & hud . hudElement .~ DisplayInventory (DisplayTerminal tmid) + & terminals . ix tmid . tmInput . tiFocus .~ True + & terminals . ix tmid %~ tryToBoot + where + tryToBoot tm = case _tmStatus tm of + TerminalReady -> tm + TerminalBusy -> tm + TerminalOff -> tm + & tmFutureLines .~ doTerminalBootProgram (_tmBootProgram tm) tm w + & tmStatus .~ TerminalBusy + torqueCr :: Float -> Int -> World -> World torqueCr x cid w | cid == 0 = set randGen g $ over cameraRot (+rot) w | otherwise = set randGen g $ over (creatures . ix cid . crDir) (+rot) w where (rot, g) = randomR (-x,x) $ _randGen w + +disconnectTerminal :: Terminal -> World -> World +disconnectTerminal tm w = w + & terminals . ix (_tmID tm) . tmStatus .~ TerminalOff + & exitTerminalSubInv + & terminals . ix (_tmID tm) . tmFutureLines .~ + [ TerminalLineTerminalEffect 0 TmTmClearDisplayedLines ] + + +exitTerminalSubInv :: World -> World +exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of + Just _ -> w & hud . hudElement . subInventory .~ NoSubInventory + _ -> w + +damageCodeCommand :: TerminalCommand +damageCodeCommand = TerminalCommand + { _tcString = "DAMAGECODE" + , _tcAlias = ["DCODE","DC"] + , _tcHelp = "DISPLAYS THE SHAPE AND COLOR ASSOCIATED WITH A GIVEN DAMAGE TYPE." + , _tcEffect = TerminalCommandEffectDamageCoding -- \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding + } +getDamageCoding :: World -> M.Map String [TerminalLine] +getDamageCoding = decodedtmap . _sensorCoding . _genParams + +decodedtmap :: M.Map DamageType (PaletteColor,DecorationShape) -> M.Map String [TerminalLine] +decodedtmap = M.mapKeys show . M.map ((:[]) . makeTermLine . show) + +sensorCommand :: TerminalCommand +sensorCommand = TerminalCommand + { _tcString = "SENSOR" + , _tcAlias = ["SEN"] + , _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR." + , _tcEffect = TerminalCommandEffectSensorParameter -- \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm + } +sensorInfoMap :: Terminal -> World -> M.Map String [TerminalLine] +sensorInfoMap tm w = M.fromList + [("REQUIREMENT", getSensor _proxRequirement tm w) + ,("DISTANCE", getSensor _proxDist tm w) + ,("CURRENTSTATUS", getSensor _proxStatus tm w) + ,("PASTSTATUS", getSensor _sensToggle tm w) + ] +getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine] +getSensor f tm w = maybe [] (makeTermPara . map toUpper . show . f) + (w ^? machines . ix (_tmMachineID tm) . mcSensor) + +toggleCommand :: TerminalCommand +toggleCommand = TerminalCommand + { _tcString = "TOGGLE" + , _tcAlias = ["TOG"] + , _tcHelp = "PERFORMS A REVERSABLE EFFECT." + , _tcEffect = TerminalCommandEffectLinkedObject -- \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) + } +togglesToEffects :: Terminal -> M.Map String [TerminalLine] +togglesToEffects = fmap f . _tmToggles + where + f tt = [TerminalLineEffect 0 $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)] + -- \_ -> triggers . ix (_ttTriggerID tt) %~ not] + +infoClearInput :: Terminal -> [TerminalLine] -> World -> World +infoClearInput tm tls = terminals . ix (_tmID tm) %~ + ( (tmInput .~ TerminalInput T.empty True (0,0)) + . (tmFutureLines ++.~ tls) + ) + +argumentHelp :: TerminalCommand -> Terminal -> World -> (String,Maybe [String]) +argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of + NoArguments {} -> ("ANY ARGUMENTS PROVIDED TO THIS COMMAND ARE IGNORED.",Nothing) + OneArgument argtype argm -> ("EXPECTS " ++ argtype ++ " AS ARGUMENT. AVAILABLE ARGUMENTS: " + , Just (M.keys argm) ) + + +infoCommand :: String -> TerminalCommand +infoCommand str = TerminalCommand + { _tcString = "INFORMATION" + , _tcAlias = ["INFO","I"] + , _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL." + , _tcEffect = TerminalCommandEffectNoArgumentsStr str -- \_ _ -> NoArguments (makeTermPara str) + } + +singleCommand :: [String] -> String -> [String] -> String -> WdWd -> TerminalCommand +singleCommand followingLines command aliases htext eff = TerminalCommand + {_tcString = command + ,_tcAlias = aliases + ,_tcHelp = htext + ,_tcEffect = TerminalCommandEffectSingleCommand eff followingLines } + +guardDisconnected :: Terminal -> World -> World -> World +guardDisconnected tm w w' = case _tmStatus tm of + TerminalOff -> w + TerminalBusy -> w + TerminalReady -> w' + +doTerminalEffectLB :: Terminal -> World -> World +doTerminalEffectLB tm w = guardDisconnected tm w $ fromMaybe w $ do + s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText + if null (words s) + then Just $ defocusTerminalInput w + else return $ terminalReturnEffect tm w + +terminalReturnEffect :: Terminal -> World -> World +terminalReturnEffect tm w = guardDisconnected tm w $ fromMaybe w $ do + s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText + return $ runTerminalString s tm $ w + & terminals . ix (_tmID tm) . tmFutureLines .~ [makeTermLine ('>':s)] + +commandFutureLines :: String -> Terminal -> World -> [TerminalLine] +commandFutureLines s tm w = fromMaybe [errline "^ INVALID COMMAND"] $ do + (str,args) <- safeUncons $ words s + command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm) + case doTerminalCommandEffect (_tcEffect command) tm w of + NoArguments tls -> Just tls + OneArgument argtype m -> Just $ fromMaybe [errline $ "^ INVALID ARGUMENT: EXPECTS "++ argtype] + $ safeHead args >>= (m M.!?) + where + errline = makeColorTermLine red + +runTerminalString :: String -> Terminal -> World -> World +runTerminalString s tm w = w & terminals . ix (_tmID tm) %~ + ( (tmInput .~ TerminalInput T.empty True (0,0)) + . (tmFutureLines ++.~ commandFutureLines s tm w) + . (tmCommandHistory %~ take 10 . (s:)) + ) + +defocusTerminalInput :: World -> World +defocusTerminalInput w = fromMaybe w $ do + tmid <- w ^? hud . hudElement . subInventory . termID + return $ w & terminals . ix tmid . tmInput . tiFocus %~ const False + +doCommandInstant :: String -> Terminal -> World -> World +doCommandInstant arg tm w = doLineEffectsInstant tm w $ commandFutureLines arg tm w + +-- doesn't do internal terminal effects +doLineEffectsInstant :: Terminal -> World -> [TerminalLine] -> World +doLineEffectsInstant tm = foldr f + where + f tl w = case tl of + TerminalLineEffect _ eff -> doTmWdWd eff tm w + _ -> w + + +lineOutputTerminal :: [TerminalLine] -> Terminal +lineOutputTerminal tls = defaultTerminal + {_tmDisplayedLines = [] + ,_tmFutureLines = [] + ,_tmMaxLines = 14 + ,_tmTitle = "TERMINAL" + ,_tmInput = defaultTerminalInput + ,_tmScrollCommands = [quitCommand] + ,_tmWriteCommands = [helpCommand,commandsCommand] + ,_tmBootProgram = TerminalBootLines $ connectionBlurbLines tls + , _tmDeathEffect = TmWdWdDoDeathTriggers + } + +doDeathTriggers :: Terminal -> World -> World +doDeathTriggers tm w = w + & triggers %~ flip (foldl' $ flip doDeathToggle) xs + where + xs = M.elems $ _tmToggles tm +doDeathToggle :: TerminalToggle -> IM.IntMap Bool -> IM.IntMap Bool +doDeathToggle (TerminalToggle trid f) = ix trid %~ doBlBl f + +doBlBl :: BlBl -> Bool -> Bool +doBlBl bb = case bb of + BlNegate -> not + BlConst bl -> const bl + BlId -> id + + +doTerminalBootProgram :: TerminalBootProgram -> Terminal -> World -> [TerminalLine] +doTerminalBootProgram tbp = case tbp of + TerminalBootMempty -> \_ _ -> [] + TerminalBootLines ls -> \_ _ -> ls + + +doTerminalCommandEffect :: TerminalCommandEffect -> Terminal -> World -> EffectArguments +doTerminalCommandEffect tce = case tce of + TerminalCommandArguments eas -> \_ _ -> eas + TerminalCommandEffectDamageCoding -> \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding + TerminalCommandEffectSensorParameter -> \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm + TerminalCommandEffectLinkedObject -> \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) + TerminalCommandEffectHelp -> \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm + TerminalCommandEffectNoArgumentsStr str -> \_ _ -> NoArguments (makeTermPara str) + TerminalCommandEffectCommands -> \tm _ -> NoArguments + ( makeTermLine "AVAILABLE COMMANDS:" + : makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm)) + ) + TerminalCommandEffectSingleCommand eff followingLines -> \_ _ -> NoArguments $ TerminalLineEffect 0 (TmWdWdfromWdWd eff) : map makeTermLine followingLines + TerminalCommandEffectNone -> \_ _ -> NoArguments [] + +doTmWdWd :: TmWdWd -> Terminal -> World -> World +doTmWdWd tmwdwd = case tmwdwd of + TmWdId -> const id + TmWdWdDisconnectTerminal -> disconnectTerminal + TmWdWdTermSound sid -> \tm w -> let tpos = fromMaybe 0 $ w ^? buttons . ix (_tmButtonID tm) . btPos + in soundStart TerminalSound tpos sid Nothing w + TmWdWdDoDeathTriggers -> doDeathTriggers + --TmWdWdfromWdWd f -> \_ -> doWorldEffect f + +simpleTermMessage :: [String] -> Terminal +simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs