Refactor, try to limit dependencies
This commit is contained in:
+157
-126
@@ -1,88 +1,100 @@
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Terminal where
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.Data
|
||||
import Dodge.Default
|
||||
import Color
|
||||
import Justify
|
||||
import LensHelp
|
||||
import Sound.Data
|
||||
import ListHelp (safeUncons,safeHead)
|
||||
|
||||
import Color
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
import Data.Foldable
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Dodge.Data.World
|
||||
import Dodge.Default
|
||||
import Dodge.SoundLogic
|
||||
import Justify
|
||||
import LensHelp
|
||||
import ListHelp (safeHead, safeUncons)
|
||||
import Sound.Data
|
||||
|
||||
basicTerminal :: Terminal
|
||||
basicTerminal = defaultTerminal
|
||||
{_tmDisplayedLines = []
|
||||
,_tmFutureLines = []
|
||||
,_tmMaxLines = 14
|
||||
,_tmTitle = "TERMINAL"
|
||||
,_tmInput = defaultTerminalInput
|
||||
,_tmScrollCommands = [quitCommand]
|
||||
,_tmWriteCommands = [helpCommand,commandsCommand]
|
||||
,_tmBootProgram = TerminalBootLines connectionBlurb
|
||||
, _tmDeathEffect = TmWdWdDoDeathTriggers
|
||||
}
|
||||
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)]
|
||||
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 = TerminalCommandArguments $ NoArguments [TerminalLineEffect 0 TmWdWdDisconnectTerminal]
|
||||
}
|
||||
quitCommand =
|
||||
TerminalCommand
|
||||
{ _tcString = "QUIT"
|
||||
, _tcAlias = ["Q", "EXIT", "X", "SHUTDOWN", ""]
|
||||
, _tcHelp = "DISCONNECTS THE TERMINAL."
|
||||
, _tcEffect = TerminalCommandArguments $ NoArguments [TerminalLineEffect 0 TmWdWdDisconnectTerminal]
|
||||
}
|
||||
|
||||
helpCommand :: TerminalCommand
|
||||
helpCommand = TerminalCommand
|
||||
{ _tcString = "HELP"
|
||||
, _tcAlias = ["H","MAN"]
|
||||
, _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND."
|
||||
, _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm
|
||||
}
|
||||
helpCommand =
|
||||
TerminalCommand
|
||||
{ _tcString = "HELP"
|
||||
, _tcAlias = ["H", "MAN"]
|
||||
, _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND."
|
||||
, _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
|
||||
f tc = M.insert (_tcString tc)
|
||||
( [makeTermLine "COMMAND:"
|
||||
, makeColorTermLine commandColor (_tcString tc)
|
||||
,makeTermLine "ALIASES:"
|
||||
, makeColorTermLine commandColor ( unwords (_tcAlias tc)) ]
|
||||
++ case argumentHelp tc tm w of
|
||||
(arghelp,Nothing) -> makeTermPara $ _tcHelp tc ++ " " ++ arghelp
|
||||
(arghelp,Just args) -> makeTermPara (_tcHelp tc ++ " " ++ arghelp)
|
||||
++ [makeColorTermLine commandColor $ unwords args]
|
||||
)
|
||||
f tc =
|
||||
M.insert
|
||||
(_tcString tc)
|
||||
( [ makeTermLine "COMMAND:"
|
||||
, makeColorTermLine commandColor (_tcString tc)
|
||||
, makeTermLine "ALIASES:"
|
||||
, makeColorTermLine commandColor (unwords (_tcAlias tc))
|
||||
]
|
||||
++ case argumentHelp tc tm w of
|
||||
(arghelp, Nothing) -> makeTermPara $ _tcHelp tc ++ " " ++ arghelp
|
||||
(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
|
||||
}
|
||||
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)]
|
||||
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
|
||||
@@ -117,78 +129,93 @@ doTerminalCommandEffect tce = case tce of
|
||||
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))
|
||||
)
|
||||
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 []
|
||||
|
||||
argumentHelp :: TerminalCommand -> Terminal -> World -> (String,Maybe [String])
|
||||
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) )
|
||||
|
||||
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)
|
||||
}
|
||||
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 }
|
||||
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'
|
||||
|
||||
getDamageCoding :: World -> M.Map String [TerminalLine]
|
||||
getDamageCoding = decodedtmap . _sensorCoding . _genParams . _cWorld
|
||||
|
||||
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)
|
||||
]
|
||||
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 ^? cWorld . machines . ix (_tmMachineID tm) . mcSensor)
|
||||
getSensor f tm w =
|
||||
maybe
|
||||
[]
|
||||
(makeTermPara . map toUpper . show . f)
|
||||
(w ^? cWorld . 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)
|
||||
}
|
||||
decodedtmap :: M.Map DamageType (PaletteColor,DecorationShape) -> M.Map String [TerminalLine]
|
||||
decodedtmap = M.mapKeys show . M.map ((:[]) . makeTermLine . show)
|
||||
toggleCommand =
|
||||
TerminalCommand
|
||||
{ _tcString = "TOGGLE"
|
||||
, _tcAlias = ["TOG"]
|
||||
, _tcHelp = "PERFORMS A REVERSABLE EFFECT."
|
||||
, _tcEffect = TerminalCommandEffectLinkedObject -- \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm)
|
||||
}
|
||||
|
||||
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
|
||||
}
|
||||
sensorCommand =
|
||||
TerminalCommand
|
||||
{ _tcString = "SENSOR"
|
||||
, _tcAlias = ["SEN"]
|
||||
, _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR."
|
||||
, _tcEffect = TerminalCommandEffectSensorParameter -- \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm
|
||||
}
|
||||
|
||||
disconnectTerminal :: Terminal -> World -> World
|
||||
disconnectTerminal tm w = w
|
||||
& cWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff
|
||||
& exitTerminalSubInv
|
||||
& cWorld . terminals . ix (_tmID tm) . tmFutureLines .~
|
||||
[ TerminalLineTerminalEffect 0 TmTmClearDisplayedLines ]
|
||||
disconnectTerminal tm w =
|
||||
w
|
||||
& cWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff
|
||||
& exitTerminalSubInv
|
||||
& cWorld . terminals . ix (_tmID tm) . tmFutureLines
|
||||
.~ [TerminalLineTerminalEffect 0 TmTmClearDisplayedLines]
|
||||
|
||||
exitTerminalSubInv :: World -> World
|
||||
exitTerminalSubInv w = case w ^? cWorld . hud . hudElement . subInventory . termID of
|
||||
@@ -196,35 +223,39 @@ exitTerminalSubInv w = case w ^? cWorld . hud . hudElement . subInventory . term
|
||||
_ -> 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
|
||||
}
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
infoClearInput :: Terminal -> [TerminalLine] -> World -> World
|
||||
infoClearInput tm tls = cWorld . terminals . ix (_tmID tm) %~
|
||||
( (tmInput .~ TerminalInput T.empty True (0,0))
|
||||
. (tmFutureLines ++.~ tls)
|
||||
)
|
||||
infoClearInput tm tls =
|
||||
cWorld . terminals . ix (_tmID tm)
|
||||
%~ ( (tmInput .~ TerminalInput T.empty True (0, 0))
|
||||
. (tmFutureLines ++.~ tls)
|
||||
)
|
||||
|
||||
togglesToEffects :: Terminal -> M.Map String [TerminalLine]
|
||||
togglesToEffects = fmap f . _tmToggles
|
||||
where
|
||||
f tt = [TerminalLineEffect 0 $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
|
||||
-- \_ -> triggers . ix (_ttTriggerID tt) %~ not]
|
||||
f tt = [TerminalLineEffect 0 $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
|
||||
|
||||
-- \_ -> triggers . ix (_ttTriggerID tt) %~ not]
|
||||
simpleTermMessage :: [String] -> Terminal
|
||||
simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs
|
||||
|
||||
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)
|
||||
(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.!?)
|
||||
OneArgument argtype m ->
|
||||
Just $
|
||||
fromMaybe [errline $ "^ INVALID ARGUMENT: EXPECTS " ++ argtype] $
|
||||
safeHead args >>= (m M.!?)
|
||||
where
|
||||
errline = makeColorTermLine red
|
||||
|
||||
Reference in New Issue
Block a user