Move towards implementing terminal autocomplete
This commit is contained in:
@@ -8,7 +8,6 @@ module Dodge.Data.Terminal (
|
||||
module Dodge.Data.Terminal.Status,
|
||||
) where
|
||||
|
||||
import qualified Data.ListTrie.Patricia.Map.Enum as PT
|
||||
import Sound.Data
|
||||
import Color
|
||||
import Control.Lens
|
||||
@@ -31,12 +30,12 @@ data Terminal = Terminal
|
||||
, _tmExternalColor :: Color
|
||||
, _tmDisplayedLines :: [(String, Color)]
|
||||
, _tmFutureLines :: [TerminalLine]
|
||||
, _tmCommands :: [TerminalCommand]
|
||||
, _tmCommands :: [TCom]
|
||||
, _tmDeathEffect :: TmWdWd
|
||||
, _tmStatus :: TerminalStatus
|
||||
, _tmCommandHistory :: [String]
|
||||
, _tmToggles :: M.Map String TerminalToggle
|
||||
, _tmPartialCommand :: Maybe TerminalCommand
|
||||
-- , _tmPartialCommand :: Maybe TerminalCommand
|
||||
}
|
||||
|
||||
data TerminalLineString = TerminalLineConst String Color
|
||||
@@ -77,10 +76,13 @@ data TerminalCommand = TerminalCommand
|
||||
, _tcEffect :: TerminalCommandEffect -- Terminal -> World -> EffectArguments
|
||||
}
|
||||
|
||||
data TCom = TCom
|
||||
{ _tcomHelp :: String
|
||||
, _tcomArgs :: PT.TrieMap Char [TerminalLine]
|
||||
}
|
||||
data TCom = TCInfo String String
|
||||
| TCBase
|
||||
|
||||
--data TEff = TEff
|
||||
-- { _teffHelp :: String
|
||||
-- , _teffArgs :: PTE.TrieMap Char [TerminalLine]
|
||||
-- }
|
||||
|
||||
data TmWdWd
|
||||
= TmWdId
|
||||
@@ -90,13 +92,14 @@ data TmWdWd
|
||||
| TmWdWdDoDeathTriggers
|
||||
| TmTmClearDisplayedLines
|
||||
| TmTmSetStatus TerminalStatus
|
||||
| TmTmSetPartialCommand (Maybe TerminalCommand)
|
||||
| TmDisplayCommands
|
||||
|
||||
makeLenses ''Terminal
|
||||
makeLenses ''TerminalLine
|
||||
makeLenses ''TerminalToggle
|
||||
makeLenses ''EffectArguments
|
||||
makeLenses ''TerminalCommand
|
||||
makeLenses ''TCom
|
||||
concat
|
||||
<$> mapM
|
||||
(deriveJSON defaultOptions)
|
||||
@@ -106,6 +109,7 @@ concat
|
||||
, ''EffectArguments
|
||||
, ''TerminalCommandEffect
|
||||
, ''TerminalCommand
|
||||
, ''TCom
|
||||
, ''TmWdWd
|
||||
, ''Terminal
|
||||
]
|
||||
|
||||
@@ -10,7 +10,7 @@ import Data.Aeson.TH
|
||||
data TerminalStatus
|
||||
= TerminalOff
|
||||
| TerminalBusy
|
||||
| TerminalTextInput {_tiText :: String, _tiSel :: Int}
|
||||
| TerminalTextInput {_tiText :: String}
|
||||
| TerminalPressTo {_tptString :: String}
|
||||
-- | TerminalArgumentInput TerminalCommand
|
||||
deriving (Eq)
|
||||
|
||||
@@ -16,14 +16,11 @@ defaultTerminal =
|
||||
, _tmMachineID = 0
|
||||
, _tmDisplayedLines = []
|
||||
, _tmFutureLines = []
|
||||
-- , _tmInput = defaultTerminalInput
|
||||
, _tmCommands = []
|
||||
-- , _tmWriteCommands = []
|
||||
, _tmDeathEffect = TmWdId
|
||||
, _tmCommands = [TCInfo "TEST" "display text",TCBase]
|
||||
, _tmDeathEffect = TmWdWdDoDeathTriggers
|
||||
, _tmStatus = TerminalOff
|
||||
, _tmCommandHistory = []
|
||||
, _tmToggles = mempty
|
||||
, _tmPartialCommand = Nothing
|
||||
, _tmExternalColor = dark magenta
|
||||
}
|
||||
|
||||
|
||||
@@ -21,7 +21,8 @@ analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
|
||||
(themachine & mcMounts . at OTTrigger .~ _plMID tp)
|
||||
tparams -- (linksensortotrigger tp)
|
||||
where
|
||||
tparams = basicTerminal & tmCommands .:~ sensorCommand
|
||||
--tparams = basicTerminal & tmCommands .:~ sensorCommand
|
||||
tparams = basicTerminal
|
||||
-- linksensortotrigger tp _ mc
|
||||
-- = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)
|
||||
themachine =
|
||||
|
||||
@@ -384,7 +384,7 @@ drawTerminalDisplay tid cfig w = fromMaybe mempty $ do
|
||||
displayTermInput tm = case _tmStatus tm of
|
||||
TerminalOff -> id
|
||||
TerminalBusy -> (++ [([cFilledRect], white)])
|
||||
TerminalTextInput s _ ->
|
||||
TerminalTextInput s ->
|
||||
(++ [(getPromptTM ++ s ++ [cFilledRect], white)])
|
||||
TerminalPressTo s ->
|
||||
(++ [("PRESS TO "++s, white)])
|
||||
|
||||
@@ -74,7 +74,8 @@ sensInsideDoor senseType outplid rm =
|
||||
.++~ [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100))
|
||||
, psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))
|
||||
, psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80
|
||||
, putMessageTerminal terminalColor (basicTerminal & tmCommands .:~ damageCodeCommand)
|
||||
, putMessageTerminal terminalColor (basicTerminal-- & tmCommands .:~ damageCodeCommand)
|
||||
)
|
||||
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
|
||||
]
|
||||
& rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
|
||||
|
||||
@@ -47,7 +47,7 @@ addWarningTerminal str outplid =
|
||||
)
|
||||
termMessages trpl =
|
||||
lineOutputTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
|
||||
& tmCommands .:~ toggleCommand
|
||||
-- & tmCommands .:~ toggleCommand
|
||||
& tmToggles
|
||||
.~ M.fromList
|
||||
[("DOOR", TerminalToggle (fromJust $ _plMID trpl) (BlConst True))]
|
||||
|
||||
+157
-132
@@ -1,10 +1,11 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Dodge.Terminal (
|
||||
doTerminalCommandEffect,
|
||||
-- doTerminalCommandEffect,
|
||||
makeTermLine,
|
||||
commandFutureLines,
|
||||
quitCommand,
|
||||
helpCommand,
|
||||
commandsCommand,
|
||||
-- commandFutureLines,
|
||||
-- quitCommand,
|
||||
-- helpCommand,
|
||||
-- commandsCommand,
|
||||
connectionBlurbLines,
|
||||
disconnectTerminal,
|
||||
basicTerminal,
|
||||
@@ -15,15 +16,18 @@ module Dodge.Terminal (
|
||||
makeTermPara,
|
||||
toggleCommand,
|
||||
terminalReturnEffect,
|
||||
getCommands,
|
||||
makeColorTermPara,
|
||||
commandColor,
|
||||
) where
|
||||
|
||||
import Dodge.Data.WorldEffect
|
||||
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
|
||||
--import Dodge.Data.WorldEffect
|
||||
import Dodge.Data.Terminal.Status
|
||||
import Color
|
||||
--import Control.Monad
|
||||
import Data.Char
|
||||
import Data.Foldable
|
||||
import qualified Data.Map.Strict as M
|
||||
--import Data.Char
|
||||
--import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Dodge.Data.World
|
||||
import Dodge.Default
|
||||
@@ -31,18 +35,13 @@ import Dodge.SoundLogic
|
||||
import Dodge.Terminal.Type
|
||||
import Justify
|
||||
import LensHelp
|
||||
import ListHelp (safeHead, safeUncons)
|
||||
--import ListHelp (safeHead, safeUncons)
|
||||
import Sound.Data
|
||||
|
||||
basicTerminal :: Terminal
|
||||
basicTerminal =
|
||||
defaultTerminal
|
||||
{ _tmDisplayedLines = []
|
||||
, _tmFutureLines = []
|
||||
-- , _tmTitle = "TERMINAL"
|
||||
, _tmCommands = [helpCommand,commandsCommand,quitCommand]
|
||||
-- , _tmWriteCommands = [helpCommand, commandsCommand]
|
||||
, _tmBootLines = connectionBlurb
|
||||
{ _tmBootLines = connectionBlurb
|
||||
, _tmDeathEffect = TmWdWdDoDeathTriggers
|
||||
}
|
||||
|
||||
@@ -52,53 +51,53 @@ connectionBlurbLines tls =
|
||||
, TLine 0 [TerminalLineConst "LOADING TEXT INTERFACE..." termTextColor] TmWdId
|
||||
]
|
||||
++ tls
|
||||
++ [ TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput "" 0))]
|
||||
++ [ 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]
|
||||
}
|
||||
--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
|
||||
}
|
||||
--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]
|
||||
)
|
||||
--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
|
||||
}
|
||||
--commandsCommand :: TerminalCommand
|
||||
--commandsCommand =
|
||||
-- TerminalCommand
|
||||
-- { _tcString = "COMMANDS"
|
||||
-- , _tcAlias = ["COMMAND", "COM"]
|
||||
-- , _tcHelp = "Displays available commands."
|
||||
-- , _tcEffect = TerminalCommandEffectCommands
|
||||
-- }
|
||||
|
||||
connectionBlurb :: [TerminalLine]
|
||||
connectionBlurb = connectionBlurbLines []
|
||||
@@ -109,8 +108,28 @@ termSoundLine sid = TLine 0 [] (TmWdWdTermSound sid)
|
||||
termTextColor :: Color
|
||||
termTextColor = greyN 0.9
|
||||
|
||||
getCommands :: Terminal -> [TerminalCommand]
|
||||
getCommands tm = _tmCommands tm -- ++ _tmWriteCommands tm
|
||||
getCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
getCommands = foldMap getCommand . _tmCommands -- tm -- ++ _tmWriteCommands tm
|
||||
|
||||
getCommand :: TCom -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
getCommand = \case
|
||||
TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
|
||||
TCBase -> helpCommand <> commandsCommand <> quitCommand
|
||||
|
||||
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. INPUT \"COMMANDS\" TO LIST AVAILABLE FUNCTIONALITY.")
|
||||
,("HELP", "BASIC HELP. ACCEPTS A COMMAND AS AN ARGUMENT.")
|
||||
]
|
||||
|
||||
commandsCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
commandsCommand = PTE.singleton "COMMANDS" (PTE.singleton "" [TLine 0 [] TmDisplayCommands])
|
||||
|
||||
quitCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
quitCommand = PTE.singleton "QUIT" (PTE.singleton "" [TLine 0 [] TmWdWdDisconnectTerminal])
|
||||
|
||||
makeTermLine :: String -> TerminalLine
|
||||
makeTermLine = makeColorTermLine termTextColor
|
||||
@@ -127,29 +146,29 @@ makeColorTermLine col str = TLine 1 [TerminalLineConst str col] TmWdId
|
||||
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 $ TLine 0 [] (TmWdWdfromWdWd eff) : map makeTermLine followingLines
|
||||
TerminalCommandEffectNone -> \_ _ -> NoArguments []
|
||||
--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)
|
||||
)
|
||||
--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 =
|
||||
@@ -169,24 +188,24 @@ argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
|
||||
-- , _tcEffect = TerminalCommandEffectSingleCommand eff followingLines
|
||||
-- }
|
||||
|
||||
getDamageCoding :: World -> M.Map String [TerminalLine]
|
||||
getDamageCoding = decodedtmap . _sensorCoding . _cwgParams . _cwGen . _cWorld
|
||||
--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)
|
||||
]
|
||||
--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)
|
||||
--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 =
|
||||
@@ -197,8 +216,8 @@ toggleCommand =
|
||||
, _tcEffect = TerminalCommandEffectLinkedObject -- \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm)
|
||||
}
|
||||
|
||||
decodedtmap :: M.Map SensorType (PaletteColor, DecorationShape) -> M.Map String [TerminalLine]
|
||||
decodedtmap = M.mapKeys show . M.map ((: []) . makeTermLine . show)
|
||||
--decodedtmap :: M.Map SensorType (PaletteColor, DecorationShape) -> M.Map String [TerminalLine]
|
||||
--decodedtmap = M.mapKeys show . M.map ((: []) . makeTermLine . show)
|
||||
|
||||
sensorCommand :: TerminalCommand
|
||||
sensorCommand =
|
||||
@@ -240,51 +259,57 @@ damageCodeCommand =
|
||||
-- . (tmFutureLines ++.~ tls)
|
||||
-- )
|
||||
|
||||
togglesToEffects :: Terminal -> M.Map String [TerminalLine]
|
||||
togglesToEffects = fmap f . _tmToggles
|
||||
where
|
||||
f tt = [TLine 0 [] $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
|
||||
--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
|
||||
--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
|
||||
-- guard $ _tmStatus tm == TerminalTextInput
|
||||
s <- tm ^? tmStatus . tiText
|
||||
let pc = maybe "" (++ " ") $ tm ^? tmPartialCommand . _Just . tcString
|
||||
return $
|
||||
runTerminalString (pc ++ s) tm $
|
||||
runTerminalInput s tm $
|
||||
w
|
||||
& cWorld . lWorld . terminals . ix tmid . tmPartialCommand .~ Nothing
|
||||
& cWorld . lWorld . terminals . ix tmid . tmFutureLines
|
||||
.~ [makeTermLine (pc ++ getPromptTM ++ s)]
|
||||
& cWorld . lWorld . terminals . ix tmid . tmDisplayedLines
|
||||
.:~ (getPromptTM ++ s,termTextColor)
|
||||
|
||||
runTerminalString :: String -> Terminal -> World -> World
|
||||
runTerminalString s tm w =
|
||||
runTerminalInput :: String -> Terminal -> World -> World
|
||||
runTerminalInput s tm w =
|
||||
w & cWorld . lWorld . terminals . ix (_tmID tm)
|
||||
%~ ( --(tmInput .~ TerminalInput{ _tiSel = (0, 0)})
|
||||
(tmFutureLines ++.~ commandFutureLines s tm w)
|
||||
|
||||
(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
|
||||
|
||||
@@ -10,6 +10,6 @@ import Control.Lens
|
||||
termScreenColor :: Terminal -> Maybe Color
|
||||
termScreenColor tm = case tm ^. tmStatus of
|
||||
TerminalOff -> Nothing
|
||||
TerminalTextInput _ _ -> Just green
|
||||
TerminalTextInput _ -> Just green
|
||||
TerminalPressTo{} -> Just green
|
||||
TerminalBusy -> Just white
|
||||
|
||||
@@ -1,7 +1,10 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Update.Scroll (
|
||||
updateWheelEvent,
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
|
||||
import Dodge.Data.Terminal.Status
|
||||
import Dodge.Data.EquipType
|
||||
import Padding
|
||||
@@ -123,16 +126,34 @@ moveCombineSel yi =
|
||||
return $ ci & ciSelection %~ scrollSelectionSections yi sss
|
||||
|
||||
terminalWheelEvent :: Int -> Int -> World -> World
|
||||
--terminalWheelEvent yi tmid w
|
||||
terminalWheelEvent _ tmid w
|
||||
terminalWheelEvent yi tmid w
|
||||
| w & has (input . mouseButtons . ix ButtonRight)
|
||||
, Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
|
||||
w -- & cWorld . lWorld . terminals . ix tmid %~ updatetermsubsel
|
||||
w & cWorld . lWorld . terminals . ix tmid %~ g
|
||||
| Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
|
||||
w -- & cWorld . lWorld . terminals . ix tmid %~ updatetermsel
|
||||
w & cWorld . lWorld . terminals . ix tmid %~ f
|
||||
| otherwise = w
|
||||
where
|
||||
-- updatetermsel tm = case tm ^? tmInput . tiSel of
|
||||
dowrap = if yi > 0 then wrapup else wrapdown
|
||||
wrapup s coms = PTE.findSuccessor s coms <|> PTE.findMin coms
|
||||
wrapdown s coms = PTE.findPredecessor s coms <|> PTE.findMax coms
|
||||
f tm = fromMaybe tm $ do
|
||||
let coms = getCommands tm
|
||||
x <- tm ^? tmStatus . tiText
|
||||
let s = fromMaybe "" $ x ^? to words . ix 0
|
||||
(s',_) <- dowrap s coms
|
||||
return $ tm & tmStatus . tiText .~ s'
|
||||
g tm = fromMaybe tm $ do
|
||||
let coms = getCommands tm
|
||||
x <- tm ^? tmStatus . tiText
|
||||
let s = fromMaybe "" $ x ^? to words . ix 0
|
||||
y = fromMaybe "" $ x ^? to words . ix 1
|
||||
-- (s',m) <- fmap (s,) (PTE.lookup s coms) <|> dowrap s coms
|
||||
-- (arg,_) <- dowrap y m
|
||||
(s',arg,_) <- if yi > 0 then doubleFindSucc s y coms <|> doubleFindMin coms
|
||||
else doubleFindPred s y coms <|> doubleFindMax coms
|
||||
return $ tm & tmStatus . tiText .~ s' ++ " " ++ arg
|
||||
--case tm ^? tmInput . tiSel of
|
||||
-- Nothing -> tm & tmInput . tiSel .~ (0, 0)
|
||||
-- Just (i, _) ->
|
||||
-- let newi = (i - yi) `mod` length (scrollCommandStrings w tm)
|
||||
@@ -151,6 +172,47 @@ terminalWheelEvent _ tmid w
|
||||
-- tc = scrollCommands tm !! i
|
||||
-- arg = getArguments' tc tm w !! j
|
||||
|
||||
doubleFindMin :: (Enum a,Enum b) => PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
|
||||
doubleFindMin m = do
|
||||
(x,n) <- PTE.findMin m
|
||||
case PTE.findMin n of
|
||||
Just (y,z) -> Just (x,y,z)
|
||||
Nothing -> Nothing
|
||||
|
||||
doubleFindSucc :: (Enum a,Enum b) => [a] -> [b] -> PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
|
||||
doubleFindSucc xs ys m = case PTE.lookup xs m of
|
||||
Just m' -> case PTE.findSuccessor ys m' of
|
||||
Just (ys',z) -> Just (xs,ys',z)
|
||||
Nothing -> dfs xs m
|
||||
Nothing -> dfs xs m
|
||||
where
|
||||
dfs xs' m' = case PTE.findSuccessor xs' m' of
|
||||
Just (xs'',n) -> case PTE.findMin n of
|
||||
Just (ys',z) -> Just (xs'',ys',z)
|
||||
Nothing -> dfs xs'' m'
|
||||
Nothing -> Nothing
|
||||
|
||||
-- there are edge cases where this doesn't behave as might be expected
|
||||
doubleFindMax :: (Enum a,Enum b) => PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
|
||||
doubleFindMax m = do
|
||||
(x,n) <- PTE.findMax m
|
||||
case PTE.findMax n of
|
||||
Just (y,z) -> Just (x,y,z)
|
||||
Nothing -> Nothing
|
||||
|
||||
doubleFindPred :: (Enum a,Enum b) => [a] -> [b] -> PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
|
||||
doubleFindPred xs ys m = case PTE.lookup xs m of
|
||||
Just m' -> case PTE.findPredecessor ys m' of
|
||||
Just (ys',z) -> Just (xs,ys',z)
|
||||
Nothing -> dfs xs m
|
||||
Nothing -> dfs xs m
|
||||
where
|
||||
dfs xs' m' = case PTE.findPredecessor xs' m' of
|
||||
Just (xs'',n) -> case PTE.findMax n of
|
||||
Just (ys',z) -> Just (xs'',ys',z)
|
||||
Nothing -> dfs xs'' m'
|
||||
Nothing -> Nothing
|
||||
|
||||
scrollRBOption :: Int -> Int -> Int -> Int
|
||||
scrollRBOption dy ymax
|
||||
| dy < 0 = min (ymax -1) . subtract dy
|
||||
@@ -177,7 +239,7 @@ scrollRBOption dy ymax
|
||||
-- , _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments []
|
||||
-- }
|
||||
|
||||
getArguments :: TerminalCommand -> Terminal -> World -> [String]
|
||||
getArguments tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
|
||||
NoArguments{} -> []
|
||||
OneArgument _ m -> map (' ' :) $ M.keys m
|
||||
--getArguments :: TerminalCommand -> Terminal -> World -> [String]
|
||||
--getArguments tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
|
||||
-- NoArguments{} -> []
|
||||
-- OneArgument _ m -> map (' ' :) $ M.keys m
|
||||
|
||||
@@ -5,6 +5,7 @@ module Dodge.WorldEffect (
|
||||
lineOutputTerminal,
|
||||
) where
|
||||
|
||||
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
|
||||
--import Dodge.DoubleTree
|
||||
import Dodge.Data.Terminal.Status
|
||||
import Dodge.Item.Grammar
|
||||
@@ -78,9 +79,6 @@ lineOutputTerminal tls =
|
||||
defaultTerminal
|
||||
{ _tmDisplayedLines = []
|
||||
, _tmFutureLines = []
|
||||
-- , _tmTitle = "TERMINAL"
|
||||
, _tmCommands = [helpCommand,commandsCommand,quitCommand]
|
||||
-- , _tmWriteCommands = [helpCommand, commandsCommand]
|
||||
, _tmBootLines = connectionBlurbLines tls
|
||||
, _tmDeathEffect = TmWdWdDoDeathTriggers
|
||||
}
|
||||
@@ -101,9 +99,14 @@ doTmWdWd tmwdwd = case tmwdwd of
|
||||
TmTmSetStatus x -> \tm -> fromMaybe id $ do
|
||||
tid <- tm ^? tmID
|
||||
return $ cWorld . lWorld . terminals . ix tid . tmStatus .~ x
|
||||
TmTmSetPartialCommand x -> \tm -> fromMaybe id $ do
|
||||
TmDisplayCommands -> \tm -> fromMaybe id $ do
|
||||
tid <- tm ^? tmID
|
||||
return $ cWorld . lWorld . terminals . ix tid . tmPartialCommand .~ x
|
||||
return $ cWorld . lWorld . terminals . ix tid . tmFutureLines .~
|
||||
makeColorTermPara commandColor
|
||||
(unwords (map fst (PTE.toList $ getCommands tm)))
|
||||
-- TmTmSetPartialCommand x -> \tm -> fromMaybe id $ do
|
||||
-- tid <- tm ^? tmID
|
||||
-- return $ cWorld . lWorld . terminals . ix tid . tmPartialCommand .~ x
|
||||
TmWdId -> const id
|
||||
TmWdWdDisconnectTerminal -> disconnectTerminal
|
||||
TmWdWdTermSound sid -> \tm w ->
|
||||
|
||||
+6
-6
@@ -31,19 +31,19 @@ lookupTrie :: Ord a => [a] -> Trie a b -> Maybe b
|
||||
lookupTrie (k : ks) t = _trieChildren t M.!? k >>= lookupTrie ks
|
||||
lookupTrie [] t = _trieMVal t
|
||||
|
||||
--nextTrie :: Ord a => [a] -> Trie a b -> Maybe (b, Trie a b)
|
||||
nextTrie :: [a] -> Trie a b -> Maybe (b, Trie a b)
|
||||
nextTrie (k:ks) t = undefined
|
||||
nextTrie [] t = Nothing
|
||||
----nextTrie :: Ord a => [a] -> Trie a b -> Maybe (b, Trie a b)
|
||||
--nextTrie :: [a] -> Trie a b -> Maybe (b, Trie a b)
|
||||
--nextTrie (k:ks) t = undefined
|
||||
--nextTrie [] t = Nothing
|
||||
|
||||
splitLookupTrie :: Ord a => [a] -> Trie a b -> (Trie a b,Maybe b,Trie a b)
|
||||
splitLookupTrie (k:ks) t@(Trie x xs) = case m of
|
||||
splitLookupTrie (k:ks) (Trie x xs) = case m of
|
||||
Nothing -> (Trie x l,Nothing,Trie x r)
|
||||
Just t' -> let (l',m',r') = splitLookupTrie ks t'
|
||||
in (Trie x (M.insert k l' l),m', Trie x (M.insert k r' r))
|
||||
where
|
||||
(l,m,r) = M.splitLookup k xs
|
||||
splitLookupTrie [] t@(Trie x xs) = (Trie Nothing mempty,x, Trie Nothing xs)
|
||||
splitLookupTrie [] (Trie x xs) = (Trie Nothing mempty,x, Trie Nothing xs)
|
||||
-- the above would be better if it removed empty trie strings; the left trie
|
||||
-- will always be empty and the right trie might be empty.
|
||||
-- I cannot think of a smart way to do this
|
||||
|
||||
Reference in New Issue
Block a user