Add fix bug in terminal destruction effects

src/Dodge/Base.hs

@@ -53,6 +53,10 @@ safeHead :: [a] -> Maybe a
 safeHead (x:_) = Just x
 safeHead _ = Nothing
 
+safeUncons :: [a] -> Maybe (a,[a])
+safeUncons (x:xs) = Just (x,xs)
+safeUncons _ = Nothing
+
 errorHead :: String -> [a] -> a
 errorHead _ (x:_) = x
 errorHead s [] = error s

src/Dodge/Data.hs

@@ -416,11 +416,6 @@ data TerminalLine
         {_tlPause :: Int
         ,_tlTermEffect :: Terminal -> Terminal
         }
-    | TerminalLineInput
-        {_tlPause :: Int
---        ,_tlScrollCommands :: [TerminalCommand]
---        ,_tlWriteCommands :: [TerminalCommand]
-        }
     | TerminalLineEffect
         {_tlPause :: Int
         ,_tlEffect :: Terminal -> World -> World
@@ -960,6 +955,12 @@ data Terminal = Terminal
     , _tmWriteCommands  :: [TerminalCommand]
     , _tmDeathEffect    :: Terminal -> World -> World
     , _tmStatus :: TerminalStatus
+    , _tmCommandHistory :: [String]
+    , _tmToggles :: M.Map String TerminalToggle
+    }
+data TerminalToggle = TerminalToggle
+    { _ttTriggerID :: Int
+    , _ttDeathEffect :: (World -> Bool) -> (World -> Bool)
     }
 data Machine = Machine
     { _mcID     :: Int
@@ -1382,10 +1383,9 @@ data TerminalCommand = TerminalCommand
     , _tcHelp   :: String
     , _tcArgumentType :: Maybe String
     , _tcArguments :: Terminal -> World -> [String]
-    , _tcEffect :: [String] -> Terminal -> World -> Either String World
+    , _tcEffect :: [String] -> Terminal -> World -> Either String [TerminalLine]
     }
 
-
 ---- ROOM DATATYPES
 data PSType = PutCrit {_unPutCrit :: Creature}
     | PutMachine { _putMachinePoly :: [Point2], _unPutMachine :: Machine }

src/Dodge/Default.hs

@@ -258,7 +258,10 @@ defaultTerminal = Terminal
     , _tmWriteCommands  = []
     , _tmDeathEffect    = const id
     , _tmStatus = Disconnected
+    , _tmCommandHistory = []
+    , _tmToggles = M.empty
     }
+defaultTerminalInput :: TerminalInput
 defaultTerminalInput = TerminalInput
     { _tiText = T.pack ""
     , _tiFocus = True

src/Dodge/Event.hs

@@ -47,7 +47,7 @@ handleEvent e = case eventPayload e of
     TextInputEvent tev         -> handleTextInput (textInputEventText tev)
     KeyboardEvent kev          -> handleKeyboardEvent kev
     MouseMotionEvent mmev      -> return . handleMouseMotionEvent mmev
-    MouseButtonEvent mbev      -> return . handleMouseButtonEvent mbev
+    MouseButtonEvent mbev      -> return . Just . over uvWorld (handleMouseButtonEvent mbev)
     MouseWheelEvent mwev       -> return . handleMouseWheelEvent mwev
     WindowSizeChangedEvent sev -> handleResizeEvent sev
     WindowMovedEvent mev       -> return . handleWindowMoveEvent mev
@@ -61,13 +61,12 @@ handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2
     cfig = _config u
     P (V2 x y) = mouseMotionEventPos mmev
 
-handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe
+handleMouseButtonEvent :: MouseButtonEventData -> World -> World
 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
     thebutton = mouseButtonEventButton mbev
-    updateButtons f = uvWorld . mouseButtons %~ f thebutton
 
 {- | Sets window position in config. -}
 handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
@@ -183,7 +182,7 @@ nullCommand = TerminalCommand
     , _tcHelp   = ""
     , _tcArgumentType = Nothing
     , _tcArguments  = const (const [])
-    , _tcEffect = const $ \_ w -> Right w
+    , _tcEffect = \_ _ _ -> Right []
     }
 
 scrollRBOption :: Float -> World -> World

src/Dodge/Initialisation.hs

@@ -41,7 +41,7 @@ initialWorld = defaultWorld
     }
 
 testStringInit :: World -> [String]
-testStringInit = const []
+testStringInit = const [] -- map (show . _mcTermMID) . IM.elems . _machines
 --testStringInit = (:[]) . show . _testFloat
 --testStringInit = map (concatMap $ \(_,ct,_,_) -> show ct) . invertListInvMult . yourInv
 --testStringInit w = fmap (show . _crHammerPosition) . IM.elems $ _creatures w

