196 lines
6.5 KiB
Haskell
196 lines
6.5 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Dodge.Terminal (
|
|
makeTermLine,
|
|
connectionBlurbLines,
|
|
textTerminal,
|
|
simpleTermMessage,
|
|
damageCodeCommand,
|
|
sensorCommand,
|
|
makeColorTermLine,
|
|
makeTermPara,
|
|
toggleCommand,
|
|
terminalReturnEffect,
|
|
getCommands,
|
|
tabComplete,
|
|
tlSetStatus,
|
|
) 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 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 ""))]
|
|
|
|
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 . 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 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 = [TLine 1 [] $ TmTmSetStatus 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
|
|
|
|
-- 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 . 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
|
|
|
|
terminalReturnEffect :: Int -> World -> World
|
|
terminalReturnEffect tmid w = fromMaybe w $ do
|
|
tm <- w ^? cWorld . lWorld . terminals . ix tmid
|
|
s <- tm ^? tmStatus . tiText
|
|
let 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
|
|
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
|