Add fix bug in terminal destruction effects

2022-06-07 01:25:36 +01:00
parent 1fe41889fe
commit d42538e3c0
13 changed files with 111 additions and 93 deletions
@@ -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
@@ -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 }
@@ -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
@@ -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
-    Pressed  -> Just . over uvWorld (handlePressedMouseButton thebutton) . updateButtons S.insert
+    Released -> mouseButtons %~ S.delete thebutton
+    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
@@ -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
@@ -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
@@ -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
-bootTerminal mtmid w = case mtmid of
+accessTerminal :: Maybe Int -> World -> World
+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 . tmStatus .~ Connected
+        & terminals . ix tmid . tmInput . tiFocus .~ True
+        & 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
@@ -110,7 +110,7 @@ placeSpotID ps pt w = case pt of
    PutShape    sh          -> placeShape sh p rot w
    PutNothing              -> (0,w)
    PutID i                 -> (i, w)
-    PutWorldUpdate f        -> (0,w & f ps)
+    PutWorldUpdate f        -> (0, w & f ps)
    PutUsingGenParams f     ->  let (w',pt') = f w
                                in placeSpotID ps pt' w'
  where 
@@ -85,17 +85,11 @@ keyCardRoomRunPast keyid rmid = do

 keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
 keyCardAnalyserByDoor keyid = analyserByDoor 
-    (machineAddSound fridgeHumS $ testYouHave (KEYCARD 0))
-  where
-    hic = "SECURITY CHECK"
-    bar = replicate 18 '-'
+    (machineAddSound fridgeHumS $ testYouHave (KEYCARD keyid))

 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 
@@ -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]
-                [helpCommand,commandsCommand]
-                )
+        , putTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand)
            & plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
        ]
    & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
@@ -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
-        [unlockCommand trid,quitCommand] 
-        [helpCommand,infoCommand theinfo,commandsCommand]
-    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."
+    termMessages trpl = basicTerminal & tmScrollCommands .:~ toggleCommand
+        & tmToggles .~ M.fromList 
+            [("DOOR",TerminalToggle (fromJust $ _plMID trpl) (const (const True)))]

 moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2,Float)
 moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
@@ -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 ..."
@@ -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)