358 lines
13 KiB
Haskell
358 lines
13 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Dodge.Terminal (
|
|
-- doTerminalCommandEffect,
|
|
makeTermLine,
|
|
-- commandFutureLines,
|
|
-- quitCommand,
|
|
-- helpCommand,
|
|
-- commandsCommand,
|
|
connectionBlurbLines,
|
|
disconnectTerminal,
|
|
textTerminal,
|
|
simpleTermMessage,
|
|
damageCodeCommand,
|
|
sensorCommand,
|
|
makeColorTermLine,
|
|
makeTermPara,
|
|
toggleCommand,
|
|
terminalReturnEffect,
|
|
getCommands,
|
|
makeColorTermPara,
|
|
commandColor,
|
|
tabComplete,
|
|
) where
|
|
|
|
--import Dodge.Data.WorldEffect
|
|
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Char
|
|
import qualified Data.List as List
|
|
import Color
|
|
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
|
|
--import Control.Monad
|
|
--import Data.Char
|
|
--import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Data.Terminal.Status
|
|
import Dodge.Data.World
|
|
import Dodge.Default
|
|
import Dodge.SoundLogic
|
|
import Dodge.Terminal.Type
|
|
import Justify
|
|
import LensHelp
|
|
--import ListHelp (safeHead, safeUncons)
|
|
import Sound.Data
|
|
|
|
textTerminal :: Terminal
|
|
textTerminal =
|
|
defaultTerminal
|
|
{ _tmBootLines = connectionBlurb
|
|
}
|
|
|
|
connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
|
|
connectionBlurbLines tls =
|
|
[ termSoundLine computerBeepingS
|
|
, TLine 0 [TerminalLineConst "LOADING TEXT INTERFACE..." termTextColor] TmWdId
|
|
]
|
|
++ tls
|
|
++ [TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput ""))]
|
|
|
|
-- ++ [TerminalLineEffect 0 (TmTmSetStatus (TerminalTextInput "" 0))]
|
|
|
|
--quitCommand :: TerminalCommand
|
|
--quitCommand =
|
|
-- TerminalCommand
|
|
-- { _tcString = "QUIT"
|
|
-- , _tcAlias = ["Q", "EXIT", "X", "SHUTDOWN", ""]
|
|
-- , _tcHelp = "Disconnects the terminal."
|
|
-- , _tcEffect = TerminalCommandArguments $ NoArguments [TLine 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 = connectionBlurbLines []
|
|
|
|
termSoundLine :: SoundID -> TerminalLine
|
|
termSoundLine sid = TLine 0 [] (TmWdWdTermSound sid)
|
|
|
|
termTextColor :: Color
|
|
termTextColor = greyN 0.9
|
|
|
|
getCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
getCommands tm = foldMap (getCommand tm) $ tm ^. tmCommands
|
|
|
|
getCommand :: Terminal -> TCom -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
getCommand tm = \case
|
|
TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
|
|
TCBase -> helpCommand <> quitCommand
|
|
TCDamageCommand -> damageCodeCommand
|
|
TCToggles -> toggleCommand tm
|
|
TCSensorInfo -> sensorCommand
|
|
|
|
damageCodeCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
damageCodeCommand = PTE.singleton "DAMAGECODE" $ PTE.fromList $ mapMaybe f [minBound..]
|
|
where
|
|
f :: SensorType -> Maybe (String, [TerminalLine])
|
|
f st = do
|
|
s <- g st
|
|
return (s, [TLine 0 [] $ TmGetDamageCoding st])
|
|
g = fmap (map toUpper) . fmap reverse . List.stripPrefix (reverse "Sensor")
|
|
. reverse . show
|
|
|
|
-- ugly, when changing check getSensorInfo
|
|
sensorCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
sensorCommand = PTE.singleton "SENSOR" $ PTE.fromList
|
|
[("REQUIREMENT", [])
|
|
,("DISTANCE",[])
|
|
,("STATUS",[])
|
|
]
|
|
|
|
toggleCommand :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
toggleCommand tm = PTE.singleton "TOGGLE" $ PTE.fromList $
|
|
M.toList $ fmap f $ tm ^. tmToggles
|
|
where
|
|
f x = [TLine 1
|
|
[TerminalLineConst "TOGGLE DONE!" termTextColor]
|
|
(TmWdWdfromWdWd (WdWdNegateTrig $ x ^. ttTriggerID))
|
|
]
|
|
|
|
helpCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
helpCommand = PTE.singleton "HELP" (fmap makeTermPara helpStrings)
|
|
|
|
helpStrings :: PTE.TrieMap Char String
|
|
helpStrings =
|
|
PTE.fromList
|
|
[ ("", "THIS TERMINAL PROCESSES TEXT INPUT. USE [TAB] FOR AVAILABLE COMMANDS AND AUTOCOMPLETE.")
|
|
, ("HELP", "BASIC HELP. ACCEPTS A COMMAND AS AN ARGUMENT.")
|
|
, ("QUIT", "SHUTDOWN TERMINAL.")
|
|
]
|
|
|
|
quitCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
quitCommand = PTE.singleton "QUIT" (PTE.singleton "" [TLine 0 [] TmWdWdDisconnectTerminal])
|
|
|
|
makeTermLine :: String -> TerminalLine
|
|
makeTermLine = makeColorTermLine termTextColor
|
|
|
|
makeTermPara :: String -> [TerminalLine]
|
|
makeTermPara = makeColorTermPara termTextColor
|
|
|
|
makeColorTermPara :: Color -> String -> [TerminalLine]
|
|
makeColorTermPara col = map (makeColorTermLine col) . makeParagraph 55
|
|
|
|
makeColorTermLine :: Color -> String -> TerminalLine
|
|
makeColorTermLine col str = TLine 1 [TerminalLineConst str col] TmWdId
|
|
|
|
commandColor :: Color
|
|
commandColor = yellow
|
|
|
|
-- ugly
|
|
tabComplete :: String -> Terminal -> Terminal
|
|
tabComplete s' tm = case PTE.lookup s $ getCommands tm of
|
|
Just m -> f (s ++ " ") $ PTE.toList $ PTE.lookupPrefix a m
|
|
Nothing -> f "" $ PTE.toList $ PTE.lookupPrefix s $ getCommands tm
|
|
where
|
|
ss = words s'
|
|
s = fromMaybe "" $ ss ^? ix 0
|
|
a = fromMaybe "" $ ss ^? ix 1
|
|
f y m' = case fmap fst m' of
|
|
[] -> tm
|
|
[x] -> tm & tmStatus .~ TerminalTextInput (y ++ x)
|
|
xs ->
|
|
tm & tmFutureLines
|
|
.~ makeColorTermPara
|
|
commandColor
|
|
(unwords xs)
|
|
|
|
--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 $ TLine 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)
|
|
|
|
|
|
--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
|
|
.~ [TLine 0 [] TmTmClearDisplayedLines]
|
|
)
|
|
|
|
exitTerminalSubInv :: World -> World
|
|
exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
|
|
Just _ ->
|
|
w & hud . hudElement . subInventory
|
|
.~ NoSubInventory --MouseInvNothing
|
|
_ -> 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 = [TLine 0 [] $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
|
|
|
|
simpleTermMessage :: [String] -> Terminal
|
|
simpleTermMessage strs = defaultTerminal & tmBootLines .~ 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) =
|
|
-- TLine 0 [] (TmTmSetPartialCommand (Just command)) :
|
|
-- makeTermPara ("Expects " ++ argtype ++ " as an argument")
|
|
-- | otherwise =
|
|
-- TLine 0 [] (TmTmSetPartialCommand Nothing) :
|
|
-- makeTermPara "No argument input, cancelling"
|
|
-- in Just $
|
|
-- fromMaybe setpartial $
|
|
-- safeHead args >>= (m M.!?)
|
|
-- where
|
|
-- errline = makeColorTermLine red
|
|
|
|
terminalReturnEffect :: Int -> World -> World
|
|
terminalReturnEffect tmid w = fromMaybe w $ do
|
|
tm <- w ^? cWorld . lWorld . terminals . ix tmid
|
|
s <- tm ^? tmStatus . tiText
|
|
return $
|
|
runTerminalInput s tm $
|
|
w
|
|
& cWorld . lWorld . terminals . ix tmid . tmDisplayedLines
|
|
.:~ (getPromptTM ++ s, termTextColor)
|
|
|
|
runTerminalInput :: String -> Terminal -> World -> World
|
|
runTerminalInput s tm w =
|
|
w & cWorld . lWorld . terminals . ix (_tmID tm)
|
|
%~ ( --(tmInput .~ TerminalInput{ _tiSel = (0, 0)})
|
|
|
|
(tmFutureLines ++.~ ss)
|
|
. (tmCommandHistory %~ take 10 . (s :))
|
|
. (tmStatus .~ TerminalTextInput "")
|
|
)
|
|
where
|
|
ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
|
|
let args = words s
|
|
x <- args ^? ix 0
|
|
teff <- PTE.lookup x (getCommands tm)
|
|
let y = fromMaybe "" (args ^? ix 1)
|
|
PTE.lookup y teff
|