333 lines
11 KiB
Haskell
333 lines
11 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Dodge.Terminal (
|
|
makeTermLine,
|
|
textInputBlurb,
|
|
textTerminal,
|
|
simpleTermMessage,
|
|
damageCodeCommand,
|
|
makeColorTermLine,
|
|
makeTermPara,
|
|
terminalReturnEffect,
|
|
getCommands,
|
|
-- tabComplete,
|
|
tlSetStatus,
|
|
tlDoEffect,
|
|
termTextColor,
|
|
doTabComplete,
|
|
recComFindSuccessor,
|
|
recComFindPredecessor,
|
|
recComFindMin,
|
|
recComFindMax,
|
|
recComLookup,
|
|
) 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
|
|
|
|
--type TCommands = PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
|
type TCommands = RecCommands [TerminalLine]
|
|
|
|
getCommands :: World -> Terminal -> TCommands
|
|
getCommands w tm = foldMap (getCommand w tm) $ tm ^. tmCommands
|
|
|
|
getCommand :: World -> Terminal -> TCom -> TCommands
|
|
getCommand w tm = \case
|
|
TCInfo x z -> RCommands $ PTE.singleton x (Right (makeTermPara z))
|
|
TCBase -> quitCommand <> toggleCommands tm
|
|
TCDamageCommand -> damageCodeCommand w tm
|
|
|
|
damageCodeCommand :: World -> Terminal -> TCommands
|
|
damageCodeCommand w _ = RCommands .
|
|
PTE.singleton "DAMAGECODE" . Left . RCommands $ PTE.fromList $ mapMaybe f [minBound ..]
|
|
where
|
|
f :: SensorType -> Maybe (String, Either TCommands [TerminalLine])
|
|
f st = do
|
|
s <- g st
|
|
return (s, Right $ 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 -> TCommands
|
|
toggleCommands tm
|
|
| null ts = mempty
|
|
| otherwise = RCommands . PTE.singleton "TOGGLE" . Left . RCommands . PTE.fromList
|
|
$ f <$> M.toList ts
|
|
where
|
|
ts = tm ^. tmToggles
|
|
f (s, x) =
|
|
( s
|
|
, Right
|
|
[ 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 :: TCommands
|
|
quitCommand = RCommands . PTE.singleton "QUIT" $ Right [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']
|
|
-- )
|
|
|
|
data TabCompletion a
|
|
= TabMatch a
|
|
| TabComplete String
|
|
| TabMultiComplete [String]
|
|
| TabFail
|
|
|
|
data RecCommands a =
|
|
RCommands {_rCommands :: (PTE.TrieMap Char (Either (RecCommands a) a))}
|
|
|
|
-- assumes that each command Trie has at least one successful command
|
|
recComFindMin :: RecCommands a -> Maybe ([String], a)
|
|
recComFindMin (RCommands m) = case PTE.findMin m of
|
|
Just (s,Right a) -> Just ([s],a)
|
|
Just (s,Left m') -> recComFindMin m' & _Just . _1 .:~ s
|
|
Nothing -> Nothing
|
|
|
|
recComFindMax :: RecCommands a -> Maybe ([String], a)
|
|
recComFindMax (RCommands m) = case PTE.findMax m of
|
|
Just (s,Right a) -> Just ([s],a)
|
|
Just (s,Left m') -> recComFindMax m' & _Just . _1 .:~ s
|
|
Nothing -> Nothing
|
|
|
|
recComLookup :: [String] -> RecCommands a -> Maybe a
|
|
recComLookup (s:ss) (RCommands t) = do
|
|
x <- PTE.lookup s t
|
|
case x of
|
|
Left m -> recComLookup ss m
|
|
Right y -> return y
|
|
recComLookup [] _ = Nothing
|
|
|
|
-- assumes that the commands are well-formed, i.e. every tree does end in a
|
|
-- command
|
|
recComFindSuccessor :: [String] -> RecCommands a -> Maybe ([String],a)
|
|
recComFindSuccessor (s:ss) (RCommands m)
|
|
| Just (Left rm) <- PTE.lookup s m
|
|
, Just (ss', x) <- recComFindSuccessor ss rm = Just (s:ss',x)
|
|
| otherwise = case PTE.findSuccessor s m of
|
|
Just (s',Right x) -> Just ([s'],x)
|
|
Just (s',Left rm') -> recComFindMin rm' & _Just . _1 .:~ s'
|
|
Nothing -> Nothing
|
|
recComFindSuccessor [] rm = recComFindMin rm
|
|
|
|
recComFindPredecessor :: [String] -> RecCommands a -> Maybe ([String],a)
|
|
recComFindPredecessor (s:ss) (RCommands m)
|
|
| Just (Left rm) <- PTE.lookup s m
|
|
, Just (ss', x) <- recComFindPredecessor ss rm = Just (s:ss',x)
|
|
| otherwise = case PTE.findPredecessor s m of
|
|
Just (s',Right x) -> Just ([s'],x)
|
|
Just (s',Left rm') -> recComFindMax rm' & _Just . _1 .:~ s'
|
|
Nothing -> Nothing
|
|
recComFindPredecessor [] rm = recComFindMax rm
|
|
--
|
|
--recComFindPredecessor :: [String] -> RecCommands a -> Maybe ([String],a)
|
|
--recComFindPredecessor (s:ss) (RCommands m) = Nothing
|
|
|
|
instance Semigroup (RecCommands a) where
|
|
RCommands x <> RCommands y = RCommands $ x <> y
|
|
|
|
instance Monoid (RecCommands a) where
|
|
mempty = RCommands mempty
|
|
|
|
|
|
tbComplete :: String -> PTE.TrieMap Char a -> TabCompletion a
|
|
tbComplete s t = case e of
|
|
[] | Just x <- mx -> TabMatch x
|
|
[] -> case fmap fst $ PTE.toList t' of
|
|
[] -> TabFail
|
|
ss -> TabMultiComplete ss
|
|
_ -> TabComplete e
|
|
where
|
|
(e, mx, t') = PTE.splitPrefix $ PTE.deletePrefix s t
|
|
|
|
recTabComplete :: String -> TCommands -> TabCompletion [TerminalLine]
|
|
recTabComplete s (RCommands t) = fromMaybe (TabMultiComplete $ allstrings $ t) $ do
|
|
(s1,ss) <- stripHead $ words s
|
|
case tbComplete s1 t of
|
|
TabComplete e -> return $ TabComplete e
|
|
TabMultiComplete es -> return $ TabMultiComplete (fmap (s1 <>) es)
|
|
TabFail -> return $ TabFail
|
|
TabMatch (Right x) -> return $ TabMatch x
|
|
TabMatch (Left rm) -> return $ recTabComplete (unwords ss) rm
|
|
where
|
|
stripHead (x:xs) = Just (x,xs)
|
|
stripHead _ = Nothing
|
|
allstrings = fmap fst . PTE.toList
|
|
|
|
doTabComplete :: World -> Terminal -> Terminal
|
|
doTabComplete w tm = fromMaybe tm $ do
|
|
s <- tm ^? tmStatus . tiText
|
|
case recTabComplete s $ getCommands w tm of
|
|
TabMatch _ -> return tm
|
|
TabComplete e -> return $ tm & tmStatus . tiText <>~ e
|
|
TabMultiComplete ss -> return $ tm
|
|
& tmStatus .~ TerminalLineRead
|
|
& tmFutureLines .~
|
|
[TLine 0 [TerminalLineConst (getPromptTM <> s) termTextColor] TmWdId] <>
|
|
(makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s])
|
|
TabFail -> return tm
|
|
|
|
-- 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 = w
|
|
& cWorld . lWorld . terminals . ix tmid %~ terminalReturnLocal w
|
|
|
|
terminalReturnLocal :: World -> Terminal -> Terminal
|
|
terminalReturnLocal w tm = fromMaybe tm $ do
|
|
s <- tm ^? tmStatus . tiText
|
|
return $ tm
|
|
& tmFutureLines .~ [TLine 0 [TerminalLineConst (getPromptTM <> s) termTextColor] TmWdId]
|
|
& case recTabComplete s $ getCommands w tm of
|
|
TabMatch x -> (tmStatus .~ TerminalLineRead )
|
|
. (tmFutureLines <>~ (x<>tlSetStatus (TerminalTextInput "")))
|
|
TabComplete e -> tmStatus . tiText <>~ e
|
|
TabMultiComplete ss ->
|
|
(tmStatus .~ TerminalLineRead)
|
|
. ( tmFutureLines <>~
|
|
(makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s])
|
|
)
|
|
TabFail -> id
|
|
|
|
-- 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
|