272 lines
10 KiB
Haskell
272 lines
10 KiB
Haskell
module Dodge.Terminal (
|
|
doTerminalCommandEffect,
|
|
makeTermLine,
|
|
commandFutureLines,
|
|
quitCommand,
|
|
helpCommand,
|
|
commandsCommand,
|
|
connectionBlurbLines,
|
|
disconnectTerminal,
|
|
basicTerminal,
|
|
simpleTermMessage,
|
|
damageCodeCommand,
|
|
sensorCommand,
|
|
makeColorTermLine,
|
|
makeTermPara,
|
|
toggleCommand,
|
|
) where
|
|
|
|
import Color
|
|
import Data.Char
|
|
import Data.Foldable
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
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"
|
|
, _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 = 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
|
|
}
|
|
|
|
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]
|
|
)
|
|
|
|
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)
|
|
|
|
termTextColor :: Color
|
|
termTextColor = greyN 0.9
|
|
|
|
getCommands :: Terminal -> [TerminalCommand]
|
|
getCommands tm = _tmScrollCommands tm ++ _tmWriteCommands tm
|
|
|
|
makeTermLine :: String -> TerminalLine
|
|
makeTermLine = makeColorTermLine termTextColor
|
|
|
|
makeTermPara :: String -> [TerminalLine]
|
|
makeTermPara = map makeTermLine . makeParagraph 60
|
|
|
|
makeColorTermPara :: Color -> String -> [TerminalLine]
|
|
makeColorTermPara col = map (makeColorTermLine col) . makeParagraph 60
|
|
|
|
makeColorTermLine :: Color -> String -> TerminalLine
|
|
makeColorTermLine col str = TerminalLineDisplay 0 $ TerminalLineConst str col
|
|
|
|
commandColor :: Color
|
|
commandColor = yellow
|
|
|
|
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 []
|
|
|
|
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
|
|
-- }
|
|
|
|
getDamageCoding :: World -> M.Map String [TerminalLine]
|
|
getDamageCoding = decodedtmap . _sensorCoding . _cwgParams . _cwGen . _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)
|
|
]
|
|
|
|
getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine]
|
|
getSensor f tm w =
|
|
maybe
|
|
[]
|
|
(makeTermPara . map toLower . show . f)
|
|
(w ^? cWorld . lWorld . machines . ix (_tmMachineID tm) . mcType . _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)
|
|
|
|
sensorCommand :: TerminalCommand
|
|
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 =
|
|
(cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff)
|
|
. exitTerminalSubInv
|
|
. ( cWorld . lWorld . 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 MouseInvNothing Nothing
|
|
_ -> 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
|
|
}
|
|
|
|
--infoClearInput :: Terminal -> [TerminalLine] -> World -> World
|
|
--infoClearInput tm tls =
|
|
-- cWorld . lWorld . 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)]
|
|
|
|
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)
|
|
case doTerminalCommandEffect (_tcEffect command) tm w of
|
|
NoArguments tls -> Just tls
|
|
OneArgument argtype m ->
|
|
let setpartial
|
|
| null (_tmPartialCommand tm)
|
|
= TerminalLineTerminalEffect 0 (TmTmSetPartialCommand (Just command)) :
|
|
makeTermPara ("Expects " ++ argtype ++ " as an argument")
|
|
| otherwise =
|
|
TerminalLineTerminalEffect 0 (TmTmSetPartialCommand Nothing) :
|
|
makeTermPara "No argument input, cancelling"
|
|
in Just $
|
|
fromMaybe setpartial $
|
|
safeHead args >>= (m M.!?)
|
|
where
|
|
errline = makeColorTermLine red
|