src/Dodge/Placement/Instance/Analyser.hs

@@ -48,7 +48,7 @@ analyser
 analyser upf pslight psmc = extTrigLitPos pslight $ \tp ->
     Just $ plSpot .~ psmc $ putTerminal' aquamarine tparams (termupdate tp)
   where
-    tparams = defaultTermParams & tmScrollCommands .:~ sensorCommand
+    tparams = basicTerminal & tmScrollCommands .:~ sensorCommand
     termupdate tp _ mc = upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
 
 analyserTest :: (World -> Bool) -> Machine -> World -> World

src/Dodge/Placement/Instance/Terminal.hs

@@ -31,9 +31,9 @@ putTerminal'' mc tm mcf = ps0PushPS (PutTerminal tm)
     $ \tmpl -> Just $ ps0PushPS (PutButton termButton)
     $ \btpl -> Just $ pt0 (PutMachine (reverse $ square 10)
         (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
     setids tmpl btpl mcpl w = w
         & terminals . ix tmid . tmButtonID .~ btid
@@ -77,7 +77,7 @@ termButton = Button
     { _btPict = const mempty
     , _btPos = 0
     , _btRot = 0
-    , _btEvent = bootTerminal . _btTermMID
+    , _btEvent = accessTerminal . _btTermMID
     , _btID = 0
     , _btText = "TERMINAL"
     , _btState = BtOff
@@ -104,14 +104,18 @@ terminalShape mc = colorSH col (prismPoly
   where
     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
     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
-        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 strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs

src/Dodge/Room/LasTurret.hs

@@ -85,17 +85,11 @@ keyCardRoomRunPast keyid rmid = do
 
 keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
 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 = analyserByDoor 
     (machineAddSound fridgeHumS $ testYourHealth 1100)
-  where
-    hic = "HEALTH INTEGRITY CHECK"
-    bar = replicate (length hic) '-'
 
 analyserByDoor :: (Machine -> World -> World) -> Int -> Room -> Room
 analyserByDoor mcf outplid rm = rm 

src/Dodge/Room/SensorDoor.hs

@@ -83,9 +83,7 @@ sensInsideDoor senseType outplid rm = rm
             thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
             <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
             <> 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)
         ]
     & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]

src/Dodge/Room/Warning.hs

@@ -30,6 +30,7 @@ import Dodge.RandomHelp
 
 --import qualified Data.Set as S
 import Data.Maybe
+import qualified Data.Map.Strict as M
 --import Data.Char
 --import Data.Tree
 import Control.Monad.State
@@ -47,18 +48,14 @@ warningRooms n = do
 
 addWarningTerminal :: Int -> Room -> Room
 addWarningTerminal outplid = (rmName .++~ "warningTerm-")
-    -- & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
     . (rmOutPmnt .~ [OutPlacement outplace outplid])
   where
     outplace = extTrigLitPos
         (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
         (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 rp rm = case rp ^? rpLinkStatus . rplsChildNum of

src/Dodge/Terminal.hs

@@ -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
+    return $ 
-        ([makeTermLine ("COMMAND:" ++ _tcString command) 
+        [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
+    , _tcEffect = \ _ _ _ -> Right ( makeTermPara str)
-                ( 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 
+    ,_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
@@ -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 
+            & 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' 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
+        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
-            Right w' -> return w'
-            Left err -> return $ w & terminals . ix (_tmID tm) %~
             ( (tmInput .~ TerminalInput T.empty True (0,0))
-                . (tmFutureLines ++.~ 
+            . (tmFutureLines ++.~ futlines)
-                    [makeColorTermLine red
+            . (tmCommandHistory %~ take 10 . (s:))
-                        ("^ 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" ]
+        . (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
+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 = []
     ,_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 ..."

src/Dodge/Update.hs

@@ -20,7 +20,7 @@ import Sound.Data
 import Geometry
 import LensHelp
 
-import qualified Data.Text as T
+--import qualified Data.Text as T
 --import System.Random
 import Data.List
 import Data.Maybe
@@ -113,10 +113,6 @@ tmUpdate tm w = case w ^? terminals . ix (_tmID tm) . tmFutureLines . ix 0 of
     Just (TerminalLineTerminalEffect _ eff) -> w
         & pointTermParams . tmFutureLines %~ tail
         & pointTermParams %~ eff
-    Just (TerminalLineInput _) -> w 
-        & pointTermParams %~
-            ( ( tmFutureLines %~ tail )
-            . ( tmInput .~ TerminalInput T.empty True (0,0)) )
   where
     pointTermParams = terminals . ix (_tmID tm)