Add fix bug in terminal destruction effects
This commit is contained in:
+70
-47
@@ -10,7 +10,8 @@ import Sound.Data
|
||||
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.Text as T
|
||||
import Text.Read
|
||||
import Data.List (find)
|
||||
@@ -22,7 +23,7 @@ quitCommand = TerminalCommand
|
||||
, _tcHelp = "DISCONNECTS THE TERMINAL."
|
||||
, _tcArgumentType = Nothing
|
||||
, _tcArguments = const (const [])
|
||||
, _tcEffect = const $ \tm w -> Right $ w & disconnectTerminal tm
|
||||
, _tcEffect = \_ _ _ -> Right [TerminalLineEffect 0 disconnectTerminal]
|
||||
}
|
||||
disconnectTerminal :: Terminal -> World -> World
|
||||
disconnectTerminal tm w = w
|
||||
@@ -47,33 +48,46 @@ damageCodeCommand = TerminalCommand
|
||||
, _tcEffect = f
|
||||
}
|
||||
where
|
||||
f args tm w = fromMaybe (Left "") $ do
|
||||
f args _ 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)]
|
||||
return $ Right [makeTermLine $ show (fst dinfo) ++ " " ++ show (snd dinfo)]
|
||||
|
||||
sensorCommand :: TerminalCommand
|
||||
sensorCommand = TerminalCommand
|
||||
{ _tcString = "SENSOR"
|
||||
, _tcAlias = ["SEN"]
|
||||
, _tcHelp = "ACCESS THE CONNECTED SENSOR"
|
||||
, _tcHelp = "ACCESS THE CONNECTED SENSOR."
|
||||
, _tcArgumentType = Just "A SENSOR PARAMETER"
|
||||
, _tcArguments = \tm w -> ["BOOL","VALUE"]
|
||||
, _tcArguments = \_ _ -> ["BOOL","VALUE"]
|
||||
, _tcEffect = effectArgMessage sensf
|
||||
}
|
||||
effectArgMessage :: (String -> Terminal -> World -> Maybe [String])
|
||||
-> [String] -> Terminal -> World -> Either String World
|
||||
-> [String] -> Terminal -> World -> Either String [TerminalLine]
|
||||
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
|
||||
return $ 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
|
||||
|
||||
|
||||
toggleCommand :: TerminalCommand
|
||||
toggleCommand = TerminalCommand
|
||||
{ _tcString = "TOGGLE"
|
||||
, _tcAlias = ["TOG"]
|
||||
, _tcHelp = "PERFORMS A REVERSABLE EFFECT."
|
||||
, _tcArgumentType = Just "AN ATTACHED OBJECT"
|
||||
, _tcArguments = \tm _ -> M.keys $ _tmToggles tm
|
||||
, _tcEffect = togglef
|
||||
}
|
||||
togglef :: [String] -> Terminal -> World -> Either String [TerminalLine]
|
||||
togglef [] _ _ = Left ""
|
||||
togglef (s:_) tm _ = fromMaybe (Left "") $ do
|
||||
TerminalToggle trid _ <- M.lookup s $ _tmToggles tm
|
||||
Just $ Right [TerminalLineEffect 0 $ \_ -> triggers . ix trid %~ fmap not]
|
||||
|
||||
helpCommand :: TerminalCommand
|
||||
helpCommand = TerminalCommand
|
||||
@@ -86,16 +100,15 @@ helpCommand = TerminalCommand
|
||||
return $ map _tcString commands
|
||||
, _tcEffect = helpf
|
||||
}
|
||||
helpf :: [String] -> Terminal -> World -> Either String World
|
||||
helpf :: [String] -> Terminal -> World -> Either String [TerminalLine]
|
||||
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))
|
||||
)
|
||||
return $
|
||||
[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
|
||||
@@ -137,8 +150,7 @@ infoCommand str = TerminalCommand
|
||||
, _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL."
|
||||
, _tcArgumentType = Nothing
|
||||
, _tcArguments = const (const [])
|
||||
, _tcEffect = const $ \tm w -> Right $ w & infoClearInput tm
|
||||
( makeTermPara str)
|
||||
, _tcEffect = \ _ _ _ -> Right ( makeTermPara str)
|
||||
}
|
||||
|
||||
commandsCommand :: TerminalCommand
|
||||
@@ -148,7 +160,7 @@ commandsCommand = TerminalCommand
|
||||
, _tcHelp = "DISPLAYS AVAILABLE COMMANDS."
|
||||
, _tcArgumentType = Nothing
|
||||
, _tcArguments = const $ const []
|
||||
, _tcEffect = \_ tm w -> Right $ w & infoClearInput tm
|
||||
, _tcEffect = \_ tm w -> Right
|
||||
( makeTermLine "AVAILABLE COMMANDS:"
|
||||
: makeTermPara (unwords (maybe [""] (map _tcString) $ getCommands tm w))
|
||||
)
|
||||
@@ -161,10 +173,7 @@ singleCommand followingLines command aliases htext eff = TerminalCommand
|
||||
,_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
|
||||
,_tcEffect = \_ _ _ -> Right $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines
|
||||
}
|
||||
|
||||
doTerminalEffectLB :: Terminal -> World -> World
|
||||
@@ -176,31 +185,31 @@ 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)]
|
||||
& terminals . ix (_tmID tm) . tmFutureLines .~ [makeColorTermLine (greyN 0.9) ('>':s)]
|
||||
|
||||
commandFutureLines :: String -> Terminal -> World -> [TerminalLine]
|
||||
commandFutureLines s tm w = fromMaybe [] $ do
|
||||
commands <- getCommands tm w
|
||||
(str,args) <- safeUncons $ words s
|
||||
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
|
||||
case _tcEffect command args tm w of
|
||||
Right tls -> Just tls
|
||||
Left err -> Just [makeColorTermLine red
|
||||
("^ INVALID ARGUMENT: EXPECTS "++fromJust (_tcArgumentType command)++ err) ]
|
||||
|
||||
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)
|
||||
]
|
||||
)
|
||||
)
|
||||
let futlines = commandFutureLines s tm w
|
||||
return $ w & terminals . ix (_tmID tm) %~
|
||||
( (tmInput .~ TerminalInput T.empty True (0,0))
|
||||
. (tmFutureLines ++.~ futlines)
|
||||
. (tmCommandHistory %~ take 10 . (s:))
|
||||
)
|
||||
where
|
||||
badinput = terminals . ix (_tmID tm) %~
|
||||
( (tmInput .~ TerminalInput T.empty True (0,0))
|
||||
. (tmFutureLines ++.~ [makeColorTermLine red "^ INVALID INPUT" ]
|
||||
)
|
||||
. (tmFutureLines ++.~ [makeColorTermLine red "^ INVALID INPUT" ])
|
||||
)
|
||||
|
||||
defocusTerminalInput :: World -> World
|
||||
@@ -208,26 +217,40 @@ 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)
|
||||
doCommandInstant :: String -> Terminal -> World -> World
|
||||
doCommandInstant arg tm w = doLineEffectsInstant tm w $ commandFutureLines arg tm w
|
||||
|
||||
defaultTermParams :: Terminal
|
||||
defaultTermParams = defaultTerminal
|
||||
-- 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 = []
|
||||
,_tmScrollCommands = [quitCommand]
|
||||
,_tmWriteCommands = [helpCommand,commandsCommand]
|
||||
,_tmProgram = \_ _ -> termSoundLine computerBeepingS
|
||||
: TerminalLineTerminalEffect 0 (tmStatus .~ Connected)
|
||||
: map makeTermLine connectionBlurb
|
||||
, _tmDeathEffect = doDeathTriggers
|
||||
}
|
||||
|
||||
doDeathTriggers :: Terminal -> World -> World
|
||||
doDeathTriggers tm w = w
|
||||
& triggers %~ flip (foldr doDeathToggle) xs
|
||||
where
|
||||
xs = M.elems $ _tmToggles tm
|
||||
doDeathToggle :: TerminalToggle -> IM.IntMap (World -> Bool) -> IM.IntMap (World -> Bool)
|
||||
doDeathToggle (TerminalToggle trid f) = ix trid %~ f
|
||||
|
||||
connectionBlurb :: [String]
|
||||
connectionBlurb =
|
||||
["CONNECTING ..."
|
||||
|
||||
Reference in New Issue
Block a user