From cc5d431d4c76045463e0cb00188b5b37c3031631 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 7 Jun 2022 12:48:22 +0100 Subject: [PATCH] Simplify (data-ify) command arguments --- src/Dodge/Data.hs | 16 ++++++-- src/Dodge/Event.hs | 16 +++++--- src/Dodge/Terminal.hs | 92 ++++++++++++++++++++++--------------------- 3 files changed, 70 insertions(+), 54 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 46a561688..37af62d97 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -998,7 +998,7 @@ data ProximityRequirement | RequireImpossible deriving (Eq,Ord,Show) data CloseToggle = NotClose | IsClose - deriving (Eq,Ord) + deriving (Eq,Ord,Show) data MachineType = StaticMachine | Turret @@ -1384,13 +1384,21 @@ data CreatureState = CrSt , _crDropsOnDeath :: CreatureDropType } +data EffectArguments + = NoArguments {_cmdEffect :: [TerminalLine]} + | OneArgument + {_argType :: String + ,_argList :: M.Map String [TerminalLine] + } + data TerminalCommand = TerminalCommand { _tcString :: String , _tcAlias :: [String] , _tcHelp :: String - , _tcArgumentType :: Maybe String - , _tcArguments :: Terminal -> World -> [String] - , _tcEffect :: [String] -> Terminal -> World -> Either String [TerminalLine] + , _tcEffect :: Terminal -> World -> EffectArguments +-- , _tcArgumentType :: Maybe String +-- , _tcArguments :: Terminal -> World -> [String] +-- , _tcEffect :: [String] -> Terminal -> World -> Either String [TerminalLine] } ---- ROOM DATATYPES diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 1e347fcc7..cd2eed7bd 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -38,7 +38,8 @@ import Data.Maybe --import Data.Char --import Data.List --import Data.Function (on) -import qualified Data.Set as S +import qualified Data.Map.Strict as M +import qualified Data.Set as S import qualified Data.Text as T import SDL @@ -157,14 +158,14 @@ wheelEvent y w = case _hudElement $ _hud w of & tmInput . tiText %~ replacewith tm newi updatetermsubsel tm = case tm ^? tmInput . tiSel of Nothing -> tm - Just (i,j) -> let newj = (j - yi) `mod` (1 + length (_tcArguments (scrollCommands tm !! i) tm w)) + Just (i,j) -> let newj = (j - yi) `mod` (1 + length (getArguments (scrollCommands tm !! i) tm w)) in tm & tmInput . tiSel .~ (i,newj) & tmInput . tiText %~ replacewith' tm i newj w replacewith tp newi _ = T.pack (_tcString (scrollCommands tp !! newi)) replacewith' tp i j w' _ = T.pack $ _tcString tc ++ " " ++ arg-- ++ ((_tcArguments tp) w !! j) where arg :: String - arg = ("": _tcArguments tc tp w' )!! j + arg = ("": getArguments tc tp w' )!! j tc = scrollCommands tp !! i numcombs = length $ combineItemListYou w yi = round $ signum y @@ -173,6 +174,11 @@ wheelEvent y w = case _hudElement $ _hud w of lbDown = ButtonLeft `S.member` _mouseButtons w invKeyDown = ScancodeCapsLock `S.member` _keys w +getArguments :: TerminalCommand -> Terminal -> World -> [String] +getArguments tc tm w = case _tcEffect tc tm w of + NoArguments {} -> [] + OneArgument _ m -> M.keys m + scrollCommands :: Terminal -> [TerminalCommand] scrollCommands = (nullCommand :) . _tmScrollCommands nullCommand :: TerminalCommand @@ -180,9 +186,7 @@ nullCommand = TerminalCommand { _tcString = "" , _tcAlias = [] , _tcHelp = "" - , _tcArgumentType = Nothing - , _tcArguments = const (const []) - , _tcEffect = \_ _ _ -> Right [] + , _tcEffect = \_ _ -> NoArguments [] } scrollRBOption :: Float -> World -> World diff --git a/src/Dodge/Terminal.hs b/src/Dodge/Terminal.hs index 1db62db71..cac92f1f9 100644 --- a/src/Dodge/Terminal.hs +++ b/src/Dodge/Terminal.hs @@ -21,9 +21,7 @@ quitCommand = TerminalCommand { _tcString = "QUIT" , _tcAlias = ["Q","EXIT","X","SHUTDOWN",""] , _tcHelp = "DISCONNECTS THE TERMINAL." - , _tcArgumentType = Nothing - , _tcArguments = const (const []) - , _tcEffect = \_ _ _ -> Right [TerminalLineEffect 0 disconnectTerminal] + , _tcEffect = \_ _ -> NoArguments [TerminalLineEffect 0 disconnectTerminal] } disconnectTerminal :: Terminal -> World -> World disconnectTerminal tm w = w @@ -43,10 +41,17 @@ damageCodeCommand = TerminalCommand { _tcString = "DAMAGECODE" , _tcAlias = ["DCODE","DC"] , _tcHelp = "DISPLAYS THE SHAPE AND COLOR ASSOCIATED WITH A GIVEN DAMAGE TYPE." - , _tcArgumentType = Just "A DAMAGE TYPE" - , _tcArguments = \_ -> map (map toUpper . show) . M.keys . _sensorCoding . _genParams - , _tcEffect = f + , _tcEffect = \_ w -> OneArgument "A DAMAGE TYPE" $ getDamageCoding w +-- , _tcArgumentType = Just "A DAMAGE TYPE" +-- , _tcArguments = \_ -> map (map toUpper . show) . M.keys . _sensorCoding . _genParams +-- , _tcEffect = f } +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) where f args _ w = fromMaybe (Left "") $ do dtype <- safeHead args >>= readMaybe @@ -58,10 +63,20 @@ sensorCommand = TerminalCommand { _tcString = "SENSOR" , _tcAlias = ["SEN"] , _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR." - , _tcArgumentType = Just "A SENSOR PARAMETER" - , _tcArguments = \_ _ -> ["REQUIREMENT","DISTANCE","CURRENTSTATUS","PASTSTATUS"] - , _tcEffect = effectArgMessage sensf + , _tcEffect = \tm w -> OneArgument "A SENSOR PARAMETER" (sensorInfoMap tm w) } +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) + + effectArgMessage :: (String -> Terminal -> World -> Maybe [String]) -> [String] -> Terminal -> World -> Either String [TerminalLine] effectArgMessage f args tm w = maybe (Left "") Right $ do @@ -80,36 +95,30 @@ toggleCommand = TerminalCommand { _tcString = "TOGGLE" , _tcAlias = ["TOG"] , _tcHelp = "PERFORMS A REVERSABLE EFFECT." - , _tcArgumentType = Just "AN ATTACHED OBJECT" - , _tcArguments = \tm _ -> M.keys $ _tmToggles tm - , _tcEffect = togglef + , _tcEffect = \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) } -togglef :: [String] -> Terminal -> World -> Either String [TerminalLine] -togglef [] _ _ = Left "" -togglef (s:_) tm _ = fromMaybe (Left "") $ do - TerminalToggle trid _ <- M.lookup s $ _tmToggles tm - Just $ Right [TerminalLineEffect 0 $ \_ -> triggers . ix trid %~ fmap not] +togglesToEffects :: Terminal -> M.Map String [TerminalLine] +togglesToEffects = fmap f . _tmToggles + where + f tt = [TerminalLineEffect 0 $ \_ -> triggers . ix (_ttTriggerID tt) %~ fmap not] helpCommand :: TerminalCommand helpCommand = TerminalCommand { _tcString = "HELP" , _tcAlias = ["H","MAN"] , _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND. TO DISPLAY AVAILABLE COMMANDS USE \"COMMANDS\"." - , _tcArgumentType = Just "AN AVAILABLE COMMAND" - , _tcArguments = \tm w -> fromMaybe [] $ do - commands <- getCommands tm w - return $ map _tcString commands - , _tcEffect = helpf + , _tcEffect = \tm w -> OneArgument "AN AVAILABLE COMMAND" $ getCommandsHelp tm w } -helpf :: [String] -> Terminal -> World -> Either String [TerminalLine] -helpf [] tm w = helpf ["HELP"] tm w -helpf (str:_) tm w = maybe (Left "") Right $ do - commands <- getCommands tm w - command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands - return $ - [makeTermLine ("COMMAND:" ++ _tcString command) - ,makeTermLine ("ALIASES:" ++ unwords (_tcAlias command)) ] - ++ makeTermPara (_tcHelp command ++ " " ++ argumentHelp (_tcArgumentType command)) +getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine] +getCommandsHelp tm w = fromMaybe mempty $ do + tcs <- getCommands tm w + return $ foldr f mempty tcs + where + f tc = M.insert (_tcString tc) + ( [makeTermLine ("COMMAND:" ++ _tcString tc) + ,makeTermLine ("ALIASES:" ++ unwords (_tcAlias tc)) ] + ++ (makeTermPara $ _tcHelp tc) + ) getCommands :: Terminal -> World -> Maybe [TerminalCommand] getCommands tm w = do commands1 <- w ^? terminals . ix (_tmID tm) . tmScrollCommands @@ -149,9 +158,7 @@ infoCommand str = TerminalCommand { _tcString = "INFORMATION" , _tcAlias = ["INFO","I"] , _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL." - , _tcArgumentType = Nothing - , _tcArguments = const (const []) - , _tcEffect = \ _ _ _ -> Right ( makeTermPara str) + , _tcEffect = \_ _ -> NoArguments (makeTermPara str) } commandsCommand :: TerminalCommand @@ -159,9 +166,7 @@ commandsCommand = TerminalCommand { _tcString = "COMMANDS" , _tcAlias = ["COMMAND","COM"] , _tcHelp = "DISPLAYS AVAILABLE COMMANDS." - , _tcArgumentType = Nothing - , _tcArguments = const $ const [] - , _tcEffect = \_ tm w -> Right + , _tcEffect = \tm w -> NoArguments ( makeTermLine "AVAILABLE COMMANDS:" : makeTermPara (unwords (maybe [""] (map _tcString) $ getCommands tm w)) ) @@ -172,9 +177,7 @@ singleCommand followingLines command aliases htext eff = TerminalCommand {_tcString = command ,_tcAlias = aliases ,_tcHelp = htext - ,_tcArgumentType = Nothing - , _tcArguments = const $ const [] - ,_tcEffect = \_ _ _ -> Right $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines + ,_tcEffect = \_ _ -> NoArguments $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines } doTerminalEffectLB :: Terminal -> World -> World @@ -193,10 +196,11 @@ commandFutureLines s tm w = fromMaybe [] $ do commands <- getCommands tm w (str,args) <- safeUncons $ words s command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands - case _tcEffect command args tm w of - Right tls -> Just tls - Left err -> Just [makeColorTermLine red - ("^ INVALID ARGUMENT: EXPECTS "++fromJust (_tcArgumentType command)++ err) ] + case _tcEffect command tm w of + NoArguments tls -> Just tls + OneArgument argtype m -> case args of + (arg:_) -> M.lookup arg m + [] -> Just [makeColorTermLine red $ "^ INVALID ARGUMENT: EXPECTS "++ argtype ] doTerminalEffect' :: String -> Terminal -> World -> World doTerminalEffect' s tm w = fromMaybe (w & badinput) $ do