Add fix bug in terminal destruction effects
This commit is contained in:
@@ -53,6 +53,10 @@ safeHead :: [a] -> Maybe a
|
|||||||
safeHead (x:_) = Just x
|
safeHead (x:_) = Just x
|
||||||
safeHead _ = Nothing
|
safeHead _ = Nothing
|
||||||
|
|
||||||
|
safeUncons :: [a] -> Maybe (a,[a])
|
||||||
|
safeUncons (x:xs) = Just (x,xs)
|
||||||
|
safeUncons _ = Nothing
|
||||||
|
|
||||||
errorHead :: String -> [a] -> a
|
errorHead :: String -> [a] -> a
|
||||||
errorHead _ (x:_) = x
|
errorHead _ (x:_) = x
|
||||||
errorHead s [] = error s
|
errorHead s [] = error s
|
||||||
|
|||||||
+7
-7
@@ -416,11 +416,6 @@ data TerminalLine
|
|||||||
{_tlPause :: Int
|
{_tlPause :: Int
|
||||||
,_tlTermEffect :: Terminal -> Terminal
|
,_tlTermEffect :: Terminal -> Terminal
|
||||||
}
|
}
|
||||||
| TerminalLineInput
|
|
||||||
{_tlPause :: Int
|
|
||||||
-- ,_tlScrollCommands :: [TerminalCommand]
|
|
||||||
-- ,_tlWriteCommands :: [TerminalCommand]
|
|
||||||
}
|
|
||||||
| TerminalLineEffect
|
| TerminalLineEffect
|
||||||
{_tlPause :: Int
|
{_tlPause :: Int
|
||||||
,_tlEffect :: Terminal -> World -> World
|
,_tlEffect :: Terminal -> World -> World
|
||||||
@@ -960,6 +955,12 @@ data Terminal = Terminal
|
|||||||
, _tmWriteCommands :: [TerminalCommand]
|
, _tmWriteCommands :: [TerminalCommand]
|
||||||
, _tmDeathEffect :: Terminal -> World -> World
|
, _tmDeathEffect :: Terminal -> World -> World
|
||||||
, _tmStatus :: TerminalStatus
|
, _tmStatus :: TerminalStatus
|
||||||
|
, _tmCommandHistory :: [String]
|
||||||
|
, _tmToggles :: M.Map String TerminalToggle
|
||||||
|
}
|
||||||
|
data TerminalToggle = TerminalToggle
|
||||||
|
{ _ttTriggerID :: Int
|
||||||
|
, _ttDeathEffect :: (World -> Bool) -> (World -> Bool)
|
||||||
}
|
}
|
||||||
data Machine = Machine
|
data Machine = Machine
|
||||||
{ _mcID :: Int
|
{ _mcID :: Int
|
||||||
@@ -1382,10 +1383,9 @@ data TerminalCommand = TerminalCommand
|
|||||||
, _tcHelp :: String
|
, _tcHelp :: String
|
||||||
, _tcArgumentType :: Maybe String
|
, _tcArgumentType :: Maybe String
|
||||||
, _tcArguments :: Terminal -> World -> [String]
|
, _tcArguments :: Terminal -> World -> [String]
|
||||||
, _tcEffect :: [String] -> Terminal -> World -> Either String World
|
, _tcEffect :: [String] -> Terminal -> World -> Either String [TerminalLine]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
---- ROOM DATATYPES
|
---- ROOM DATATYPES
|
||||||
data PSType = PutCrit {_unPutCrit :: Creature}
|
data PSType = PutCrit {_unPutCrit :: Creature}
|
||||||
| PutMachine { _putMachinePoly :: [Point2], _unPutMachine :: Machine }
|
| PutMachine { _putMachinePoly :: [Point2], _unPutMachine :: Machine }
|
||||||
|
|||||||
@@ -258,7 +258,10 @@ defaultTerminal = Terminal
|
|||||||
, _tmWriteCommands = []
|
, _tmWriteCommands = []
|
||||||
, _tmDeathEffect = const id
|
, _tmDeathEffect = const id
|
||||||
, _tmStatus = Disconnected
|
, _tmStatus = Disconnected
|
||||||
|
, _tmCommandHistory = []
|
||||||
|
, _tmToggles = M.empty
|
||||||
}
|
}
|
||||||
|
defaultTerminalInput :: TerminalInput
|
||||||
defaultTerminalInput = TerminalInput
|
defaultTerminalInput = TerminalInput
|
||||||
{ _tiText = T.pack ""
|
{ _tiText = T.pack ""
|
||||||
, _tiFocus = True
|
, _tiFocus = True
|
||||||
|
|||||||
+5
-6
@@ -47,7 +47,7 @@ handleEvent e = case eventPayload e of
|
|||||||
TextInputEvent tev -> handleTextInput (textInputEventText tev)
|
TextInputEvent tev -> handleTextInput (textInputEventText tev)
|
||||||
KeyboardEvent kev -> handleKeyboardEvent kev
|
KeyboardEvent kev -> handleKeyboardEvent kev
|
||||||
MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev
|
MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev
|
||||||
MouseButtonEvent mbev -> return . handleMouseButtonEvent mbev
|
MouseButtonEvent mbev -> return . Just . over uvWorld (handleMouseButtonEvent mbev)
|
||||||
MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev
|
MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev
|
||||||
WindowSizeChangedEvent sev -> handleResizeEvent sev
|
WindowSizeChangedEvent sev -> handleResizeEvent sev
|
||||||
WindowMovedEvent mev -> return . handleWindowMoveEvent mev
|
WindowMovedEvent mev -> return . handleWindowMoveEvent mev
|
||||||
@@ -61,13 +61,12 @@ handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2
|
|||||||
cfig = _config u
|
cfig = _config u
|
||||||
P (V2 x y) = mouseMotionEventPos mmev
|
P (V2 x y) = mouseMotionEventPos mmev
|
||||||
|
|
||||||
handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe
|
handleMouseButtonEvent :: MouseButtonEventData -> World -> World
|
||||||
handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
|
handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
|
||||||
Released -> Just . updateButtons S.delete
|
Released -> mouseButtons %~ S.delete thebutton
|
||||||
Pressed -> Just . over uvWorld (handlePressedMouseButton thebutton) . updateButtons S.insert
|
Pressed -> handlePressedMouseButton thebutton . (mouseButtons %~ S.insert thebutton)
|
||||||
where
|
where
|
||||||
thebutton = mouseButtonEventButton mbev
|
thebutton = mouseButtonEventButton mbev
|
||||||
updateButtons f = uvWorld . mouseButtons %~ f thebutton
|
|
||||||
|
|
||||||
{- | Sets window position in config. -}
|
{- | Sets window position in config. -}
|
||||||
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
|
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
|
||||||
@@ -183,7 +182,7 @@ nullCommand = TerminalCommand
|
|||||||
, _tcHelp = ""
|
, _tcHelp = ""
|
||||||
, _tcArgumentType = Nothing
|
, _tcArgumentType = Nothing
|
||||||
, _tcArguments = const (const [])
|
, _tcArguments = const (const [])
|
||||||
, _tcEffect = const $ \_ w -> Right w
|
, _tcEffect = \_ _ _ -> Right []
|
||||||
}
|
}
|
||||||
|
|
||||||
scrollRBOption :: Float -> World -> World
|
scrollRBOption :: Float -> World -> World
|
||||||
|
|||||||
@@ -41,7 +41,7 @@ initialWorld = defaultWorld
|
|||||||
}
|
}
|
||||||
|
|
||||||
testStringInit :: World -> [String]
|
testStringInit :: World -> [String]
|
||||||
testStringInit = const []
|
testStringInit = const [] -- map (show . _mcTermMID) . IM.elems . _machines
|
||||||
--testStringInit = (:[]) . show . _testFloat
|
--testStringInit = (:[]) . show . _testFloat
|
||||||
--testStringInit = map (concatMap $ \(_,ct,_,_) -> show ct) . invertListInvMult . yourInv
|
--testStringInit = map (concatMap $ \(_,ct,_,_) -> show ct) . invertListInvMult . yourInv
|
||||||
--testStringInit w = fmap (show . _crHammerPosition) . IM.elems $ _creatures w
|
--testStringInit w = fmap (show . _crHammerPosition) . IM.elems $ _creatures w
|
||||||
|
|||||||
@@ -48,7 +48,7 @@ analyser
|
|||||||
analyser upf pslight psmc = extTrigLitPos pslight $ \tp ->
|
analyser upf pslight psmc = extTrigLitPos pslight $ \tp ->
|
||||||
Just $ plSpot .~ psmc $ putTerminal' aquamarine tparams (termupdate tp)
|
Just $ plSpot .~ psmc $ putTerminal' aquamarine tparams (termupdate tp)
|
||||||
where
|
where
|
||||||
tparams = defaultTermParams & tmScrollCommands .:~ sensorCommand
|
tparams = basicTerminal & tmScrollCommands .:~ sensorCommand
|
||||||
termupdate tp _ mc = upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
|
termupdate tp _ mc = upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
|
||||||
|
|
||||||
analyserTest :: (World -> Bool) -> Machine -> World -> World
|
analyserTest :: (World -> Bool) -> Machine -> World -> World
|
||||||
|
|||||||
@@ -31,9 +31,9 @@ putTerminal'' mc tm mcf = ps0PushPS (PutTerminal tm)
|
|||||||
$ \tmpl -> Just $ ps0PushPS (PutButton termButton)
|
$ \tmpl -> Just $ ps0PushPS (PutButton termButton)
|
||||||
$ \btpl -> Just $ pt0 (PutMachine (reverse $ square 10)
|
$ \btpl -> Just $ pt0 (PutMachine (reverse $ square 10)
|
||||||
(mc & mcUpdate .~ machineAddSound fridgeHumS (mcf (fromJust $ _plMID btpl))
|
(mc & mcUpdate .~ machineAddSound fridgeHumS (mcf (fromJust $ _plMID btpl))
|
||||||
& mcDeath %~ (\fd mc' -> mcKillTerm mc . (buttons . at (fromJust (_plMID btpl)) .~ Nothing) . fd mc')
|
& mcDeath %~ (\fd mc' -> mcKillTerm mc' . (buttons . at (fromJust (_plMID btpl)) .~ Nothing) . fd mc')
|
||||||
) )
|
) )
|
||||||
$ \mcpl -> Just $ sps0 $ PutWorldUpdate (const $ setids tmpl btpl mcpl)
|
$ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl)
|
||||||
where
|
where
|
||||||
setids tmpl btpl mcpl w = w
|
setids tmpl btpl mcpl w = w
|
||||||
& terminals . ix tmid . tmButtonID .~ btid
|
& terminals . ix tmid . tmButtonID .~ btid
|
||||||
@@ -77,7 +77,7 @@ termButton = Button
|
|||||||
{ _btPict = const mempty
|
{ _btPict = const mempty
|
||||||
, _btPos = 0
|
, _btPos = 0
|
||||||
, _btRot = 0
|
, _btRot = 0
|
||||||
, _btEvent = bootTerminal . _btTermMID
|
, _btEvent = accessTerminal . _btTermMID
|
||||||
, _btID = 0
|
, _btID = 0
|
||||||
, _btText = "TERMINAL"
|
, _btText = "TERMINAL"
|
||||||
, _btState = BtOff
|
, _btState = BtOff
|
||||||
@@ -104,14 +104,18 @@ terminalShape mc = colorSH col (prismPoly
|
|||||||
where
|
where
|
||||||
col = _mcColor mc
|
col = _mcColor mc
|
||||||
|
|
||||||
bootTerminal :: Maybe Int -> World -> World
|
accessTerminal :: Maybe Int -> World -> World
|
||||||
bootTerminal mtmid w = case mtmid of
|
accessTerminal mtmid w = case mtmid of
|
||||||
Nothing -> w
|
Nothing -> w
|
||||||
Just tmid -> w & hud . hudElement .~ DisplayInventory (DisplayTerminal tmid)
|
Just tmid -> w & hud . hudElement .~ DisplayInventory (DisplayTerminal tmid)
|
||||||
& terminals . ix tmid . tmFutureLines ++.~ _tmProgram tm tm w
|
& terminals . ix tmid . tmInput . tiFocus .~ True
|
||||||
& terminals . ix tmid . tmStatus .~ Connected
|
& terminals . ix tmid %~ tryToBoot
|
||||||
where
|
where
|
||||||
tm = w ^?! terminals . ix tmid
|
tryToBoot tm = case _tmStatus tm of
|
||||||
|
Connected -> tm
|
||||||
|
Disconnected -> tm
|
||||||
|
& tmFutureLines ++.~ _tmProgram tm tm w
|
||||||
|
& tmStatus .~ Connected
|
||||||
|
|
||||||
simpleTermMessage :: [String] -> Terminal
|
simpleTermMessage :: [String] -> Terminal
|
||||||
simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs
|
simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs
|
||||||
|
|||||||
@@ -110,7 +110,7 @@ placeSpotID ps pt w = case pt of
|
|||||||
PutShape sh -> placeShape sh p rot w
|
PutShape sh -> placeShape sh p rot w
|
||||||
PutNothing -> (0,w)
|
PutNothing -> (0,w)
|
||||||
PutID i -> (i, w)
|
PutID i -> (i, w)
|
||||||
PutWorldUpdate f -> (0,w & f ps)
|
PutWorldUpdate f -> (0, w & f ps)
|
||||||
PutUsingGenParams f -> let (w',pt') = f w
|
PutUsingGenParams f -> let (w',pt') = f w
|
||||||
in placeSpotID ps pt' w'
|
in placeSpotID ps pt' w'
|
||||||
where
|
where
|
||||||
|
|||||||
@@ -85,17 +85,11 @@ keyCardRoomRunPast keyid rmid = do
|
|||||||
|
|
||||||
keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
|
keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
|
||||||
keyCardAnalyserByDoor keyid = analyserByDoor
|
keyCardAnalyserByDoor keyid = analyserByDoor
|
||||||
(machineAddSound fridgeHumS $ testYouHave (KEYCARD 0))
|
(machineAddSound fridgeHumS $ testYouHave (KEYCARD keyid))
|
||||||
where
|
|
||||||
hic = "SECURITY CHECK"
|
|
||||||
bar = replicate 18 '-'
|
|
||||||
|
|
||||||
healthAnalyserByDoor :: Int -> Room -> Room
|
healthAnalyserByDoor :: Int -> Room -> Room
|
||||||
healthAnalyserByDoor = analyserByDoor
|
healthAnalyserByDoor = analyserByDoor
|
||||||
(machineAddSound fridgeHumS $ testYourHealth 1100)
|
(machineAddSound fridgeHumS $ testYourHealth 1100)
|
||||||
where
|
|
||||||
hic = "HEALTH INTEGRITY CHECK"
|
|
||||||
bar = replicate (length hic) '-'
|
|
||||||
|
|
||||||
analyserByDoor :: (Machine -> World -> World) -> Int -> Room -> Room
|
analyserByDoor :: (Machine -> World -> World) -> Int -> Room -> Room
|
||||||
analyserByDoor mcf outplid rm = rm
|
analyserByDoor mcf outplid rm = rm
|
||||||
|
|||||||
@@ -83,9 +83,7 @@ sensInsideDoor senseType outplid rm = rm
|
|||||||
thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
|
thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
|
||||||
<> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
|
<> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
|
||||||
<> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80))
|
<> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80))
|
||||||
, putTerminal terminalColor (defaultTermParams & addInputLine [damageCodeCommand,quitCommand]
|
, putTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand)
|
||||||
[helpCommand,commandsCommand]
|
|
||||||
)
|
|
||||||
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
|
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
|
||||||
]
|
]
|
||||||
& rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
|
& rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
|
||||||
|
|||||||
@@ -30,6 +30,7 @@ import Dodge.RandomHelp
|
|||||||
|
|
||||||
--import qualified Data.Set as S
|
--import qualified Data.Set as S
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import qualified Data.Map.Strict as M
|
||||||
--import Data.Char
|
--import Data.Char
|
||||||
--import Data.Tree
|
--import Data.Tree
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
@@ -47,18 +48,14 @@ warningRooms n = do
|
|||||||
|
|
||||||
addWarningTerminal :: Int -> Room -> Room
|
addWarningTerminal :: Int -> Room -> Room
|
||||||
addWarningTerminal outplid = (rmName .++~ "warningTerm-")
|
addWarningTerminal outplid = (rmName .++~ "warningTerm-")
|
||||||
-- & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
|
|
||||||
. (rmOutPmnt .~ [OutPlacement outplace outplid])
|
. (rmOutPmnt .~ [OutPlacement outplace outplid])
|
||||||
where
|
where
|
||||||
outplace = extTrigLitPos
|
outplace = extTrigLitPos
|
||||||
(atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
|
(atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
|
||||||
(Just . set plSpot (rprShift moveToSideFirstOutLink) . putTerminal terminalColor . termMessages)
|
(Just . set plSpot (rprShift moveToSideFirstOutLink) . putTerminal terminalColor . termMessages)
|
||||||
termMessages trid = defaultTermParams & addInputLine
|
termMessages trpl = basicTerminal & tmScrollCommands .:~ toggleCommand
|
||||||
[unlockCommand trid,quitCommand]
|
& tmToggles .~ M.fromList
|
||||||
[helpCommand,infoCommand theinfo,commandsCommand]
|
[("DOOR",TerminalToggle (fromJust $ _plMID trpl) (const (const True)))]
|
||||||
unlockCommand trid = singleCommand ["DOOR OPENED"] "OPEN" ["YES","Y"] "OPEN THE CONNECTED DOOR." (toggledoor trid)
|
|
||||||
toggledoor trid w' = w' & triggers . ix (fromJust $ _plMID trid) .~ const True
|
|
||||||
theinfo = "DOOR CONTROLABLE WITH THE \"OPEN\" COMMAND. THIS TERMINAL CANNOT CLOSE THE DOOR."
|
|
||||||
|
|
||||||
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2,Float)
|
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2,Float)
|
||||||
moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
|
moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
|
||||||
|
|||||||
+70
-47
@@ -10,7 +10,8 @@ import Sound.Data
|
|||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Maybe
|
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 qualified Data.Text as T
|
||||||
import Text.Read
|
import Text.Read
|
||||||
import Data.List (find)
|
import Data.List (find)
|
||||||
@@ -22,7 +23,7 @@ quitCommand = TerminalCommand
|
|||||||
, _tcHelp = "DISCONNECTS THE TERMINAL."
|
, _tcHelp = "DISCONNECTS THE TERMINAL."
|
||||||
, _tcArgumentType = Nothing
|
, _tcArgumentType = Nothing
|
||||||
, _tcArguments = const (const [])
|
, _tcArguments = const (const [])
|
||||||
, _tcEffect = const $ \tm w -> Right $ w & disconnectTerminal tm
|
, _tcEffect = \_ _ _ -> Right [TerminalLineEffect 0 disconnectTerminal]
|
||||||
}
|
}
|
||||||
disconnectTerminal :: Terminal -> World -> World
|
disconnectTerminal :: Terminal -> World -> World
|
||||||
disconnectTerminal tm w = w
|
disconnectTerminal tm w = w
|
||||||
@@ -47,33 +48,46 @@ damageCodeCommand = TerminalCommand
|
|||||||
, _tcEffect = f
|
, _tcEffect = f
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
f args tm w = fromMaybe (Left "") $ do
|
f args _ w = fromMaybe (Left "") $ do
|
||||||
dtype <- safeHead args >>= readMaybe
|
dtype <- safeHead args >>= readMaybe
|
||||||
dinfo <- _sensorCoding (_genParams w) M.!? dtype
|
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
|
||||||
sensorCommand = TerminalCommand
|
sensorCommand = TerminalCommand
|
||||||
{ _tcString = "SENSOR"
|
{ _tcString = "SENSOR"
|
||||||
, _tcAlias = ["SEN"]
|
, _tcAlias = ["SEN"]
|
||||||
, _tcHelp = "ACCESS THE CONNECTED SENSOR"
|
, _tcHelp = "ACCESS THE CONNECTED SENSOR."
|
||||||
, _tcArgumentType = Just "A SENSOR PARAMETER"
|
, _tcArgumentType = Just "A SENSOR PARAMETER"
|
||||||
, _tcArguments = \tm w -> ["BOOL","VALUE"]
|
, _tcArguments = \_ _ -> ["BOOL","VALUE"]
|
||||||
, _tcEffect = effectArgMessage sensf
|
, _tcEffect = effectArgMessage sensf
|
||||||
}
|
}
|
||||||
effectArgMessage :: (String -> Terminal -> World -> Maybe [String])
|
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
|
effectArgMessage f args tm w = maybe (Left "") Right $ do
|
||||||
arg <- safeHead args
|
arg <- safeHead args
|
||||||
strs <- f arg tm w
|
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 :: String -> Terminal -> World -> Maybe [String]
|
||||||
sensf arg tm w = case arg of
|
sensf arg tm w = case arg of
|
||||||
"BOOL" -> Just [show $ w ^? machines . ix (_tmMachineID tm) . mcSensor . sensToggle]
|
"BOOL" -> Just [show $ w ^? machines . ix (_tmMachineID tm) . mcSensor . sensToggle]
|
||||||
_ -> Nothing
|
_ -> 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
|
||||||
helpCommand = TerminalCommand
|
helpCommand = TerminalCommand
|
||||||
@@ -86,16 +100,15 @@ helpCommand = TerminalCommand
|
|||||||
return $ map _tcString commands
|
return $ map _tcString commands
|
||||||
, _tcEffect = helpf
|
, _tcEffect = helpf
|
||||||
}
|
}
|
||||||
helpf :: [String] -> Terminal -> World -> Either String World
|
helpf :: [String] -> Terminal -> World -> Either String [TerminalLine]
|
||||||
helpf [] tm w = helpf ["HELP"] tm w
|
helpf [] tm w = helpf ["HELP"] tm w
|
||||||
helpf (str:_) tm w = maybe (Left "") Right $ do
|
helpf (str:_) tm w = maybe (Left "") Right $ do
|
||||||
commands <- getCommands tm w
|
commands <- getCommands tm w
|
||||||
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
|
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
|
||||||
return $ w & infoClearInput tm
|
return $
|
||||||
([makeTermLine ("COMMAND:" ++ _tcString command)
|
[makeTermLine ("COMMAND:" ++ _tcString command)
|
||||||
,makeTermLine ("ALIASES:" ++ unwords (_tcAlias command)) ]
|
,makeTermLine ("ALIASES:" ++ unwords (_tcAlias command)) ]
|
||||||
++ makeTermPara (_tcHelp command ++ " " ++ argumentHelp (_tcArgumentType command))
|
++ makeTermPara (_tcHelp command ++ " " ++ argumentHelp (_tcArgumentType command))
|
||||||
)
|
|
||||||
getCommands :: Terminal -> World -> Maybe [TerminalCommand]
|
getCommands :: Terminal -> World -> Maybe [TerminalCommand]
|
||||||
getCommands tm w = do
|
getCommands tm w = do
|
||||||
commands1 <- w ^? terminals . ix (_tmID tm) . tmScrollCommands
|
commands1 <- w ^? terminals . ix (_tmID tm) . tmScrollCommands
|
||||||
@@ -137,8 +150,7 @@ infoCommand str = TerminalCommand
|
|||||||
, _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL."
|
, _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL."
|
||||||
, _tcArgumentType = Nothing
|
, _tcArgumentType = Nothing
|
||||||
, _tcArguments = const (const [])
|
, _tcArguments = const (const [])
|
||||||
, _tcEffect = const $ \tm w -> Right $ w & infoClearInput tm
|
, _tcEffect = \ _ _ _ -> Right ( makeTermPara str)
|
||||||
( makeTermPara str)
|
|
||||||
}
|
}
|
||||||
|
|
||||||
commandsCommand :: TerminalCommand
|
commandsCommand :: TerminalCommand
|
||||||
@@ -148,7 +160,7 @@ commandsCommand = TerminalCommand
|
|||||||
, _tcHelp = "DISPLAYS AVAILABLE COMMANDS."
|
, _tcHelp = "DISPLAYS AVAILABLE COMMANDS."
|
||||||
, _tcArgumentType = Nothing
|
, _tcArgumentType = Nothing
|
||||||
, _tcArguments = const $ const []
|
, _tcArguments = const $ const []
|
||||||
, _tcEffect = \_ tm w -> Right $ w & infoClearInput tm
|
, _tcEffect = \_ tm w -> Right
|
||||||
( makeTermLine "AVAILABLE COMMANDS:"
|
( makeTermLine "AVAILABLE COMMANDS:"
|
||||||
: makeTermPara (unwords (maybe [""] (map _tcString) $ getCommands tm w))
|
: makeTermPara (unwords (maybe [""] (map _tcString) $ getCommands tm w))
|
||||||
)
|
)
|
||||||
@@ -161,10 +173,7 @@ singleCommand followingLines command aliases htext eff = TerminalCommand
|
|||||||
,_tcHelp = htext
|
,_tcHelp = htext
|
||||||
,_tcArgumentType = Nothing
|
,_tcArgumentType = Nothing
|
||||||
, _tcArguments = const $ const []
|
, _tcArguments = const $ const []
|
||||||
,_tcEffect = \_ tm w -> Right $ eff $ w
|
,_tcEffect = \_ _ _ -> Right $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines
|
||||||
& 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 :: Terminal -> World -> World
|
||||||
@@ -176,31 +185,31 @@ doTerminalEffect :: Terminal -> World -> World
|
|||||||
doTerminalEffect tm w = fromMaybe w $ do
|
doTerminalEffect tm w = fromMaybe w $ do
|
||||||
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText
|
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText
|
||||||
return $ doTerminalEffect' s tm $ w
|
return $ doTerminalEffect' s tm $ w
|
||||||
& terminals . ix (_tmID tm) . tmFutureLines
|
& terminals . ix (_tmID tm) . tmFutureLines .~ [makeColorTermLine (greyN 0.9) ('>':s)]
|
||||||
.~ [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' :: String -> Terminal -> World -> World
|
||||||
doTerminalEffect' s tm w = fromMaybe (w & badinput) $ do
|
doTerminalEffect' s tm w = fromMaybe (w & badinput) $ do
|
||||||
commands <- getCommands tm w
|
|
||||||
if null (words s) then Just $ defocusTerminalInput w else do
|
if null (words s) then Just $ defocusTerminalInput w else do
|
||||||
let (str:args) = words s
|
let futlines = commandFutureLines s tm w
|
||||||
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
|
return $ w & terminals . ix (_tmID tm) %~
|
||||||
case _tcEffect command args tm w of
|
( (tmInput .~ TerminalInput T.empty True (0,0))
|
||||||
Right w' -> return w'
|
. (tmFutureLines ++.~ futlines)
|
||||||
Left err -> return $ w & terminals . ix (_tmID tm) %~
|
. (tmCommandHistory %~ take 10 . (s:))
|
||||||
( (tmInput .~ TerminalInput T.empty True (0,0))
|
)
|
||||||
. (tmFutureLines ++.~
|
|
||||||
[makeColorTermLine red
|
|
||||||
("^ INVALID ARGUMENT: EXPECTS "++fromJust (_tcArgumentType command)++ err)
|
|
||||||
]
|
|
||||||
)
|
|
||||||
)
|
|
||||||
where
|
where
|
||||||
badinput = terminals . ix (_tmID tm) %~
|
badinput = terminals . ix (_tmID tm) %~
|
||||||
( (tmInput .~ TerminalInput T.empty True (0,0))
|
( (tmInput .~ TerminalInput T.empty True (0,0))
|
||||||
. (tmFutureLines ++.~ [makeColorTermLine red "^ INVALID INPUT" ]
|
. (tmFutureLines ++.~ [makeColorTermLine red "^ INVALID INPUT" ])
|
||||||
)
|
|
||||||
)
|
)
|
||||||
|
|
||||||
defocusTerminalInput :: World -> World
|
defocusTerminalInput :: World -> World
|
||||||
@@ -208,26 +217,40 @@ defocusTerminalInput w = fromMaybe w $ do
|
|||||||
tmid <- w ^? hud . hudElement . subInventory . termID
|
tmid <- w ^? hud . hudElement . subInventory . termID
|
||||||
return $ w & terminals . ix tmid . tmInput . tiFocus %~ const False
|
return $ w & terminals . ix tmid . tmInput . tiFocus %~ const False
|
||||||
|
|
||||||
addInputLine :: [TerminalCommand] -> [TerminalCommand] -> Terminal -> Terminal
|
doCommandInstant :: String -> Terminal -> World -> World
|
||||||
addInputLine searchablecommands hiddencommands =
|
doCommandInstant arg tm w = doLineEffectsInstant tm w $ commandFutureLines arg tm w
|
||||||
(tmProgram %~ \f t w -> f t w ++ [TerminalLineInput 0])
|
|
||||||
. (tmScrollCommands .~ searchablecommands)
|
|
||||||
. (tmWriteCommands .~ hiddencommands)
|
|
||||||
|
|
||||||
defaultTermParams :: Terminal
|
-- doesn't do internal terminal effects
|
||||||
defaultTermParams = defaultTerminal
|
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 = []
|
{_tmDisplayedLines = []
|
||||||
,_tmFutureLines = []
|
,_tmFutureLines = []
|
||||||
,_tmMaxLines = 14
|
,_tmMaxLines = 14
|
||||||
,_tmTitle = "TERMINAL"
|
,_tmTitle = "TERMINAL"
|
||||||
,_tmInput = defaultTerminalInput
|
,_tmInput = defaultTerminalInput
|
||||||
,_tmScrollCommands = []
|
,_tmScrollCommands = [quitCommand]
|
||||||
,_tmWriteCommands = [helpCommand,commandsCommand]
|
,_tmWriteCommands = [helpCommand,commandsCommand]
|
||||||
,_tmProgram = \_ _ -> termSoundLine computerBeepingS
|
,_tmProgram = \_ _ -> termSoundLine computerBeepingS
|
||||||
: TerminalLineTerminalEffect 0 (tmStatus .~ Connected)
|
: TerminalLineTerminalEffect 0 (tmStatus .~ Connected)
|
||||||
: map makeTermLine connectionBlurb
|
: 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 :: [String]
|
||||||
connectionBlurb =
|
connectionBlurb =
|
||||||
["CONNECTING ..."
|
["CONNECTING ..."
|
||||||
|
|||||||
+1
-5
@@ -20,7 +20,7 @@ import Sound.Data
|
|||||||
import Geometry
|
import Geometry
|
||||||
import LensHelp
|
import LensHelp
|
||||||
|
|
||||||
import qualified Data.Text as T
|
--import qualified Data.Text as T
|
||||||
--import System.Random
|
--import System.Random
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
@@ -113,10 +113,6 @@ tmUpdate tm w = case w ^? terminals . ix (_tmID tm) . tmFutureLines . ix 0 of
|
|||||||
Just (TerminalLineTerminalEffect _ eff) -> w
|
Just (TerminalLineTerminalEffect _ eff) -> w
|
||||||
& pointTermParams . tmFutureLines %~ tail
|
& pointTermParams . tmFutureLines %~ tail
|
||||||
& pointTermParams %~ eff
|
& pointTermParams %~ eff
|
||||||
Just (TerminalLineInput _) -> w
|
|
||||||
& pointTermParams %~
|
|
||||||
( ( tmFutureLines %~ tail )
|
|
||||||
. ( tmInput .~ TerminalInput T.empty True (0,0)) )
|
|
||||||
where
|
where
|
||||||
pointTermParams = terminals . ix (_tmID tm)
|
pointTermParams = terminals . ix (_tmID tm)
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user