236 lines
8.6 KiB
Haskell
236 lines
8.6 KiB
Haskell
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 Data.Char
|
|
import Data.Maybe
|
|
import qualified Data.Map as M
|
|
import qualified Data.Text as T
|
|
import Text.Read
|
|
import Data.List (find)
|
|
|
|
quitCommand :: TerminalCommand
|
|
quitCommand = TerminalCommand
|
|
{ _tcString = "QUIT"
|
|
, _tcAlias = ["Q","EXIT","X","SHUTDOWN",""]
|
|
, _tcHelp = "DISCONNECTS THE TERMINAL."
|
|
, _tcArgumentType = Nothing
|
|
, _tcArguments = const (const [])
|
|
, _tcEffect = const $ \tm w -> Right $ w & disconnectTerminal tm
|
|
}
|
|
disconnectTerminal :: Terminal -> World -> World
|
|
disconnectTerminal tm w = w
|
|
& terminals . ix (_tmID tm) . tmStatus .~ Disconnected
|
|
& 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."
|
|
, _tcArgumentType = Just "A DAMAGE TYPE"
|
|
, _tcArguments = \_ -> map (map toUpper . show) . M.keys . _sensorCoding . _genParams
|
|
, _tcEffect = f
|
|
}
|
|
where
|
|
f args tm w = fromMaybe (Left "") $ do
|
|
dtype <- safeHead args >>= readMaybe
|
|
dinfo <- _sensorCoding (_genParams w) M.!? dtype
|
|
return $ Right $ w & infoClearInput tm [makeTermLine $ show (fst dinfo) ++ " " ++ show (snd dinfo)]
|
|
|
|
sensorCommand :: TerminalCommand
|
|
sensorCommand = TerminalCommand
|
|
{ _tcString = "SENSOR"
|
|
, _tcAlias = ["SEN"]
|
|
, _tcHelp = "ACCESS THE CONNECTED SENSOR"
|
|
, _tcArgumentType = Just "A SENSOR PARAMETER"
|
|
, _tcArguments = \tm w -> ["BOOL","VALUE"]
|
|
, _tcEffect = effectArgMessage sensf
|
|
}
|
|
effectArgMessage :: (String -> Terminal -> World -> Maybe [String])
|
|
-> [String] -> Terminal -> World -> Either String World
|
|
effectArgMessage f args tm w = maybe (Left "") Right $ do
|
|
arg <- safeHead args
|
|
strs <- f arg tm w
|
|
return $ w & terminals . ix (_tmID tm) . tmFutureLines ++.~ map makeTermLine strs
|
|
|
|
sensf :: String -> Terminal -> World -> Maybe [String]
|
|
sensf arg tm w = case arg of
|
|
"BOOL" -> Just [show $ w ^? machines . ix (_tmMachineID tm) . mcSensor . sensToggle]
|
|
_ -> Nothing
|
|
|
|
|
|
|
|
helpCommand :: TerminalCommand
|
|
helpCommand = TerminalCommand
|
|
{ _tcString = "HELP"
|
|
, _tcAlias = ["H","MAN"]
|
|
, _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND. TO DISPLAY AVAILABLE COMMANDS USE \"COMMANDS\"."
|
|
, _tcArgumentType = Just "AN AVAILABLE COMMAND"
|
|
, _tcArguments = \tm w -> fromMaybe [] $ do
|
|
commands <- getCommands tm w
|
|
return $ map _tcString commands
|
|
, _tcEffect = helpf
|
|
}
|
|
helpf :: [String] -> Terminal -> World -> Either String World
|
|
helpf [] tm w = helpf ["HELP"] tm w
|
|
helpf (str:_) tm w = maybe (Left "") Right $ do
|
|
commands <- getCommands tm w
|
|
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
|
|
return $ w & infoClearInput tm
|
|
([makeTermLine ("COMMAND:" ++ _tcString command)
|
|
,makeTermLine ("ALIASES:" ++ unwords (_tcAlias command)) ]
|
|
++ makeTermPara (_tcHelp command ++ " " ++ argumentHelp (_tcArgumentType command))
|
|
)
|
|
getCommands :: Terminal -> World -> Maybe [TerminalCommand]
|
|
getCommands tm w = do
|
|
commands1 <- w ^? terminals . ix (_tmID tm) . tmScrollCommands
|
|
commands2 <- w ^? terminals . ix (_tmID tm) . tmWriteCommands
|
|
return $ commands1 ++ commands2
|
|
|
|
infoClearInput :: Terminal -> [TerminalLine] -> World -> World
|
|
infoClearInput tm tls = terminals . ix (_tmID tm) %~
|
|
( (tmInput .~ TerminalInput T.empty True (0,0))
|
|
. (tmFutureLines ++.~ tls
|
|
)
|
|
)
|
|
|
|
argumentHelp :: Maybe String -> String
|
|
argumentHelp mstr = case mstr of
|
|
Nothing -> "ANY ARGUMENTS PROVIDED TO THIS COMMAND ARE IGNORED."
|
|
Just str -> "EXPECTS " ++ str ++ " AS ARGUMENT."
|
|
|
|
makeTermPara :: String -> [TerminalLine]
|
|
makeTermPara = map makeTermLine . makeParagraph 60
|
|
|
|
makeColorTermLine :: Color -> String -> TerminalLine
|
|
makeColorTermLine col str = TerminalLineDisplay 0 $ const (str,col)
|
|
|
|
makeTermLine :: String -> TerminalLine
|
|
makeTermLine = makeColorTermLine white
|
|
|
|
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."
|
|
, _tcArgumentType = Nothing
|
|
, _tcArguments = const (const [])
|
|
, _tcEffect = const $ \tm w -> Right $ w & infoClearInput tm
|
|
( makeTermPara str)
|
|
}
|
|
|
|
commandsCommand :: TerminalCommand
|
|
commandsCommand = TerminalCommand
|
|
{ _tcString = "COMMANDS"
|
|
, _tcAlias = ["COMMAND","COM"]
|
|
, _tcHelp = "DISPLAYS AVAILABLE COMMANDS."
|
|
, _tcArgumentType = Nothing
|
|
, _tcArguments = const $ const []
|
|
, _tcEffect = \_ tm w -> Right $ w & infoClearInput tm
|
|
( makeTermLine "AVAILABLE COMMANDS:"
|
|
: makeTermPara (unwords (maybe [""] (map _tcString) $ getCommands tm w))
|
|
)
|
|
}
|
|
|
|
singleCommand :: [String] -> String -> [String] -> String -> (World -> World) -> TerminalCommand
|
|
singleCommand followingLines command aliases htext eff = TerminalCommand
|
|
{_tcString = command
|
|
,_tcAlias = aliases
|
|
,_tcHelp = htext
|
|
,_tcArgumentType = Nothing
|
|
, _tcArguments = const $ const []
|
|
,_tcEffect = \_ tm w -> Right $ eff $ w
|
|
& terminals . ix (_tmID tm) . tmInput . tiText .~ T.pack ""
|
|
& terminals . ix (_tmID tm) . tmFutureLines ++.~ map makeTermLine followingLines
|
|
-- & hud . hudElement . subInventory . onInputLine %~ const False
|
|
}
|
|
|
|
doTerminalEffectLB :: Terminal -> World -> World
|
|
doTerminalEffectLB 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 $ doTerminalEffect tm w
|
|
|
|
doTerminalEffect :: Terminal -> World -> World
|
|
doTerminalEffect tm w = fromMaybe w $ do
|
|
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText
|
|
return $ doTerminalEffect' s tm $ w
|
|
& terminals . ix (_tmID tm) . tmFutureLines
|
|
.~ [makeColorTermLine (greyN 0.9) ('>':s)]
|
|
|
|
|
|
doTerminalEffect' :: String -> Terminal -> World -> World
|
|
doTerminalEffect' s tm w = fromMaybe (w & badinput) $ do
|
|
commands <- getCommands tm w
|
|
if null (words s) then Just $ defocusTerminalInput w else do
|
|
let (str:args) = words s
|
|
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
|
|
case _tcEffect command args tm w of
|
|
Right w' -> return w'
|
|
Left err -> return $ w & terminals . ix (_tmID tm) %~
|
|
( (tmInput .~ TerminalInput T.empty True (0,0))
|
|
. (tmFutureLines ++.~
|
|
[makeColorTermLine red
|
|
("^ INVALID ARGUMENT: EXPECTS "++fromJust (_tcArgumentType command)++ err)
|
|
]
|
|
)
|
|
)
|
|
where
|
|
badinput = terminals . ix (_tmID tm) %~
|
|
( (tmInput .~ TerminalInput T.empty True (0,0))
|
|
. (tmFutureLines ++.~ [makeColorTermLine red "^ INVALID INPUT" ]
|
|
)
|
|
)
|
|
|
|
defocusTerminalInput :: World -> World
|
|
defocusTerminalInput w = fromMaybe w $ do
|
|
tmid <- w ^? hud . hudElement . subInventory . termID
|
|
return $ w & terminals . ix tmid . tmInput . tiFocus %~ const False
|
|
|
|
addInputLine :: [TerminalCommand] -> [TerminalCommand] -> Terminal -> Terminal
|
|
addInputLine searchablecommands hiddencommands =
|
|
(tmProgram %~ \f t w -> f t w ++ [TerminalLineInput 0])
|
|
. (tmScrollCommands .~ searchablecommands)
|
|
. (tmWriteCommands .~ hiddencommands)
|
|
|
|
defaultTermParams :: Terminal
|
|
defaultTermParams = defaultTerminal
|
|
{_tmDisplayedLines = []
|
|
,_tmFutureLines = []
|
|
,_tmMaxLines = 14
|
|
,_tmTitle = "TERMINAL"
|
|
,_tmInput = defaultTerminalInput
|
|
,_tmScrollCommands = []
|
|
,_tmWriteCommands = [helpCommand,commandsCommand]
|
|
,_tmProgram = \_ _ -> termSoundLine computerBeepingS
|
|
: TerminalLineTerminalEffect 0 (tmStatus .~ Connected)
|
|
: map makeTermLine connectionBlurb
|
|
}
|
|
|
|
connectionBlurb :: [String]
|
|
connectionBlurb =
|
|
["CONNECTING ..."
|
|
,"COMPLETE"
|
|
]
|