Simplify (data-ify) command arguments

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
+    , _tcEffect :: Terminal -> World -> EffectArguments
-    , _tcArguments :: Terminal -> World -> [String]
+--    , _tcArgumentType :: Maybe String
-    , _tcEffect :: [String] -> Terminal -> World -> Either String [TerminalLine]
+--    , _tcArguments :: Terminal -> World -> [String]
+--    , _tcEffect :: [String] -> Terminal -> World -> Either String [TerminalLine]
     }
 
 ---- ROOM DATATYPES

src/Dodge/Event.hs

@@ -38,6 +38,7 @@ import Data.Maybe
 --import Data.Char
 --import Data.List
 --import Data.Function (on)
+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
+    , _tcEffect = \_ _ -> NoArguments []
-    , _tcArguments  = const (const [])
-    , _tcEffect = \_ _ _ -> Right []
     }
 
 scrollRBOption :: Float -> World -> World

src/Dodge/Terminal.hs

@@ -21,9 +21,7 @@ quitCommand = TerminalCommand
     { _tcString = "QUIT"
     , _tcAlias  = ["Q","EXIT","X","SHUTDOWN",""]
     , _tcHelp   = "DISCONNECTS THE TERMINAL."
-    , _tcArgumentType = Nothing
+    , _tcEffect = \_ _ -> NoArguments [TerminalLineEffect 0 disconnectTerminal]
-    , _tcArguments  = const (const [])
-    , _tcEffect = \_ _ _ -> Right [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"
+    , _tcEffect = \_ w -> OneArgument "A DAMAGE TYPE" $ getDamageCoding w
-    , _tcArguments = \_ -> map (map toUpper . show) . M.keys . _sensorCoding . _genParams
+--    , _tcArgumentType = Just "A DAMAGE TYPE"
-    , _tcEffect = f
+--    , _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"
+    , _tcEffect = \tm w -> OneArgument "A SENSOR PARAMETER" (sensorInfoMap tm w)
-    , _tcArguments  = \_ _ -> ["REQUIREMENT","DISTANCE","CURRENTSTATUS","PASTSTATUS"]
-    , _tcEffect = effectArgMessage sensf
     }
+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"
+    , _tcEffect = \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm)
-    , _tcArguments  = \tm _ -> M.keys $ _tmToggles tm
-    , _tcEffect = togglef
     }
-togglef :: [String] -> Terminal -> World -> Either String [TerminalLine]
+togglesToEffects :: Terminal -> M.Map String [TerminalLine]
-togglef [] _ _ = Left ""
+togglesToEffects = fmap f . _tmToggles
-togglef (s:_) tm _ = fromMaybe (Left "") $ do
+  where
-    TerminalToggle trid _ <- M.lookup s $ _tmToggles tm
+    f tt = [TerminalLineEffect 0 $ \_ -> triggers . ix (_ttTriggerID tt) %~ fmap not]
-    Just $ Right [TerminalLineEffect 0 $ \_ -> triggers . ix trid %~ 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"
+    , _tcEffect = \tm w -> OneArgument "AN AVAILABLE COMMAND" $ getCommandsHelp tm w
-    , _tcArguments  = \tm w -> fromMaybe [] $ do
-        commands <- getCommands tm w
-        return $ map _tcString commands
-    , _tcEffect = helpf
     }
-helpf :: [String] -> Terminal -> World -> Either String [TerminalLine]
+getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine]
-helpf [] tm w = helpf ["HELP"] tm w
+getCommandsHelp tm w = fromMaybe mempty $ do
-helpf (str:_) tm w = maybe (Left "") Right $ do
+    tcs <- getCommands tm w
-    commands <- getCommands tm w
+    return $ foldr f mempty tcs
-    command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
+  where
-    return $ 
+    f tc = M.insert (_tcString tc) 
-        [makeTermLine ("COMMAND:" ++ _tcString command) 
+        ( [makeTermLine ("COMMAND:" ++ _tcString tc) 
-        ,makeTermLine ("ALIASES:" ++ unwords (_tcAlias command)) ] 
+            ,makeTermLine ("ALIASES:" ++ unwords (_tcAlias tc)) ] 
-        ++ makeTermPara (_tcHelp command ++ " " ++ argumentHelp (_tcArgumentType command))
+            ++ (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
+    , _tcEffect = \_ _ -> NoArguments (makeTermPara str)
-    , _tcArguments = const (const [])
-    , _tcEffect = \ _ _ _ -> Right ( makeTermPara str)
     }
 
 commandsCommand :: TerminalCommand
@@ -159,9 +166,7 @@ commandsCommand = TerminalCommand
     { _tcString = "COMMANDS"
     , _tcAlias  = ["COMMAND","COM"]
     , _tcHelp   = "DISPLAYS AVAILABLE COMMANDS."
-    , _tcArgumentType = Nothing
+    , _tcEffect = \tm w -> NoArguments
-    , _tcArguments = const $ const []
-    , _tcEffect = \_ tm w -> Right
         ( 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
+    ,_tcEffect = \_ _ -> NoArguments $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines
-    , _tcArguments = const $ const []
-    ,_tcEffect = \_ _ _ -> Right $ 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
+    case _tcEffect command tm w of
-            Right tls -> Just tls
+        NoArguments tls -> Just tls
-            Left err -> Just [makeColorTermLine red
+        OneArgument argtype m -> case args of
-                ("^ INVALID ARGUMENT: EXPECTS "++fromJust (_tcArgumentType command)++ err) ]
+            (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