justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Simplify (data-ify) command arguments

Browse Source
This commit is contained in:
justin
2022-06-07 12:48:22 +01:00
parent 3c2f0cb824
commit cc5d431d4c
3 changed files with 70 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+12 -4
View File
@@ -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
src/Dodge/Event.hs
+10 -6
View File
@@ -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
src/Dodge/Terminal.hs
+48 -44
View File
@@ -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