188 lines
6.3 KiB
Haskell
188 lines
6.3 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Dodge.Terminal (
|
|
makeTermLine,
|
|
textInputBlurb,
|
|
textTerminal,
|
|
simpleTermMessage,
|
|
damageCodeCommand,
|
|
makeColorTermLine,
|
|
makeTermPara,
|
|
terminalReturnEffect,
|
|
getCommands,
|
|
tabComplete,
|
|
tlSetStatus,
|
|
tlDoEffect,
|
|
termTextColor,
|
|
) where
|
|
|
|
import Color
|
|
import Data.Char
|
|
import qualified Data.List as List
|
|
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
|
|
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 Sound.Data
|
|
|
|
textTerminal :: Terminal
|
|
textTerminal = defaultTerminal{_tmBootLines = textInputBlurb []}
|
|
|
|
textInputBlurb :: [TerminalLine] -> [TerminalLine]
|
|
textInputBlurb tls =
|
|
[termSoundLine computerBeepingS]
|
|
++ tls
|
|
++ tlSetStatus (TerminalTextInput "")
|
|
|
|
termSoundLine :: SoundID -> TerminalLine
|
|
termSoundLine = TLine 0 [] . TmWdWdTermSound
|
|
|
|
termTextColor :: Color
|
|
termTextColor = greyN 0.9
|
|
|
|
getCommands :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
getCommands w tm = foldMap (getCommand w tm) $ tm ^. tmCommands
|
|
|
|
getCommand :: World
|
|
-> Terminal -> TCom -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
getCommand w tm = \case
|
|
TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
|
|
TCBase -> quitCommand <> toggleCommands tm
|
|
TCDamageCommand -> damageCodeCommand w tm
|
|
|
|
damageCodeCommand :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
damageCodeCommand w _
|
|
= PTE.singleton "DAMAGECODE" $ PTE.fromList $ mapMaybe f [minBound ..]
|
|
where
|
|
f :: SensorType -> Maybe (String, [TerminalLine])
|
|
f st = do
|
|
s <- g st
|
|
return (s, decodeSensorType st w)
|
|
g =
|
|
fmap (map toUpper . reverse) . List.stripPrefix (reverse "Sensor")
|
|
. reverse
|
|
. show
|
|
|
|
decodeSensorType :: SensorType -> World -> [TerminalLine]
|
|
decodeSensorType st w = fromMaybe [] $ do
|
|
x <- w ^? cWorld . cwGen . cwgParams . sensorCoding . ix st
|
|
return [makeTermLine $ show x]
|
|
|
|
toggleCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
toggleCommands tm
|
|
| null ts = mempty
|
|
| otherwise = PTE.singleton "TOGGLE" $ PTE.fromList $ f <$> M.toList ts
|
|
where
|
|
ts = tm ^. tmToggles
|
|
f (s,x) = (s,
|
|
[ TLine
|
|
1
|
|
[TerminalLineConst (s ++ " TOGGLE DONE!") termTextColor]
|
|
(TmWdWdfromWdWd (WdWdNegateTrig $ x ^. ttTriggerID))
|
|
])
|
|
|
|
helpPara :: [TerminalLine]
|
|
helpPara = makeTermPara "THIS TERMINAL PROCESSES KEYBOARD INPUT. USE [RETURN] OR [LMB] TO REGISTER YOUR INPUT. AVAILABLE COMMANDS CAN BE SCROLLED THROUGH, HOLD [RMB] TO SCROLL THROUGH ARGUMENTS. USE [TAB] FOR AUTOCOMPLETE."
|
|
|
|
quitCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
quitCommand = PTE.singleton "QUIT" (PTE.singleton "" [TLine 0 [] TmWdWdPowerDownTerminal])
|
|
|
|
makeTermLine :: String -> TerminalLine
|
|
makeTermLine = makeColorTermLine termTextColor
|
|
|
|
tlSetStatus :: TerminalStatus -> [TerminalLine]
|
|
tlSetStatus x = tlDoEffect $ TmTmSetStatus x
|
|
|
|
tlDoEffect :: TmWdWd -> [TerminalLine]
|
|
tlDoEffect x = [TLine 1 [] x]
|
|
|
|
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
|
|
|
|
tabComplete :: World -> Terminal -> Terminal
|
|
tabComplete w tm = fromMaybe tm $ do
|
|
s <- tm ^? tmStatus . tiText
|
|
return $ tabComplete' s w tm
|
|
|
|
-- ugly, can improve output to explain when showing available arguments
|
|
tabComplete' :: String -> World -> Terminal -> Terminal
|
|
tabComplete' s' w tm = case PTE.lookup s $ getCommands w tm of
|
|
Just m -> f (s ++ " ") $ PTE.toList $ PTE.lookupPrefix a m
|
|
Nothing -> f "" $ PTE.toList $ PTE.lookupPrefix s $ getCommands w 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 . tiText .~ (y ++ x)
|
|
xs ->
|
|
tm & tmStatus .~ TerminalLineRead
|
|
& tmFutureLines
|
|
.~ ( makeColorTermPara
|
|
commandColor
|
|
(unwords xs)
|
|
<> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s']
|
|
)
|
|
|
|
--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
|
|
|
|
-- list available arguments on function input?
|
|
terminalReturnEffect :: Int -> World -> World
|
|
terminalReturnEffect tmid w = fromMaybe w $ do
|
|
tm' <- w ^? cWorld . lWorld . terminals . ix tmid
|
|
let tm = tabComplete w tm'
|
|
s <- tm ^? tmStatus . tiText
|
|
let ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
|
|
let args = words s
|
|
case args of
|
|
[] -> return helpPara
|
|
(x:_) -> do
|
|
teff <- PTE.lookup x (getCommands w tm)
|
|
let y = fromMaybe "" (args ^? ix 1)
|
|
PTE.lookup y teff
|
|
return $ w
|
|
& totm . tmDisplayedLines .:~ (getPromptTM ++ s, termTextColor)
|
|
& totm . tmFutureLines .~ ss <> tlSetStatus (TerminalTextInput "")
|
|
& totm . tmCommandHistory %~ take 10 . (s :)
|
|
& totm . tmStatus .~ TerminalLineRead
|
|
where
|
|
totm = cWorld . lWorld . terminals . ix tmid
|