273 lines
10 KiB
Haskell
273 lines
10 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Terminal where
|
|
import Dodge.Data
|
|
import Dodge.Default
|
|
--import Dodge.Base
|
|
import Dodge.SoundLogic
|
|
import Color
|
|
import Justify
|
|
import LensHelp
|
|
import Sound.Data
|
|
import ListHelp (safeUncons,safeHead)
|
|
|
|
import Data.Char
|
|
import Data.Maybe
|
|
import Data.Foldable
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Text as T
|
|
--import Text.Read
|
|
|
|
quitCommand :: TerminalCommand
|
|
quitCommand = TerminalCommand
|
|
{ _tcString = "QUIT"
|
|
, _tcAlias = ["Q","EXIT","X","SHUTDOWN",""]
|
|
, _tcHelp = "DISCONNECTS THE TERMINAL."
|
|
, _tcEffect = \_ _ -> NoArguments [TerminalLineEffect 0 disconnectTerminal]
|
|
}
|
|
disconnectTerminal :: Terminal -> World -> World
|
|
disconnectTerminal tm w = w
|
|
& terminals . ix (_tmID tm) . tmStatus .~ TerminalOff
|
|
& exitTerminalSubInv
|
|
& terminals . ix (_tmID tm) . tmFutureLines .~
|
|
[ TerminalLineTerminalEffect 0 (tmDisplayedLines .~ []) ]
|
|
|
|
exitTerminalSubInv :: World -> World
|
|
exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
|
|
Just _ -> w & hud . hudElement . subInventory .~ NoSubInventory
|
|
_ -> w
|
|
|
|
damageCodeCommand :: TerminalCommand
|
|
damageCodeCommand = TerminalCommand
|
|
{ _tcString = "DAMAGECODE"
|
|
, _tcAlias = ["DCODE","DC"]
|
|
, _tcHelp = "DISPLAYS THE SHAPE AND COLOR ASSOCIATED WITH A GIVEN DAMAGE TYPE."
|
|
, _tcEffect = \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding
|
|
}
|
|
getDamageCoding :: World -> M.Map String [TerminalLine]
|
|
getDamageCoding = decodedtmap . _sensorCoding . _genParams
|
|
|
|
decodedtmap :: M.Map DamageType (PaletteColor,DecorationShape) -> M.Map String [TerminalLine]
|
|
decodedtmap = M.mapKeys show . M.map ((:[]) . makeTermLine . show)
|
|
|
|
sensorCommand :: TerminalCommand
|
|
sensorCommand = TerminalCommand
|
|
{ _tcString = "SENSOR"
|
|
, _tcAlias = ["SEN"]
|
|
, _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR."
|
|
, _tcEffect = \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm
|
|
}
|
|
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 toUpper . show . f)
|
|
(w ^? machines . ix (_tmMachineID tm) . mcSensor)
|
|
|
|
toggleCommand :: TerminalCommand
|
|
toggleCommand = TerminalCommand
|
|
{ _tcString = "TOGGLE"
|
|
, _tcAlias = ["TOG"]
|
|
, _tcHelp = "PERFORMS A REVERSABLE EFFECT."
|
|
, _tcEffect = \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm)
|
|
}
|
|
togglesToEffects :: Terminal -> M.Map String [TerminalLine]
|
|
togglesToEffects = fmap f . _tmToggles
|
|
where
|
|
f tt = [TerminalLineEffect 0 $ \_ -> triggers . ix (_ttTriggerID tt) %~ not]
|
|
|
|
helpCommand :: TerminalCommand
|
|
helpCommand = TerminalCommand
|
|
{ _tcString = "HELP"
|
|
, _tcAlias = ["H","MAN"]
|
|
, _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND."
|
|
, _tcEffect = \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]
|
|
)
|
|
getCommands :: Terminal -> [TerminalCommand]
|
|
getCommands tm = _tmScrollCommands tm ++ _tmWriteCommands tm
|
|
|
|
infoClearInput :: Terminal -> [TerminalLine] -> World -> World
|
|
infoClearInput tm tls = terminals . ix (_tmID tm) %~
|
|
( (tmInput .~ TerminalInput T.empty True (0,0))
|
|
. (tmFutureLines ++.~ tls)
|
|
)
|
|
|
|
argumentHelp :: TerminalCommand -> Terminal -> World -> (String,Maybe [String])
|
|
argumentHelp tc tm w = case _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) )
|
|
|
|
makeTermPara :: String -> [TerminalLine]
|
|
makeTermPara = map makeTermLine . makeParagraph 60
|
|
|
|
makeColorTermPara :: Color -> String -> [TerminalLine]
|
|
makeColorTermPara col = map (makeColorTermLine col) . makeParagraph 60
|
|
|
|
makeColorTermLine :: Color -> String -> TerminalLine
|
|
makeColorTermLine col str = TerminalLineDisplay 0 $ const (str,col)
|
|
|
|
makeTermLine :: String -> TerminalLine
|
|
makeTermLine = makeColorTermLine termTextColor
|
|
|
|
termTextColor :: Color
|
|
termTextColor = greyN 0.9
|
|
|
|
termSoundLine :: SoundID -> TerminalLine
|
|
termSoundLine sid = TerminalLineEffect 0 termsound
|
|
where
|
|
termsound tm w = soundStart TerminalSound tpos sid Nothing w
|
|
where
|
|
tpos = fromMaybe 0 $ w ^? buttons . ix (_tmButtonID tm) . btPos
|
|
|
|
infoCommand :: String -> TerminalCommand
|
|
infoCommand str = TerminalCommand
|
|
{ _tcString = "INFORMATION"
|
|
, _tcAlias = ["INFO","I"]
|
|
, _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL."
|
|
, _tcEffect = \_ _ -> NoArguments (makeTermPara str)
|
|
}
|
|
|
|
commandsCommand :: TerminalCommand
|
|
commandsCommand = TerminalCommand
|
|
{ _tcString = "COMMANDS"
|
|
, _tcAlias = ["COMMAND","COM"]
|
|
, _tcHelp = "DISPLAYS AVAILABLE COMMANDS."
|
|
, _tcEffect = \tm _ -> NoArguments
|
|
( makeTermLine "AVAILABLE COMMANDS:"
|
|
: makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm))
|
|
)
|
|
}
|
|
|
|
commandColor :: Color
|
|
commandColor = yellow
|
|
|
|
singleCommand :: [String] -> String -> [String] -> String -> (World -> World) -> TerminalCommand
|
|
singleCommand followingLines command aliases htext eff = TerminalCommand
|
|
{_tcString = command
|
|
,_tcAlias = aliases
|
|
,_tcHelp = htext
|
|
,_tcEffect = \_ _ -> NoArguments $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines
|
|
}
|
|
|
|
guardDisconnected :: Terminal -> World -> World -> World
|
|
guardDisconnected tm w w' = case _tmStatus tm of
|
|
TerminalOff -> w
|
|
TerminalBusy -> w
|
|
TerminalReady -> w'
|
|
|
|
doTerminalEffectLB :: Terminal -> World -> World
|
|
doTerminalEffectLB tm w = guardDisconnected tm w $ fromMaybe w $ do
|
|
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText
|
|
if null (words s)
|
|
then Just $ defocusTerminalInput w
|
|
else return $ terminalReturnEffect tm w
|
|
|
|
terminalReturnEffect :: Terminal -> World -> World
|
|
terminalReturnEffect tm w = guardDisconnected tm w $ fromMaybe w $ do
|
|
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText
|
|
return $ runTerminalString s tm $ w
|
|
& terminals . ix (_tmID tm) . tmFutureLines .~ [makeTermLine ('>':s)]
|
|
|
|
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 _tcEffect command tm w of
|
|
NoArguments tls -> Just tls
|
|
OneArgument argtype m -> Just $ fromMaybe [errline $ "^ INVALID ARGUMENT: EXPECTS "++ argtype]
|
|
$ safeHead args >>= (m M.!?)
|
|
where
|
|
errline = makeColorTermLine red
|
|
|
|
runTerminalString :: String -> Terminal -> World -> World
|
|
runTerminalString s tm w = w & terminals . ix (_tmID tm) %~
|
|
( (tmInput .~ TerminalInput T.empty True (0,0))
|
|
. (tmFutureLines ++.~ commandFutureLines s tm w)
|
|
. (tmCommandHistory %~ take 10 . (s:))
|
|
)
|
|
|
|
defocusTerminalInput :: World -> World
|
|
defocusTerminalInput w = fromMaybe w $ do
|
|
tmid <- w ^? hud . hudElement . subInventory . termID
|
|
return $ w & terminals . ix tmid . tmInput . tiFocus %~ const False
|
|
|
|
doCommandInstant :: String -> Terminal -> World -> World
|
|
doCommandInstant arg tm w = doLineEffectsInstant tm w $ commandFutureLines arg tm w
|
|
|
|
-- doesn't do internal terminal effects
|
|
doLineEffectsInstant :: Terminal -> World -> [TerminalLine] -> World
|
|
doLineEffectsInstant tm = foldr f
|
|
where
|
|
f tl w = case tl of
|
|
TerminalLineEffect _ eff -> eff tm w
|
|
_ -> w
|
|
|
|
basicTerminal :: Terminal
|
|
basicTerminal = defaultTerminal
|
|
{_tmDisplayedLines = []
|
|
,_tmFutureLines = []
|
|
,_tmMaxLines = 14
|
|
,_tmTitle = "TERMINAL"
|
|
,_tmInput = defaultTerminalInput
|
|
,_tmScrollCommands = [quitCommand]
|
|
,_tmWriteCommands = [helpCommand,commandsCommand]
|
|
,_tmBootProgram = \_ _ -> connectionBlurb
|
|
, _tmDeathEffect = doDeathTriggers
|
|
}
|
|
|
|
lineOutputTerminal :: [TerminalLine] -> Terminal
|
|
lineOutputTerminal tls = defaultTerminal
|
|
{_tmDisplayedLines = []
|
|
,_tmFutureLines = []
|
|
,_tmMaxLines = 14
|
|
,_tmTitle = "TERMINAL"
|
|
,_tmInput = defaultTerminalInput
|
|
,_tmScrollCommands = [quitCommand]
|
|
,_tmWriteCommands = [helpCommand,commandsCommand]
|
|
,_tmBootProgram = \_ _ -> connectionBlurbLines tls
|
|
, _tmDeathEffect = doDeathTriggers
|
|
}
|
|
|
|
doDeathTriggers :: Terminal -> World -> World
|
|
doDeathTriggers tm w = w
|
|
& triggers %~ flip (foldl' $ flip doDeathToggle) xs
|
|
where
|
|
xs = M.elems $ _tmToggles tm
|
|
doDeathToggle :: TerminalToggle -> IM.IntMap Bool -> IM.IntMap Bool
|
|
doDeathToggle (TerminalToggle trid f) = ix trid %~ f
|
|
|
|
connectionBlurb :: [TerminalLine]
|
|
connectionBlurb =
|
|
[termSoundLine computerBeepingS
|
|
,TerminalLineDisplay 0 (const ("CONNECTING",termTextColor))
|
|
,TerminalLineDisplay 10 (const ("...",termTextColor))
|
|
,TerminalLineDisplay 10 (const ("CONNECTED",termTextColor))
|
|
,TerminalLineTerminalEffect 0 (tmStatus .~ TerminalReady)]
|
|
|
|
connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
|
|
connectionBlurbLines tls =
|
|
[termSoundLine computerBeepingS
|
|
,TerminalLineDisplay 0 (const ("CONNECTING",termTextColor))
|
|
,TerminalLineDisplay 10 (const ("...",termTextColor))
|
|
,TerminalLineDisplay 10 (const ("CONNECTED",termTextColor))
|
|
] ++ tls ++
|
|
[TerminalLineTerminalEffect 0 (tmStatus .~ TerminalReady)]
|