From 687bad8610b9a2e82e97bc292959ccb565b0d377 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= <44544735+xsebek@users.noreply.github.com> Date: Mon, 8 Jul 2024 13:43:37 +0200 Subject: [PATCH] Customizable keybindings (#1979) * create a new `SwarmEvent` enumeration * define configuration names (`swarmEvents`) * define default keybindings (`defaultSwarmBindings`) * add `KeyConfig` and `KeyDispatcher`s to `AppState` * load custom bindings from an INI file * migrate key event controller code to use `onEvent` * call `handleKey` with handlers * show the shortcuts in TUI * check for conflicts between parent/child handler (right now `mainHandler` and the rest) * generate the INI file (`keybinding --init`) with commented-out (`;`) settings * allow `brick` version 2.4 to get uppercase keybindings fix --- * Closes #523 * Closes #1962 --- app/Main.hs | 34 + .../Swarm/Game/Achievement/Persistence.hs | 10 +- src/swarm-scenario/Swarm/Constant.hs | 3 + src/swarm-scenario/Swarm/Game/Failure.hs | 2 +- .../Swarm/Game/ResourceLoading.hs | 41 +- src/swarm-tui/Swarm/TUI/Controller.hs | 850 +----------------- .../Swarm/TUI/Controller/EventHandlers.hs | 130 +++ .../TUI/Controller/EventHandlers/Frame.hs | 157 ++++ .../TUI/Controller/EventHandlers/Main.hs | 155 ++++ .../TUI/Controller/EventHandlers/REPL.hs | 69 ++ .../TUI/Controller/EventHandlers/Robot.hs | 150 ++++ .../TUI/Controller/EventHandlers/World.hs | 59 ++ .../Swarm/TUI/Controller/SaveScenario.hs | 118 +++ .../Swarm/TUI/Controller/UpdateUI.hs | 250 ++++++ src/swarm-tui/Swarm/TUI/Controller/Util.hs | 89 +- src/swarm-tui/Swarm/TUI/Model.hs | 109 ++- src/swarm-tui/Swarm/TUI/Model/Achievements.hs | 39 + src/swarm-tui/Swarm/TUI/Model/Event.hs | 236 +++++ src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs | 137 +++ src/swarm-tui/Swarm/TUI/Model/Menu.hs | 4 +- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 49 +- src/swarm-tui/Swarm/TUI/View.hs | 162 ++-- src/swarm-tui/Swarm/TUI/View/Util.hs | 3 +- src/swarm-web/Swarm/Web.hs | 8 +- swarm.cabal | 13 +- test/integration/Main.hs | 11 +- 26 files changed, 1909 insertions(+), 979 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs create mode 100644 src/swarm-tui/Swarm/TUI/Model/Achievements.hs create mode 100644 src/swarm-tui/Swarm/TUI/Model/Event.hs create mode 100644 src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs diff --git a/app/Main.hs b/app/Main.hs index 79c0b505d..dd36cb7f5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,14 +6,18 @@ -- SPDX-License-Identifier: BSD-3-Clause module Main where +import Control.Monad (when) import Data.Foldable qualified +import Data.Text.IO qualified as T import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) import Options.Applicative import Swarm.App (appMain) +import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) import Swarm.Language.Format import Swarm.Language.LSP (lspMain) import Swarm.Language.Parser.Core (LanguageVersion (..)) import Swarm.TUI.Model (AppOpts (..), ColorMode (..)) +import Swarm.TUI.Model.KeyBindings (KeybindingPrint (..), showKeybindings) import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond) import Swarm.Version import Swarm.Web (defaultPort) @@ -30,6 +34,8 @@ commitInfo = case gitInfo of data CLI = Run AppOpts + | -- | Print list of bindings, optionally initializing the INI configuration file. + ListKeybinding Bool KeybindingPrint | Format FormatConfig | LSP | Version @@ -41,6 +47,7 @@ cliParser = [ command "format" (info (Format <$> parseFormat) (progDesc "Format a file")) , command "lsp" (info (pure LSP) (progDesc "Start the LSP")) , command "version" (info (pure Version) (progDesc "Get current and upstream version.")) + , command "keybindings" (info (ListKeybinding <$> initKeybindingConfig <*> printKeyMode <**> helper) (progDesc "List the keybindings")) ] ) <|> Run @@ -73,6 +80,15 @@ cliParser = langVer :: Parser LanguageVersion langVer = flag SwarmLangLatest SwarmLang0_5 (long "v0.5" <> help "Read (& convert) code from Swarm version 0.5") + printKeyMode :: Parser KeybindingPrint + printKeyMode = + flag' IniPrint (long "ini" <> help "Print in INI format") + <|> flag' MarkdownPrint (long "markdown" <> help "Print in Markdown table format") + <|> pure TextPrint + + initKeybindingConfig :: Parser Bool + initKeybindingConfig = switch (short 'i' <> long "init" <> help "Initialise the keybindings configuration file") + parseFormat :: Parser FormatConfig parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper @@ -125,11 +141,29 @@ showVersion = do up <- getNewerReleaseVersion gitInfo either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up +printKeybindings :: Bool -> KeybindingPrint -> IO () +printKeybindings initialize p = do + kb <- showKeybindings p + T.putStrLn kb + (iniExists, ini) <- getSwarmConfigIniFile + when initialize $ do + kbi <- showKeybindings IniPrint + T.writeFile ini kbi + let iniState + | iniExists && initialize = "has been updated" + | iniExists = "is" + | initialize = "has been created" + | otherwise = "can be created (--init)" + putStrLn $ replicate 80 '-' + putStrLn $ "The configuration file " <> iniState <> " at:" + putStrLn ini + main :: IO () main = do cli <- execParser cliInfo case cli of Run opts -> appMain opts + ListKeybinding initialize p -> printKeybindings initialize p Format cfg -> formatSwarmIO cfg LSP -> lspMain Version -> showVersion diff --git a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs index a2bb562d3..a90f7a6ab 100644 --- a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs +++ b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | -- SPDX-License-Identifier: BSD-3-Clause -- Description: Achievements load/save @@ -18,17 +16,11 @@ import Data.Yaml qualified as Y import Swarm.Game.Achievement.Attainment import Swarm.Game.Achievement.Definitions import Swarm.Game.Failure -import Swarm.Game.ResourceLoading (getSwarmXdgDataSubdir) +import Swarm.Game.ResourceLoading (getSwarmAchievementsPath) import Swarm.Util.Effect (forMW) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (()) --- | Get a path to the directory where achievement records are --- stored. If the argument is set to @True@, create the directory if --- it does not exist. -getSwarmAchievementsPath :: Bool -> IO FilePath -getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement" - -- | Load saved info about achievements from XDG data directory. -- Returns a list of attained achievements. loadAchievementsInfo :: diff --git a/src/swarm-scenario/Swarm/Constant.hs b/src/swarm-scenario/Swarm/Constant.hs index 17e7425d3..f0e742e4b 100644 --- a/src/swarm-scenario/Swarm/Constant.hs +++ b/src/swarm-scenario/Swarm/Constant.hs @@ -15,6 +15,9 @@ import Data.Text (Text) -- By convention, all URL constants include trailing slashes -- when applicable. +swarmWebIRC :: Text +swarmWebIRC = "https://web.libera.chat/?channels=#swarm" + -- | The URL for the Swarm repository. swarmRepoUrl :: Text swarmRepoUrl = "https://github.com/swarm-game/swarm/" diff --git a/src/swarm-scenario/Swarm/Game/Failure.hs b/src/swarm-scenario/Swarm/Game/Failure.hs index 409fbe9f9..604cc3c20 100644 --- a/src/swarm-scenario/Swarm/Game/Failure.hs +++ b/src/swarm-scenario/Swarm/Game/Failure.hs @@ -40,7 +40,7 @@ data AssetData = AppAsset | NameGeneration | Entities | Terrain | Recipes | Worl deriving (Eq, Show) -- | Overarching enumeration of various assets we can attempt to load. -data Asset = Achievement | Data AssetData | History | Save +data Asset = Achievement | Data AssetData | History | Keybindings | Save deriving (Eq, Show) -- | Enumeration type to distinguish between directories and files. diff --git a/src/swarm-scenario/Swarm/Game/ResourceLoading.hs b/src/swarm-scenario/Swarm/Game/ResourceLoading.hs index 57d3f44b4..bf4ec0df1 100644 --- a/src/swarm-scenario/Swarm/Game/ResourceLoading.hs +++ b/src/swarm-scenario/Swarm/Game/ResourceLoading.hs @@ -5,7 +5,22 @@ -- Description: Fetching game data -- -- Various utilities related to loading game data files. -module Swarm.Game.ResourceLoading where +module Swarm.Game.ResourceLoading ( + -- * Generic data access + getDataDirSafe, + getDataFileNameSafe, + + -- * Concrete data access + getSwarmConfigIniFile, + getSwarmSavePath, + getSwarmHistoryPath, + getSwarmAchievementsPath, + + -- ** Loading text files + readAppData, + NameGenerator (..), + initNameGenerator, +) where import Control.Algebra (Has) import Control.Effect.Lift (Lift, sendIO) @@ -23,7 +38,7 @@ import Paths_swarm (getDataDir) import Swarm.Game.Failure import Swarm.Util import System.Directory ( - XdgDirectory (XdgData), + XdgDirectory (..), createDirectoryIfMissing, doesDirectoryExist, doesFileExist, @@ -83,17 +98,11 @@ getDataFileNameSafe asset name = do then return fp else throwError $ AssetNotLoaded (Data asset) fp $ DoesNotExist File --- | Get a nice message suggesting to download @data@ directory to 'XdgData'. -dataNotFound :: FilePath -> IO LoadingFailure -dataNotFound f = do - d <- getSwarmXdgDataSubdir False "" - let squotes = squote . T.pack - return $ - CustomMessage $ - T.unlines - [ "Could not find the data: " <> squotes f - , "Try downloading the Swarm 'data' directory to: " <> squotes (d "data") - ] +getSwarmConfigIniFile :: IO (Bool, FilePath) +getSwarmConfigIniFile = do + ini <- ( "config.ini") <$> getXdgDirectory XdgConfig "swarm" + iniExists <- doesFileExist ini + return (iniExists, ini) -- | Get path to swarm data, optionally creating necessary -- directories. This could fail if user has bad permissions @@ -120,6 +129,12 @@ getSwarmSavePath createDirs = getSwarmXdgDataSubdir createDirs "saves" getSwarmHistoryPath :: Bool -> IO FilePath getSwarmHistoryPath createDirs = getSwarmXdgDataFile createDirs "history" +-- | Get a path to the directory where achievement records are +-- stored. If the argument is set to @True@, create the directory if +-- it does not exist. +getSwarmAchievementsPath :: Bool -> IO FilePath +getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement" + -- | Read all the @.txt@ files in the @data/@ directory. readAppData :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 462e7b1d2..c6e4575f8 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -- | @@ -13,12 +12,8 @@ module Swarm.TUI.Controller ( -- ** Handling 'Swarm.TUI.Model.Frame' events runFrameUI, - runFrame, ticksPerFrameCap, - runFrameTicks, runGameTickUI, - runGameTick, - updateUI, -- ** REPL panel runBaseWebCode, @@ -27,72 +22,52 @@ module Swarm.TUI.Controller ( adjReplHistIndex, TimeDir (..), - -- ** World panel - handleWorldEvent, - keyToDir, - scrollView, - adjustTPS, - -- ** Info panel handleInfoPanelEvent, ) where +-- See Note [liftA2 re-export from Prelude] +import Prelude hiding (Applicative (..)) + import Brick hiding (Direction, Location) import Brick.Focus +import Brick.Keybindings qualified as B import Brick.Widgets.Dialog import Brick.Widgets.Edit (Editor, applyEdit, handleEditorEvent) import Brick.Widgets.List (handleListEvent) import Brick.Widgets.List qualified as BL -import Control.Applicative (liftA2, pure) -import Control.Carrier.Lift qualified as Fused -import Control.Carrier.State.Lazy qualified as Fused +import Control.Applicative (pure) import Control.Category ((>>>)) import Control.Lens as Lens -import Control.Lens.Extras as Lens (is) -import Control.Monad (forM_, unless, void, when) +import Control.Monad (unless, void, when) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execState) -import Data.Bits -import Data.Foldable (toList) -import Data.Int (Int32) -import Data.List.Extra (enumerate) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M -import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Set (Set) import Data.Set qualified as S -import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Text.Zipper qualified as TZ import Data.Text.Zipper.Generic.Words qualified as TZ -import Data.Time (getZonedTime) import Data.Vector qualified as V import Graphics.Vty qualified as V -import Linear -import Swarm.Effect (TimeIOC (..)) import Swarm.Game.Achievement.Definitions -import Swarm.Game.Achievement.Persistence -import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend), cancel, continue) +import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend)) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Land -import Swarm.Game.Location import Swarm.Game.ResourceLoading (getSwarmHistoryPath) -import Swarm.Game.Robot import Swarm.Game.Robot.Concrete -import Swarm.Game.Scenario.Status (updateScenarioInfoOnFinish) -import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.ScenarioInfo import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Runtime import Swarm.Game.State.Substate -import Swarm.Game.Step (finishGameTick, gameTick) import Swarm.Language.Capability ( Capability (CGod), constCaps, @@ -104,20 +79,17 @@ import Swarm.Language.Parser.Core (defaultParserConfig) import Swarm.Language.Parser.Lex (reservedWords) import Swarm.Language.Parser.Util (showErrorPos) import Swarm.Language.Pipeline (processParsedTerm', processTerm') -import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Pretty import Swarm.Language.Syntax hiding (Key) import Swarm.Language.Typecheck ( ContextualTypeErr (..), ) -import Swarm.Language.Typed (Typed (..)) -import Swarm.Language.Types -import Swarm.Language.Value (Value (VExc, VKey, VUnit), envTydefs, envTypes, prettyValue) +import Swarm.Language.Value (Value (VKey), envTypes) import Swarm.Log +import Swarm.TUI.Controller.EventHandlers +import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Controller qualified as EC import Swarm.TUI.Editor.Model -import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) import Swarm.TUI.Launch.Controller import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.Prep (prepareLaunchDialog) @@ -129,14 +101,8 @@ import Swarm.TUI.Model.Repl import Swarm.TUI.Model.StateUpdate import Swarm.TUI.Model.Structure import Swarm.TUI.Model.UI -import Swarm.TUI.View.Objective qualified as GR -import Swarm.TUI.View.Util (generateModal) import Swarm.Util hiding (both, (<<.=)) import Swarm.Version (NewReleaseFailure (..)) -import System.Clock -import System.FilePath (splitDirectories) -import Witch (into) -import Prelude hiding (Applicative (..)) -- See Note [liftA2 re-export from Prelude] -- ~~~~ Note [liftA2 re-export from Prelude] -- @@ -186,6 +152,8 @@ handleEvent = \case AboutMenu -> pressAnyKey (MainMenu (mainMenu About)) -- | The event handler for the main menu. +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleMainMenuEvent :: BL.List Name MainMenuEntry -> BrickEvent Name AppEvent -> EventM Name AppState () handleMainMenuEvent menu = \case @@ -264,6 +232,7 @@ handleMainMessagesEvent = \case where returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages) +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleNewGameMenuEvent :: NonEmpty (BL.List Name ScenarioItem) -> BrickEvent Name AppEvent -> @@ -306,11 +275,7 @@ pressAnyKey _ _ = continueWithoutRedraw handleMainEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleMainEvent ev = do s <- get - mt <- preuse $ uiState . uiGameplay . uiModal . _Just . modalType - let isRunning = maybe True isRunningModal mt - let isPaused = s ^. gameState . temporal . paused - let isCreative = s ^. gameState . creativeMode - let hasDebug = hasDebugCapability isCreative s + let keyHandler = s ^. keyEventHandling . keyDispatchers . to mainGameDispatcher case ev of AppEvent ae -> case ae of Frame @@ -318,85 +283,19 @@ handleMainEvent ev = do | otherwise -> runFrameUI Web (RunWebCode c) -> runBaseWebCode c _ -> continueWithoutRedraw - -- ctrl-q works everywhere - ControlChar 'q' -> - case s ^. gameState . winCondition of - WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal - WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal - _ -> toggleModal QuitModal VtyEvent (V.EvResize _ _) -> invalidateCache - Key V.KEsc - | Just m <- s ^. uiState . uiGameplay . uiModal -> do - safeAutoUnpause - uiState . uiGameplay . uiModal .= Nothing - -- message modal is not autopaused, so update notifications when leaving it - case m ^. modalType of - MessagesModal -> do - gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks - _ -> return () - FKey 1 -> toggleModal HelpModal - FKey 2 -> toggleModal RobotsModal - FKey 3 | not (null (s ^. gameState . discovery . availableRecipes . notificationsContent)) -> do - toggleModal RecipesModal - gameState . discovery . availableRecipes . notificationsCount .= 0 - FKey 4 | not (null (s ^. gameState . discovery . availableCommands . notificationsContent)) -> do - toggleModal CommandsModal - gameState . discovery . availableCommands . notificationsCount .= 0 - FKey 5 | not (null (s ^. gameState . messageNotifications . notificationsContent)) -> do - toggleModal MessagesModal - gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks - FKey 6 | not (null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions) -> toggleModal StructuresModal - -- show goal - ControlChar 'g' -> - if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent - then toggleModal GoalModal - else continueWithoutRedraw - -- hide robots - MetaChar 'h' -> do - t <- liftIO $ getTime Monotonic - h <- use $ uiState . uiGameplay . uiHideRobotsUntil - case h >= t of - -- ignore repeated keypresses - True -> continueWithoutRedraw - -- hide for two seconds - False -> do - uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 - invalidateCacheEntry WorldCache - -- debug focused robot - MetaChar 'd' | isPaused && hasDebug -> do - debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not - if debug - then gameState . temporal . gameStep .= RobotStep SBefore - else zoomGameState finishGameTick >> void updateUI - -- pausing and stepping - ControlChar 'p' | isRunning -> safeTogglePause - ControlChar 'o' | isRunning -> do - gameState . temporal . runStatus .= ManualPause - runGameTickUI - -- speed controls - ControlChar 'x' | isRunning -> modify $ adjustTPS (+) - ControlChar 'z' | isRunning -> modify $ adjustTPS (-) - -- special keys that work on all panels - MetaChar 'w' -> setFocus WorldPanel - MetaChar 'e' -> setFocus RobotPanel - MetaChar 'r' -> setFocus REPLPanel - MetaChar 't' -> setFocus InfoPanel + EscapeKey | Just m <- s ^. uiState . uiGameplay . uiModal -> closeModal m + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] + VtyEvent (V.EvKey k m) + | isJust (B.lookupVtyEvent k m keyHandler) -> void $ B.handleKey keyHandler k m -- pass keys on to modal event handler if a modal is open VtyEvent vev | isJust (s ^. uiState . uiGameplay . uiModal) -> handleModalEvent vev - -- toggle creative mode if in "cheat mode" - MouseDown (TerrainListItem pos) V.BLeft _ _ -> uiState . uiGameplay . uiWorldEditor . terrainList %= BL.listMoveTo pos MouseDown (EntityPaintListItem pos) V.BLeft _ _ -> uiState . uiGameplay . uiWorldEditor . entityPaintList %= BL.listMoveTo pos - ControlChar 'v' - | s ^. uiState . uiCheatMode -> gameState . creativeMode %= not - -- toggle world editor mode if in "cheat mode" - ControlChar 'e' - | s ^. uiState . uiCheatMode -> do - uiState . uiGameplay . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not - setFocus WorldEditorPanel MouseDown WorldPositionIndicator _ _ _ -> uiState . uiGameplay . uiWorldCursor .= Nothing MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc -> -- Eye Dropper tool @@ -407,10 +306,6 @@ handleMainEvent ev = do MouseDown (FocusablePanel WorldPanel) V.BLeft [V.MCtrl] mouseLoc -> -- Paint with the World Editor EC.handleCtrlLeftClick mouseLoc - -- toggle collapse/expand REPL - MetaChar ',' -> do - invalidateCacheEntry WorldCache - uiState . uiGameplay . uiShowREPL %= not MouseDown n _ _ mouseLoc -> case n of FocusablePanel WorldPanel -> do @@ -448,42 +343,27 @@ handleMainEvent ev = do case focusGetCurrent fring of Just (FocusablePanel x) -> case x of REPLPanel -> handleREPLEvent ev - WorldPanel -> handleWorldEvent ev + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] + WorldPanel | VtyEvent (V.EvKey k m) <- ev -> do + wh <- use $ keyEventHandling . keyDispatchers . to worldDispatcher + void $ B.handleKey wh k m + WorldPanel | otherwise -> continueWithoutRedraw WorldEditorPanel -> EC.handleWorldEditorPanelEvent ev RobotPanel -> handleRobotPanelEvent ev InfoPanel -> handleInfoPanelEvent infoScroll ev _ -> continueWithoutRedraw --- | Set the game to Running if it was (auto) paused otherwise to paused. --- --- Also resets the last frame time to now. If we are pausing, it --- doesn't matter; if we are unpausing, this is critical to --- ensure the next frame doesn't think it has to catch up from --- whenever the game was paused! -safeTogglePause :: EventM Name AppState () -safeTogglePause = do - curTime <- liftIO $ getTime Monotonic - uiState . uiGameplay . uiTiming . lastFrameTime .= curTime - uiState . uiGameplay . uiShowDebug .= False - p <- gameState . temporal . runStatus Lens.<%= toggleRunStatus - when (p == Running) $ zoomGameState finishGameTick - --- | Only unpause the game if leaving autopaused modal. --- --- Note that the game could have been paused before opening --- the modal, in that case, leave the game paused. -safeAutoUnpause :: EventM Name AppState () -safeAutoUnpause = do - runs <- use $ gameState . temporal . runStatus - when (runs == AutoPause) safeTogglePause - -toggleModal :: ModalType -> EventM Name AppState () -toggleModal mt = do - modal <- use $ uiState . uiGameplay . uiModal - case modal of - Nothing -> openModal mt - Just _ -> uiState . uiGameplay . uiModal .= Nothing >> safeAutoUnpause +closeModal :: Modal -> EventM Name AppState () +closeModal m = do + safeAutoUnpause + uiState . uiGameplay . uiModal .= Nothing + -- message modal is not autopaused, so update notifications when leaving it + when ((m ^. modalType) == MessagesModal) $ do + t <- use $ gameState . temporal . ticks + gameState . messageInfo . lastSeenMessageTime .= t +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleModalEvent :: V.Event -> EventM Name AppState () handleModalEvent = \case V.EvKey V.KEnter [] -> do @@ -535,94 +415,6 @@ handleModalEvent = \case refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection refreshList z = Brick.zoom z $ BL.handleListEvent ev -getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) -getNormalizedCurrentScenarioPath = - -- the path should be normalized and good to search in scenario collection - use (gameState . currentScenarioPath) >>= \case - Nothing -> return Nothing - Just p' -> do - gs <- use $ runtimeState . scenarios - Just <$> liftIO (normalizeScenarioPath gs p') - -saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo) -saveScenarioInfoOnFinish p = do - initialRunCode <- use $ gameState . gameControls . initiallyRunCode - t <- liftIO getZonedTime - wc <- use $ gameState . winCondition - let won = case wc of - WinConditions (Won _ _) _ -> True - _ -> False - ts <- use $ gameState . temporal . ticks - - -- NOTE: This traversal is apparently not the same one as used by - -- the scenario selection menu, so the menu needs to be updated separately. - -- See Note [scenario menu update] - let currentScenarioInfo :: Traversal' AppState ScenarioInfo - currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2 - - replHist <- use $ uiState . uiGameplay . uiREPL . replHistory - let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput - currentScenarioInfo - %= updateScenarioInfoOnFinish determinator t ts won - status <- preuse currentScenarioInfo - case status of - Nothing -> return () - Just si -> do - let segments = splitDirectories p - case segments of - firstDir : _ -> do - when (won && firstDir == tutorialsDirname) $ - attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial) - _ -> return () - liftIO $ saveScenarioInfo p si - return status - --- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit). -saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m () -saveScenarioInfoOnFinishNocheat = do - -- Don't save progress if we are in cheat mode - cheat <- use $ uiState . uiCheatMode - unless cheat $ do - -- the path should be normalized and good to search in scenario collection - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> void $ saveScenarioInfoOnFinish p - --- | Write the @ScenarioInfo@ out to disk when exiting a game. -saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () -saveScenarioInfoOnQuit = do - -- Don't save progress if we are in cheat mode - -- NOTE This check is duplicated in "saveScenarioInfoOnFinishNocheat" - cheat <- use $ uiState . uiCheatMode - unless cheat $ do - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> do - maybeSi <- saveScenarioInfoOnFinish p - -- Note [scenario menu update] - -- Ensures that the scenario selection menu gets updated - -- with the high score/completion status - forM_ - maybeSi - ( uiState - . uiMenu - . _NewGameMenu - . ix 0 - . BL.listSelectedElementL - . _SISingle - . _2 - .= - ) - - -- See what scenario is currently focused in the menu. Depending on how the - -- previous scenario ended (via quit vs. via win), it might be the same as - -- currentScenarioPath or it might be different. - curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath - -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, - -- being sure to preserve the same focused scenario. - sc <- use $ runtimeState . scenarios - forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=) - -- | Quit a game. -- -- * writes out the updated REPL history to a @.swarm_history@ file @@ -654,354 +446,6 @@ quitGame = do NoMenu -> halt _ -> uiState . uiPlaying .= False ------------------------------------------------------------- --- Handling Frame events ------------------------------------------------------------- - --- | Run the game for a single /frame/ (/i.e./ screen redraw), then --- update the UI. Depending on how long it is taking to draw each --- frame, and how many ticks per second we are trying to achieve, --- this may involve stepping the game any number of ticks (including --- zero). -runFrameUI :: EventM Name AppState () -runFrameUI = do - runFrame - redraw <- updateUI - unless redraw continueWithoutRedraw - --- | Run the game for a single frame, without updating the UI. -runFrame :: EventM Name AppState () -runFrame = do - -- Reset the needsRedraw flag. While processing the frame and stepping the robots, - -- the flag will get set to true if anything changes that requires redrawing the - -- world (e.g. a robot moving or disappearing). - gameState . needsRedraw .= False - - -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ . - - -- Find out how long the previous frame took, by subtracting the - -- previous time from the current time. - prevTime <- use (uiState . uiGameplay . uiTiming . lastFrameTime) - curTime <- liftIO $ getTime Monotonic - let frameTime = diffTimeSpec curTime prevTime - - -- Remember now as the new previous time. - uiState . uiGameplay . uiTiming . lastFrameTime .= curTime - - -- We now have some additional accumulated time to play with. The - -- idea is to now "catch up" by doing as many ticks as are supposed - -- to fit in the accumulated time. Some accumulated time may be - -- left over, but it will roll over to the next frame. This way we - -- deal smoothly with things like a variable frame rate, the frame - -- rate not being a nice multiple of the desired ticks per second, - -- etc. - uiState . uiGameplay . uiTiming . accumulatedTime += frameTime - - -- Figure out how many ticks per second we're supposed to do, - -- and compute the timestep `dt` for a single tick. - lgTPS <- use (uiState . uiGameplay . uiTiming . lgTicksPerSecond) - let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds - dt - | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS) - | otherwise = oneSecond * (1 `shiftL` abs lgTPS) - - -- Update TPS/FPS counters every second - infoUpdateTime <- use (uiState . uiGameplay . uiTiming . lastInfoTime) - let updateTime = toNanoSecs $ diffTimeSpec curTime infoUpdateTime - when (updateTime >= oneSecond) $ do - -- Wait for at least one second to have elapsed - when (infoUpdateTime /= 0) $ do - -- set how much frame got processed per second - frames <- use (uiState . uiGameplay . uiTiming . frameCount) - uiState . uiGameplay . uiTiming . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime - - -- set how much ticks got processed per frame - uiTicks <- use (uiState . uiGameplay . uiTiming . tickCount) - uiState . uiGameplay . uiTiming . uiTPF .= fromIntegral uiTicks / fromIntegral frames - - -- ensure this frame gets drawn - gameState . needsRedraw .= True - - -- Reset the counter and wait another seconds for the next update - uiState . uiGameplay . uiTiming . tickCount .= 0 - uiState . uiGameplay . uiTiming . frameCount .= 0 - uiState . uiGameplay . uiTiming . lastInfoTime .= curTime - - -- Increment the frame count - uiState . uiGameplay . uiTiming . frameCount += 1 - - -- Now do as many ticks as we need to catch up. - uiState . uiGameplay . uiTiming . frameTickCount .= 0 - runFrameTicks (fromNanoSecs dt) - -ticksPerFrameCap :: Int -ticksPerFrameCap = 30 - --- | Do zero or more ticks, with each tick notionally taking the given --- timestep, until we have used up all available accumulated time, --- OR until we have hit the cap on ticks per frame, whichever comes --- first. -runFrameTicks :: TimeSpec -> EventM Name AppState () -runFrameTicks dt = do - a <- use (uiState . uiGameplay . uiTiming . accumulatedTime) - t <- use (uiState . uiGameplay . uiTiming . frameTickCount) - - -- Ensure there is still enough time left, and we haven't hit the - -- tick limit for this frame. - when (a >= dt && t < ticksPerFrameCap) $ do - -- If so, do a tick, count it, subtract dt from the accumulated time, - -- and loop! - runGameTick - Brick.zoom (uiState . uiGameplay . uiTiming) $ do - tickCount += 1 - frameTickCount += 1 - accumulatedTime -= dt - runFrameTicks dt - --- | Run the game for a single tick, and update the UI. -runGameTickUI :: EventM Name AppState () -runGameTickUI = runGameTick >> void updateUI - --- | Modifies the game state using a fused-effect state action. -zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> m a -zoomGameState f = do - gs <- use gameState - (gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f))) - gameState .= gs' - return a - -updateAchievements :: EventM Name AppState () -updateAchievements = do - -- Merge the in-game achievements with the master list in UIState - achievementsFromGame <- use $ gameState . discovery . gameAchievements - let wrappedGameAchievements = M.mapKeys GameplayAchievement achievementsFromGame - - oldMasterAchievementsList <- use $ uiState . uiAchievements - uiState . uiAchievements %= M.unionWith (<>) wrappedGameAchievements - - -- Don't save to disk unless there was a change in the attainment list. - let incrementalAchievements = wrappedGameAchievements `M.difference` oldMasterAchievementsList - unless (null incrementalAchievements) $ do - -- TODO: #916 This is where new achievements would be displayed in a popup - newAchievements <- use $ uiState . uiAchievements - liftIO $ saveAchievementsInfo $ M.elems newAchievements - --- | Run the game for a single tick (/without/ updating the UI). --- Every robot is given a certain amount of maximum computation to --- perform a single world action (like moving, turning, grabbing, --- etc.). -runGameTick :: EventM Name AppState () -runGameTick = do - ticked <- zoomGameState gameTick - when ticked updateAchievements - --- | Update the UI. This function is used after running the --- game for some number of ticks. -updateUI :: EventM Name AppState Bool -updateUI = do - loadVisibleRegion - - -- If the game state indicates a redraw is needed, invalidate the - -- world cache so it will be redrawn. - g <- use gameState - when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache - - -- The hash of the robot whose inventory is currently displayed (if any) - listRobotHash <- fmap fst <$> use (uiState . uiGameplay . uiInventory . uiInventoryList) - - -- The hash of the focused robot (if any) - fr <- use (gameState . to focusedRobot) - let focusedRobotHash = view inventoryHash <$> fr - - -- Check if the inventory list needs to be updated. - shouldUpdate <- use (uiState . uiGameplay . uiInventory . uiInventoryShouldUpdate) - - -- Whether the focused robot is too far away to sense, & whether - -- that has recently changed - dist <- use (gameState . to focusedRange) - farOK <- liftA2 (||) (use (gameState . creativeMode)) (use (gameState . landscape . worldScrollable)) - let tooFar = not farOK && dist == Just Far - farChanged = tooFar /= isNothing listRobotHash - - -- If the robot moved in or out of range, or hashes don't match - -- (either because which robot (or whether any robot) is focused - -- changed, or the focused robot's inventory changed), or the - -- inventory was flagged to be updated, regenerate the inventory list. - inventoryUpdated <- - if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate - then do - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - populateInventoryList $ if tooFar then Nothing else fr - uiInventoryShouldUpdate .= False - pure True - else pure False - - -- Now check if the base finished running a program entered at the REPL. - replUpdated <- case g ^. gameControls . replStatus of - REPLWorking pty (Just v) - -- It did, and the result was the unit value or an exception. Just reset replStatus. - | v `elem` [VUnit, VExc] -> do - gameState . gameControls . replStatus .= REPLDone (Just (pty, v)) - pure True - - -- It did, and returned some other value. Create new 'it' - -- variables, pretty-print the result as a REPL output, with its - -- type, and reset the replStatus. - | otherwise -> do - itIx <- use (gameState . gameControls . replNextValueIndex) - env <- use (gameState . baseEnv) - let finalType = stripCmd (env ^. envTydefs) pty - itName = fromString $ "it" ++ show itIx - out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] - uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLOutput out) - invalidateCacheEntry REPLHistoryCache - vScrollToEnd replScroll - gameState . gameControls . replStatus .= REPLDone (Just (finalType, v)) - gameState . baseEnv . at itName .= Just (Typed v finalType mempty) - gameState . baseEnv . at "it" .= Just (Typed v finalType mempty) - gameState . gameControls . replNextValueIndex %= (+ 1) - pure True - - -- Otherwise, do nothing. - _ -> pure False - - -- If the focused robot's log has been updated and the UI focus - -- isn't currently on the inventory or info panels, attempt to - -- automatically switch to the logger and scroll all the way down so - -- the new message can be seen. - uiState . uiGameplay . uiScrollToEnd .= False - logUpdated <- do - -- If the inventory or info panels are currently focused, it would - -- be rude to update them right under the user's nose, so consider - -- them "sticky". They will be updated as soon as the player moves - -- the focus away. - fring <- use $ uiState . uiGameplay . uiFocusRing - let sticky = focusGetCurrent fring `elem` map (Just . FocusablePanel) [RobotPanel, InfoPanel] - - -- Check if the robot log was updated and we are allowed to change - -- the inventory+info panels. - case maybe False (view robotLogUpdated) fr && not sticky of - False -> pure False - True -> do - -- Reset the log updated flag - zoomGameState $ zoomRobots clearFocusedRobotLogUpdated - - -- Find and focus an equipped "logger" device in the inventory list. - let isLogger (EquippedEntry e) = e ^. entityName == "logger" - isLogger _ = False - focusLogger = BL.listFindBy isLogger - - uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 %= focusLogger - - -- Now inform the UI that it should scroll the info panel to - -- the very end. - uiState . uiGameplay . uiScrollToEnd .= True - pure True - - goalOrWinUpdated <- doGoalUpdates - - let redraw = - g ^. needsRedraw - || inventoryUpdated - || replUpdated - || logUpdated - || goalOrWinUpdated - pure redraw - --- | Either pops up the updated Goals modal --- or pops up the Congratulations (Win) modal, or pops --- up the Condolences (Lose) modal. --- The Win modal will take precedence if the player --- has met the necessary conditions to win the game. --- --- If the player chooses to "Keep Playing" from the Win modal, the --- updated Goals will then immediately appear. --- This is desirable for: --- * feedback as to the final goal the player accomplished, --- * as a summary of all of the goals of the game --- * shows the player more "optional" goals they can continue to pursue -doGoalUpdates :: EventM Name AppState Bool -doGoalUpdates = do - curGoal <- use (uiState . uiGameplay . uiGoal . goalsContent) - isCheating <- use (uiState . uiCheatMode) - curWinCondition <- use (gameState . winCondition) - announcementsSeq <- use (gameState . messageInfo . announcementQueue) - let announcementsList = toList announcementsSeq - - -- Decide whether we need to update the current goal text and pop - -- up a modal dialog. - case curWinCondition of - NoWinCondition -> return False - WinConditions (Unwinnable False) x -> do - -- This clears the "flag" that the Lose dialog needs to pop up - gameState . winCondition .= WinConditions (Unwinnable True) x - openModal $ ScenarioEndModal LoseModal - saveScenarioInfoOnFinishNocheat - return True - WinConditions (Won False ts) x -> do - -- This clears the "flag" that the Win dialog needs to pop up - gameState . winCondition .= WinConditions (Won True ts) x - openModal $ ScenarioEndModal WinModal - saveScenarioInfoOnFinishNocheat - -- We do NOT advance the New Game menu to the next item here (we - -- used to!), because we do not know if the user is going to - -- select 'keep playing' or 'next challenge'. We maintain the - -- invariant that the current menu item is always the same as - -- the scenario currently being played. If the user either (1) - -- quits to the menu or (2) selects 'next challenge' we will - -- advance the menu at that point. - return True - WinConditions _ oc -> do - let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc - -- The "uiGoal" field is initialized with empty members, so we know that - -- this will be the first time showing it if it will be nonempty after previously - -- being empty. - isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal) - goalWasUpdated = isFirstGoalDisplay || not (null announcementsList) - - -- Decide whether to show a pop-up modal congratulating the user on - -- successfully completing the current challenge. - when goalWasUpdated $ do - let hasMultiple = hasMultipleGoals newGoalTracking - defaultFocus = - if hasMultiple - then ObjectivesList - else GoalSummary - - ring = - focusRing $ - map GoalWidgets $ - if hasMultiple - then enumerate - else [GoalSummary] - - -- The "uiGoal" field is necessary at least to "persist" the data that is needed - -- if the player chooses to later "recall" the goals dialog with CTRL+g. - uiState - . uiGameplay - . uiGoal - .= GoalDisplay - newGoalTracking - (GR.makeListWidget newGoalTracking) - (focusSetCurrent (GoalWidgets defaultFocus) ring) - - -- This clears the "flag" that indicate that the goals dialog needs to be - -- automatically popped up. - gameState . messageInfo . announcementQueue .= mempty - - hideGoals <- use $ uiState . uiGameplay . uiHideGoals - unless hideGoals $ - openModal GoalModal - - return goalWasUpdated - --- | Strips the top-level @Cmd@ from a type, if any (to compute the --- result type of a REPL command evaluation). -stripCmd :: TDCtx -> Polytype -> Polytype -stripCmd tdCtx (Forall xs ty) = case whnfType tdCtx ty of - TyCmd resTy -> Forall xs resTy - _ -> Forall xs ty - ------------------------------------------------------------ -- REPL events ------------------------------------------------------------ @@ -1017,37 +461,14 @@ resetREPL t r replState = handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEvent x = do s <- get - let theRepl = s ^. uiState . uiGameplay . uiREPL - controlMode = theRepl ^. replControlMode - uinput = theRepl ^. replPromptText + let controlMode = s ^. uiState . uiGameplay . uiREPL . replControlMode + let keyHandler = s ^. keyEventHandling . keyDispatchers . to replDispatcher case x of - -- Handle Ctrl-c here so we can always cancel the currently running - -- base program no matter what REPL control mode we are in. - ControlChar 'c' -> do - working <- use $ gameState . gameControls . replWorking - when working $ gameState . baseRobot . machine %= cancel - Brick.zoom (uiState . uiGameplay . uiREPL) $ do - replPromptType .= CmdPrompt [] - replPromptText .= "" - - -- Handle M-p and M-k, shortcuts for toggling pilot + key handler modes. - MetaChar 'p' -> - onlyCreative $ do - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode - case curMode of - Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing - _ -> - if T.null uinput - then uiState . uiGameplay . uiREPL . replControlMode .= Piloting - else do - let err = REPLError "Please clear the REPL before engaging pilot mode." - uiState . uiGameplay . uiREPL . replHistory %= addREPLItem err - invalidateCacheEntry REPLHistoryCache - MetaChar 'k' -> do - when (isJust (s ^. gameState . gameControls . inputHandler)) $ do - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode - (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling - + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] + VtyEvent (V.EvKey k m) + | isJust (B.lookupVtyEvent k m keyHandler) -> + void $ B.handleKey keyHandler k m -- Handle other events in a way appropriate to the current REPL -- control mode. _ -> case controlMode of @@ -1081,6 +502,8 @@ runInputHandler kc = do gameState %= execState (zoomRobots $ activateRobot 0) -- | Handle a user "piloting" input event for the REPL. +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEventPiloting x = case x of Key V.KUp -> inputCmd "move" @@ -1130,22 +553,9 @@ runBaseCode uinput = do Left err -> do uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLError err) -runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () -runBaseTerm = maybe (pure ()) startBaseProgram - where - -- The player typed something at the REPL and hit Enter; this - -- function takes the resulting ProcessedTerm (if the REPL - -- input is valid) and sets up the base robot to run it. - startBaseProgram t = do - -- Set the REPL status to Working - gameState . gameControls . replStatus .= REPLWorking (t ^. sType) Nothing - -- Set up the robot's CESK machine to evaluate/execute the - -- given term. - gameState . baseRobot . machine %= continue t - -- Finally, be sure to activate the base robot. - gameState %= execState (zoomRobots $ activateRobot 0) - -- | Handle a user input event for the REPL. +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEventTyping = \case -- Scroll the REPL on PageUp or PageDown @@ -1352,177 +762,13 @@ adjReplHistIndex d s = oldEntry = getCurrEntry theRepl newEntry = getCurrEntry newREPL ------------------------------------------------------------- --- World events ------------------------------------------------------------- - -worldScrollDist :: Int32 -worldScrollDist = 8 - -onlyCreative :: (MonadState AppState m) => m () -> m () -onlyCreative a = do - c <- use $ gameState . creativeMode - when c a - --- | Handle a user input event in the world view panel. -handleWorldEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleWorldEvent = \case - Key k - | k `elem` moveKeys -> do - c <- use $ gameState . creativeMode - s <- use $ gameState . landscape . worldScrollable - when (c || s) $ scrollView (.+^ (worldScrollDist *^ keyToDir k)) - CharKey 'c' -> do - invalidateCacheEntry WorldCache - gameState . robotInfo . viewCenterRule .= VCRobot 0 - -- show fps - CharKey 'f' -> uiState . uiGameplay . uiTiming . uiShowFPS %= not - -- Fall-through case: don't do anything. - _ -> continueWithoutRedraw - where - moveKeys = - [ V.KUp - , V.KDown - , V.KLeft - , V.KRight - , V.KChar 'h' - , V.KChar 'j' - , V.KChar 'k' - , V.KChar 'l' - ] - --- | Manually scroll the world view. -scrollView :: (Location -> Location) -> EventM Name AppState () -scrollView update = do - -- Manually invalidate the 'WorldCache' instead of just setting - -- 'needsRedraw'. I don't quite understand why the latter doesn't - -- always work, but there seems to be some sort of race condition - -- where 'needsRedraw' gets reset before the UI drawing code runs. - invalidateCacheEntry WorldCache - gameState . robotInfo %= modifyViewCenter (fmap update) - --- | Convert a directional key into a direction. -keyToDir :: V.Key -> Heading -keyToDir V.KUp = north -keyToDir V.KDown = south -keyToDir V.KRight = east -keyToDir V.KLeft = west -keyToDir (V.KChar 'h') = west -keyToDir (V.KChar 'j') = south -keyToDir (V.KChar 'k') = north -keyToDir (V.KChar 'l') = east -keyToDir _ = zero - --- | Adjust the ticks per second speed. -adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState -adjustTPS (+/-) = uiState . uiGameplay . uiTiming . lgTicksPerSecond %~ (+/- 1) - ------------------------------------------------------------- --- Robot panel events ------------------------------------------------------------- - --- | Handle user input events in the robot panel. -handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleRobotPanelEvent bev = do - search <- use $ uiState . uiGameplay . uiInventory . uiInventorySearch - case search of - Just _ -> handleInventorySearchEvent bev - Nothing -> case bev of - Key V.KEnter -> - gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal - CharKey 'm' -> - gets focusedEntity >>= maybe continueWithoutRedraw makeEntity - CharKey '0' -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiShowZero %= not - CharKey ';' -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySort %= cycleSortOrder - CharKey ':' -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySort %= cycleSortDirection - CharKey '/' -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch .= Just "" - VtyEvent ev -> handleInventoryListEvent ev - _ -> continueWithoutRedraw - --- | Handle an event to navigate through the inventory list. -handleInventoryListEvent :: V.Event -> EventM Name AppState () -handleInventoryListEvent ev = do - -- Note, refactoring like this is tempting: - -- - -- Brick.zoom (uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2) (handleListEventWithSeparators ev (is _Separator)) - -- - -- However, this does not work since we want to skip redrawing in the no-list case! - - mList <- preuse $ uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 - case mList of - Nothing -> continueWithoutRedraw - Just l -> do - when (isValidListMovement ev) $ resetViewport infoScroll - l' <- nestEventM' l (handleListEventWithSeparators ev (is _Separator)) - uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 .= l' - --- | Handle a user input event in the robot/inventory panel, while in --- inventory search mode. -handleInventorySearchEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleInventorySearchEvent = \case - -- Escape: stop filtering and go back to regular inventory mode - EscapeKey -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch .= Nothing - -- Enter: return to regular inventory mode, and pop out the selected item - Key V.KEnter -> do - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch .= Nothing - gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal - -- Any old character: append to the current search string - CharKey c -> do - resetViewport infoScroll - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch %= fmap (`snoc` c) - -- Backspace: chop the last character off the end of the current search string - BackspaceKey -> do - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch %= fmap (T.dropEnd 1) - -- Handle any other event as list navigation, so we can look through - -- the filtered inventory using e.g. arrow keys - VtyEvent ev -> handleInventoryListEvent ev - _ -> continueWithoutRedraw - --- | Attempt to make an entity selected from the inventory, if the --- base is not currently busy. -makeEntity :: Entity -> EventM Name AppState () -makeEntity e = do - s <- get - let name = e ^. entityName - mkT = [tmQ| make $str:name |] - - case isActive <$> (s ^? gameState . baseRobot) of - Just False -> runBaseTerm (Just mkT) - _ -> continueWithoutRedraw - --- | Display a modal window with the description of an entity. -descriptionModal :: Entity -> EventM Name AppState () -descriptionModal e = do - s <- get - resetViewport modalScroll - uiState . uiGameplay . uiModal ?= generateModal s (DescriptionModal e) - ------------------------------------------------------------ -- Info panel events ------------------------------------------------------------ -- | Handle user events in the info panel (just scrolling). +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleInfoPanelEvent :: ViewportScroll Name -> BrickEvent Name AppEvent -> EventM Name AppState () handleInfoPanelEvent vs = \case Key V.KDown -> vScrollBy vs 1 diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs new file mode 100644 index 000000000..f35e99aeb --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Swarm (abstract) event handlers allow players to customize some keybindings. +-- This all comes together in 'Swarm.TUI.Controller' which calls the handlers +-- for parts of UI and also handles mouse events and frame updates. +module Swarm.TUI.Controller.EventHandlers ( + -- * Documentation + createKeyDispatchers, + allEventHandlers, + + -- ** Main game handler + mainEventHandlers, + + -- ** REPL panel handler + replEventHandlers, + + -- ** World panel handler + worldEventHandlers, + + -- ** Robot panel handler + robotEventHandlers, + handleRobotPanelEvent, + + -- ** Frame + runFrameUI, + runGameTickUI, + ticksPerFrameCap, +) where + +import Brick hiding (on) +import Brick.Keybindings as BK +import Control.Effect.Accum +import Control.Effect.Throw +import Data.List (sortOn) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Swarm.Game.Failure (SystemFailure (..)) +import Swarm.TUI.Controller.EventHandlers.Frame (runFrameUI, runGameTickUI, ticksPerFrameCap) +import Swarm.TUI.Controller.EventHandlers.Main (mainEventHandlers) +import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers) +import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, robotEventHandlers) +import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents) +import Swarm.Util (parens, squote) + +-- ~~~~ Note [how Swarm event handlers work] +-- +-- Allowing players to customize keybindings requires storing the configuration in AppState. +-- By doing it as declaratively as possible, Brick also allows us to detect conflicts. +-- +-- The high level overview is this: +-- 1. The 'SwarmEvent' is a enumeration of abstracts key events ('PauseEvent', etc.) +-- 2. The 'AppState' definition contains the key configuration and dispatchers (keys to handlers) +-- 3. Here in 'Swarm.TUI.Controller.EventHandlers' we declare the handlers for abstract events +-- and also some non-customizable key handlers (e.g. escape and enter). +-- 4. When provided with 'KeyConfig' (can include customized keybindings) we can +-- 'createKeyDispatchers' in 'Swarm.TUI.Model.StateUpdate' and store them in 'AppState'. +-- 5. Finally in 'Swarm.TUI.Controller' the Brick event handler calls the stored dispatchers. + +-- | Create key dispatchers that call (abstract) event handlers based on given key config. +-- +-- Fails if any key events have conflict within one dispatcher or when a main dispatcher +-- has conflict with one of the subdispatchers. +createKeyDispatchers :: + (Has (Throw SystemFailure) sig m) => + KeyConfig SwarmEvent -> + m SwarmKeyDispatchers +createKeyDispatchers config = do + mainGameDispatcher <- buildDispatcher mainEventHandlers + let buildSubMainDispatcher = buildSubDispatcher "Main game events" mainGameDispatcher + replDispatcher <- buildSubMainDispatcher "REPL panel events" replEventHandlers + worldDispatcher <- buildSubMainDispatcher "World view panel events" worldEventHandlers + robotDispatcher <- buildSubMainDispatcher "Robot inventory panel events" robotEventHandlers + return SwarmKeyDispatchers {..} + where + -- this error handling code is modified version of the brick demo app: + -- https://github.com/jtdaugherty/brick/blob/764e66897/programs/CustomKeybindingDemo.hs#L216 + buildDispatcher handlers = case keyDispatcher config handlers of + Left collisions -> + throwLoadingFailure $ + "Error: some key events have the same keys bound to them.\n" + : handlerErrors collisions + Right d -> return d + buildSubDispatcher parentName parentDispatcher name handlers = do + d <- buildDispatcher handlers + let collisions = conflicts parentDispatcher d + if null collisions + then return d + else + throwLoadingFailure $ + ("Error: some key events have keys bound to them in '" <> parentName <> "' and in '" <> name <> "'") + : handlerErrors collisions + + throwLoadingFailure = throwError . CustomFailure . T.intercalate "\n" + handlerErrors collisions = flip map collisions $ \(b, hs) -> + let hsm = "Handlers with the " <> squote (BK.ppBinding b) <> " binding:" + hss = flip map hs $ \h -> + let trigger = case BK.kehEventTrigger $ BK.khHandler h of + ByKey k -> "triggered by the key " <> squote (BK.ppBinding k) + ByEvent e -> "triggered by the event " <> maybe "" squote (BK.keyEventName swarmEvents e) + desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h + in " " <> desc <> " " <> parens trigger + in T.intercalate "\n" (hsm : hss) + +-- | Take two dispatchers (that do not have conflict themselves) and find conflicting keys between them. +conflicts :: SwarmKeyDispatcher -> SwarmKeyDispatcher -> [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])] +conflicts d1 d2 = combine <$> badGroups + where + l1 = keyDispatcherToList d1 + l2 = keyDispatcherToList d2 + gs = NE.groupWith fst $ sortOn fst (l1 <> l2) + badGroups = filter ((1 <) . length) gs + combine :: NE.NonEmpty (Binding, KeyHandler k m) -> (Binding, [KeyHandler k m]) + combine as = + let b = fst $ NE.head as + in (b, snd <$> NE.toList as) + +allEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +allEventHandlers = + concat + [ mainEventHandlers + , replEventHandlers + , worldEventHandlers + , robotEventHandlers + ] diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs new file mode 100644 index 000000000..ea278aa49 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs @@ -0,0 +1,157 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Handling 'Swarm.TUI.Model.Frame' events. +module Swarm.TUI.Controller.EventHandlers.Frame ( + runFrameUI, + runGameTickUI, + + -- ** Constants + ticksPerFrameCap, +) where + +import Brick +import Control.Lens as Lens +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Bits +import Data.Map qualified as M +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Achievement.Persistence +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.Game.Step (gameTick) +import Swarm.TUI.Controller.UpdateUI +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.UI +import System.Clock + +ticksPerFrameCap :: Int +ticksPerFrameCap = 30 + +-- | Run the game for a single /frame/ (/i.e./ screen redraw), then +-- update the UI. Depending on how long it is taking to draw each +-- frame, and how many ticks per second we are trying to achieve, +-- this may involve stepping the game any number of ticks (including +-- zero). +runFrameUI :: EventM Name AppState () +runFrameUI = do + runFrame + redraw <- updateUI + unless redraw continueWithoutRedraw + +-- | Run the game for a single frame, without updating the UI. +runFrame :: EventM Name AppState () +runFrame = do + -- Reset the needsRedraw flag. While processing the frame and stepping the robots, + -- the flag will get set to true if anything changes that requires redrawing the + -- world (e.g. a robot moving or disappearing). + gameState . needsRedraw .= False + + -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ . + + -- Find out how long the previous frame took, by subtracting the + -- previous time from the current time. + prevTime <- use (uiState . uiGameplay . uiTiming . lastFrameTime) + curTime <- liftIO $ getTime Monotonic + let frameTime = diffTimeSpec curTime prevTime + + -- Remember now as the new previous time. + uiState . uiGameplay . uiTiming . lastFrameTime .= curTime + + -- We now have some additional accumulated time to play with. The + -- idea is to now "catch up" by doing as many ticks as are supposed + -- to fit in the accumulated time. Some accumulated time may be + -- left over, but it will roll over to the next frame. This way we + -- deal smoothly with things like a variable frame rate, the frame + -- rate not being a nice multiple of the desired ticks per second, + -- etc. + uiState . uiGameplay . uiTiming . accumulatedTime += frameTime + + -- Figure out how many ticks per second we're supposed to do, + -- and compute the timestep `dt` for a single tick. + lgTPS <- use (uiState . uiGameplay . uiTiming . lgTicksPerSecond) + let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds + dt + | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS) + | otherwise = oneSecond * (1 `shiftL` abs lgTPS) + + -- Update TPS/FPS counters every second + infoUpdateTime <- use (uiState . uiGameplay . uiTiming . lastInfoTime) + let updateTime = toNanoSecs $ diffTimeSpec curTime infoUpdateTime + when (updateTime >= oneSecond) $ do + -- Wait for at least one second to have elapsed + when (infoUpdateTime /= 0) $ do + -- set how much frame got processed per second + frames <- use (uiState . uiGameplay . uiTiming . frameCount) + uiState . uiGameplay . uiTiming . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime + + -- set how much ticks got processed per frame + uiTicks <- use (uiState . uiGameplay . uiTiming . tickCount) + uiState . uiGameplay . uiTiming . uiTPF .= fromIntegral uiTicks / fromIntegral frames + + -- ensure this frame gets drawn + gameState . needsRedraw .= True + + -- Reset the counter and wait another seconds for the next update + uiState . uiGameplay . uiTiming . tickCount .= 0 + uiState . uiGameplay . uiTiming . frameCount .= 0 + uiState . uiGameplay . uiTiming . lastInfoTime .= curTime + + -- Increment the frame count + uiState . uiGameplay . uiTiming . frameCount += 1 + + -- Now do as many ticks as we need to catch up. + uiState . uiGameplay . uiTiming . frameTickCount .= 0 + runFrameTicks (fromNanoSecs dt) + +-- | Do zero or more ticks, with each tick notionally taking the given +-- timestep, until we have used up all available accumulated time, +-- OR until we have hit the cap on ticks per frame, whichever comes +-- first. +runFrameTicks :: TimeSpec -> EventM Name AppState () +runFrameTicks dt = do + a <- use (uiState . uiGameplay . uiTiming . accumulatedTime) + t <- use (uiState . uiGameplay . uiTiming . frameTickCount) + + -- Ensure there is still enough time left, and we haven't hit the + -- tick limit for this frame. + when (a >= dt && t < ticksPerFrameCap) $ do + -- If so, do a tick, count it, subtract dt from the accumulated time, + -- and loop! + runGameTick + Brick.zoom (uiState . uiGameplay . uiTiming) $ do + tickCount += 1 + frameTickCount += 1 + accumulatedTime -= dt + runFrameTicks dt + +-- | Run the game for a single tick, and update the UI. +runGameTickUI :: EventM Name AppState () +runGameTickUI = runGameTick >> void updateUI + +updateAchievements :: EventM Name AppState () +updateAchievements = do + -- Merge the in-game achievements with the master list in UIState + achievementsFromGame <- use $ gameState . discovery . gameAchievements + let wrappedGameAchievements = M.mapKeys GameplayAchievement achievementsFromGame + + oldMasterAchievementsList <- use $ uiState . uiAchievements + uiState . uiAchievements %= M.unionWith (<>) wrappedGameAchievements + + -- Don't save to disk unless there was a change in the attainment list. + let incrementalAchievements = wrappedGameAchievements `M.difference` oldMasterAchievementsList + unless (null incrementalAchievements) $ do + -- TODO: #916 This is where new achievements would be displayed in a popup + newAchievements <- use $ uiState . uiAchievements + liftIO $ saveAchievementsInfo $ M.elems newAchievements + +-- | Run the game for a single tick (/without/ updating the UI). +-- Every robot is given a certain amount of maximum computation to +-- perform a single world action (like moving, turning, grabbing, +-- etc.). +runGameTick :: EventM Name AppState () +runGameTick = do + ticked <- zoomGameState gameTick + when ticked updateAchievements diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs new file mode 100644 index 000000000..ec895d5f2 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Here is the main player configurable key event handler while playing the game. +module Swarm.TUI.Controller.EventHandlers.Main ( + mainEventHandlers, +) where + +import Brick +import Brick.Keybindings +import Control.Lens as Lens +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (liftIO) +import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.Game.Step (finishGameTick) +import Swarm.TUI.Controller.EventHandlers.Frame (runGameTickUI) +import Swarm.TUI.Controller.UpdateUI (updateUI) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Editor.Model (isWorldEditorEnabled, worldOverdraw) +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (MainEvent (..), SwarmEvent (..)) +import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.UI +import System.Clock (Clock (..), TimeSpec (..), getTime) + +-- | Main keybindings event handler while running the game itself. +-- +-- See 'Swarm.TUI.Controller.handleMainEvent'. +mainEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +mainEventHandlers = allHandlers Main $ \case + QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) + ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) + ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) + ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) + ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) + ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) + ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) + ViewGoalEvent -> ("View scenario goal description", viewGoal) + HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) + ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) + PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) + RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) + IncreaseTpsEvent -> ("Double game speed", whenRunning . modify $ adjustTPS (+)) + DecreaseTpsEvent -> ("Halve game speed", whenRunning . modify $ adjustTPS (-)) + FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) + FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) + FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) + FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) + ToggleCreativeModeEvent -> ("Toggle creative mode", whenCheating toggleCreativeMode) + ToggleWorldEditorEvent -> ("Toggle world editor mode", whenCheating toggleWorldEditor) + ToggleREPLVisibilityEvent -> ("Collapse/Expand REPL panel", toggleREPLVisibility) + +toggleQuitGameDialog :: EventM Name AppState () +toggleQuitGameDialog = do + s <- get + case s ^. gameState . winCondition of + WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal + WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal + _ -> toggleModal QuitModal + +toggleGameModal :: Foldable t => ModalType -> Getter GameState (t a) -> EventM Name AppState Bool +toggleGameModal m l = do + s <- get + let nothingToShow = null $ s ^. gameState . l + unless nothingToShow $ toggleModal m + return nothingToShow + +toggleDiscoveryModal :: Foldable t => ModalType -> Lens' Discovery (t a) -> EventM Name AppState () +toggleDiscoveryModal m l = void $ toggleGameModal m (discovery . l) + +toggleDiscoveryNotificationModal :: ModalType -> Lens' Discovery (Notifications a) -> EventM Name AppState () +toggleDiscoveryNotificationModal m l = do + nothingToShow <- toggleGameModal m (discovery . l . notificationsContent) + unless nothingToShow $ gameState . discovery . l . notificationsCount .= 0 + +toggleMessagesModal :: EventM Name AppState () +toggleMessagesModal = do + s <- get + nothingToShow <- toggleGameModal MessagesModal (messageNotifications . notificationsContent) + unless nothingToShow $ gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks + +viewGoal :: EventM Name AppState () +viewGoal = do + s <- get + if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent + then toggleModal GoalModal + else continueWithoutRedraw + +hideRobots :: EventM Name AppState () +hideRobots = do + t <- liftIO $ getTime Monotonic + h <- use $ uiState . uiGameplay . uiHideRobotsUntil + case h >= t of + -- ignore repeated keypresses + True -> continueWithoutRedraw + -- hide for two seconds + False -> do + uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 + invalidateCacheEntry WorldCache + +showCESKDebug :: EventM Name AppState () +showCESKDebug = do + s <- get + let isPaused = s ^. gameState . temporal . paused + let isCreative = s ^. gameState . creativeMode + let hasDebug = hasDebugCapability isCreative s + when (isPaused && hasDebug) $ do + debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not + if debug + then gameState . temporal . gameStep .= RobotStep SBefore + else zoomGameState finishGameTick >> void updateUI + +runSingleTick :: EventM Name AppState () +runSingleTick = do + gameState . temporal . runStatus .= ManualPause + runGameTickUI + +-- | Adjust the ticks per second speed. +adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState +adjustTPS (+/-) = uiState . uiGameplay . uiTiming . lgTicksPerSecond %~ (+/- 1) + +toggleCreativeMode :: EventM Name AppState () +toggleCreativeMode = gameState . creativeMode %= not + +toggleWorldEditor :: EventM Name AppState () +toggleWorldEditor = do + uiState . uiGameplay . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not + setFocus WorldEditorPanel + +toggleREPLVisibility :: EventM Name AppState () +toggleREPLVisibility = do + invalidateCacheEntry WorldCache + uiState . uiGameplay . uiShowREPL %= not + +-- ---------------------------------------------- +-- HELPER UTILS +-- ---------------------------------------------- + +isRunning :: EventM Name AppState Bool +isRunning = do + mt <- preuse $ uiState . uiGameplay . uiModal . _Just . modalType + return $ maybe True isRunningModal mt + +whenRunning :: EventM Name AppState () -> EventM Name AppState () +whenRunning a = isRunning >>= \r -> when r a + +whenCheating :: EventM Name AppState () -> EventM Name AppState () +whenCheating a = do + s <- get + when (s ^. uiState . uiCheatMode) a diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs new file mode 100644 index 000000000..35449cd91 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Here is the REPL player configurable key event handler. +module Swarm.TUI.Controller.EventHandlers.REPL ( + replEventHandlers, +) where + +import Brick +import Brick.Keybindings qualified as B +import Control.Lens as Lens +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.Text qualified as T +import Swarm.Game.CESK (cancel) +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Event +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI + +-- | Handle a user input key event for the REPL. +-- +-- See 'Swarm.TUI.Controller.handleREPLEvent'. +replEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] +replEventHandlers = allHandlers REPL $ \case + CancelRunningProgramEvent -> ("Cancel running base robot program", cancelRunningBase) + TogglePilotingModeEvent -> ("Toggle piloting mode", onlyCreative togglePilotingMode) + ToggleCustomKeyHandlingEvent -> ("Toggle custom key handling mode", toggleCustomKeyHandling) + +-- | Cancel the running base CESK machine and clear REPL input text. +-- +-- It is handled in top REPL handler so we can always cancel the currently running +-- base program no matter what REPL control mode we are in. +cancelRunningBase :: EventM Name AppState () +cancelRunningBase = do + working <- use $ gameState . gameControls . replWorking + when working $ gameState . baseRobot . machine %= cancel + Brick.zoom (uiState . uiGameplay . uiREPL) $ do + replPromptType .= CmdPrompt [] + replPromptText .= "" + +togglePilotingMode :: EventM Name AppState () +togglePilotingMode = do + s <- get + let theRepl = s ^. uiState . uiGameplay . uiREPL + uinput = theRepl ^. replPromptText + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + case curMode of + Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing + _ -> + if T.null uinput + then uiState . uiGameplay . uiREPL . replControlMode .= Piloting + else do + let err = REPLError "Please clear the REPL before engaging pilot mode." + uiState . uiGameplay . uiREPL . replHistory %= addREPLItem err + invalidateCacheEntry REPLHistoryCache + +toggleCustomKeyHandling :: EventM Name AppState () +toggleCustomKeyHandling = do + s <- get + when (isJust (s ^. gameState . gameControls . inputHandler)) $ do + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs new file mode 100644 index 000000000..542346f76 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Here is the RobotPanel key event handler. +-- +-- Because of how tricky the search logic is, +-- the player configurable part and the dynamic +-- search handler are both here. +module Swarm.TUI.Controller.EventHandlers.Robot ( + robotEventHandlers, + handleRobotPanelEvent, +) where + +import Brick +import Brick.Keybindings +import Control.Lens as Lens +import Control.Lens.Extras as Lens (is) +import Control.Monad (unless, when) +import Data.Text qualified as T +import Graphics.Vty qualified as V +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Language.Pipeline.QQ (tmQ) +import Swarm.Language.Syntax hiding (Key) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) +import Swarm.TUI.List +import Swarm.TUI.Model +import Swarm.TUI.Model.Event +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Util (generateModal) + +-- | Handle user input events in the robot panel. +handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleRobotPanelEvent bev = do + search <- use $ uiState . uiGameplay . uiInventory . uiInventorySearch + keyHandler <- use $ keyEventHandling . keyDispatchers . to robotDispatcher + case search of + Just _ -> handleInventorySearchEvent bev + Nothing -> case bev of + VtyEvent ev@(V.EvKey k m) -> do + handled <- handleKey keyHandler k m + unless handled $ handleInventoryListEvent ev + _ -> continueWithoutRedraw + +-- | Handle key events in the robot panel. +robotEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +robotEventHandlers = nonCustomizableHandlers <> customizableHandlers + where + nonCustomizableHandlers = + [ onKey V.KEnter "Show entity description" showEntityDescription + ] + customizableHandlers = allHandlers Robot $ \case + MakeEntityEvent -> ("Make the selected entity", makeFocusedEntity) + ShowZeroInventoryEntitiesEvent -> ("Show entities with zero count in inventory", zoomInventory showZero) + CycleInventorySortEvent -> ("Cycle inventory sorting type", zoomInventory cycleSort) + SwitchInventorySortDirection -> ("Switch ascending/descending inventory sort", zoomInventory switchSortDirection) + SearchInventoryEvent -> ("Start inventory search", zoomInventory searchInventory) + +-- | Display a modal window with the description of an entity. +showEntityDescription :: EventM Name AppState () +showEntityDescription = gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal + where + descriptionModal :: Entity -> EventM Name AppState () + descriptionModal e = do + s <- get + resetViewport modalScroll + uiState . uiGameplay . uiModal ?= generateModal s (DescriptionModal e) + +-- | Attempt to make an entity selected from the inventory, if the +-- base is not currently busy. +makeFocusedEntity :: EventM Name AppState () +makeFocusedEntity = gets focusedEntity >>= maybe continueWithoutRedraw makeEntity + where + makeEntity :: Entity -> EventM Name AppState () + makeEntity e = do + s <- get + let name = e ^. entityName + mkT = [tmQ| make $str:name |] + case isActive <$> (s ^? gameState . baseRobot) of + Just False -> runBaseTerm (Just mkT) + _ -> continueWithoutRedraw + +showZero :: EventM Name UIInventory () +showZero = uiShowZero %= not + +cycleSort :: EventM Name UIInventory () +cycleSort = uiInventorySort %= cycleSortOrder + +switchSortDirection :: EventM Name UIInventory () +switchSortDirection = uiInventorySort %= cycleSortDirection + +searchInventory :: EventM Name UIInventory () +searchInventory = uiInventorySearch .= Just "" + +-- | Handle an event to navigate through the inventory list. +handleInventoryListEvent :: V.Event -> EventM Name AppState () +handleInventoryListEvent ev = do + -- Note, refactoring like this is tempting: + -- + -- Brick.zoom (uiState . ... . _Just . _2) (handleListEventWithSeparators ev (is _Separator)) + -- + -- However, this does not work since we want to skip redrawing in the no-list case! + mList <- preuse $ uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 + case mList of + Nothing -> continueWithoutRedraw + Just l -> do + when (isValidListMovement ev) $ resetViewport infoScroll + l' <- nestEventM' l (handleListEventWithSeparators ev (is _Separator)) + uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 .= l' + +-- ---------------------------------------------- +-- INVENTORY SEARCH +-- ---------------------------------------------- + +-- | Handle a user input event in the robot/inventory panel, while in +-- inventory search mode. +handleInventorySearchEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleInventorySearchEvent = \case + -- Escape: stop filtering and go back to regular inventory mode + EscapeKey -> + zoomInventory $ uiInventorySearch .= Nothing + -- Enter: return to regular inventory mode, and pop out the selected item + Key V.KEnter -> do + zoomInventory $ uiInventorySearch .= Nothing + showEntityDescription + -- Any old character: append to the current search string + CharKey c -> do + resetViewport infoScroll + zoomInventory $ uiInventorySearch %= fmap (`snoc` c) + -- Backspace: chop the last character off the end of the current search string + BackspaceKey -> do + zoomInventory $ uiInventorySearch %= fmap (T.dropEnd 1) + -- Handle any other event as list navigation, so we can look through + -- the filtered inventory using e.g. arrow keys + VtyEvent ev -> handleInventoryListEvent ev + _ -> continueWithoutRedraw + +-- ---------------------------------------------- +-- HELPER UTILS +-- ---------------------------------------------- + +zoomInventory :: EventM Name UIInventory () -> EventM Name AppState () +zoomInventory act = Brick.zoom (uiState . uiGameplay . uiInventory) $ do + uiInventoryShouldUpdate .= True + act diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs new file mode 100644 index 000000000..b4dbe921a --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Here is the WorldPanel player configurable key event handler. +module Swarm.TUI.Controller.EventHandlers.World ( + worldEventHandlers, +) where + +import Brick hiding (Location) +import Brick.Keybindings +import Control.Lens +import Control.Monad (when) +import Data.Int (Int32) +import Linear +import Swarm.Game.Location +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Language.Syntax.Direction (Direction (..), directionSyntax) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Event +import Swarm.TUI.Model.UI + +-- | Handle a user input event in the world view panel. +worldEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +worldEventHandlers = allHandlers World $ \case + ViewBaseEvent -> ("View the base robot", viewBase) + ShowFpsEvent -> ("Show frames per second", showFps) + MoveViewEvent d -> ("Scroll world view in the " <> directionSyntax (DAbsolute d) <> " direction", scrollViewInDir $ toHeading d) + +viewBase :: EventM Name AppState () +viewBase = do + invalidateCacheEntry WorldCache + gameState . robotInfo . viewCenterRule .= VCRobot 0 + +showFps :: EventM Name AppState () +showFps = uiState . uiGameplay . uiTiming . uiShowFPS %= not + +scrollViewInDir :: V2 Int32 -> EventM Name AppState () +scrollViewInDir d = do + c <- use $ gameState . creativeMode + s <- use $ gameState . landscape . worldScrollable + when (c || s) $ scrollView (.+^ (worldScrollDist *^ d)) + +worldScrollDist :: Int32 +worldScrollDist = 8 + +-- | Manually scroll the world view. +scrollView :: (Location -> Location) -> EventM Name AppState () +scrollView update = do + -- Manually invalidate the 'WorldCache' instead of just setting + -- 'needsRedraw'. I don't quite understand why the latter doesn't + -- always work, but there seems to be some sort of race condition + -- where 'needsRedraw' gets reset before the UI drawing code runs. + invalidateCacheEntry WorldCache + gameState . robotInfo %= modifyViewCenter (fmap update) diff --git a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs new file mode 100644 index 000000000..1c97df99b --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs @@ -0,0 +1,118 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Collection of functions used to save the scenario metadata. +module Swarm.TUI.Controller.SaveScenario ( + saveScenarioInfoOnFinish, + saveScenarioInfoOnFinishNocheat, + saveScenarioInfoOnQuit, +) where + +-- See Note [liftA2 re-export from Prelude] +import Brick.Widgets.List qualified as BL +import Control.Lens as Lens +import Control.Monad (forM_, unless, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState) +import Data.Maybe (fromMaybe) +import Data.Time (getZonedTime) +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Scenario.Status (updateScenarioInfoOnFinish) +import Swarm.Game.ScenarioInfo +import Swarm.Game.State +import Swarm.Game.State.Runtime +import Swarm.Game.State.Substate +import Swarm.TUI.Model +import Swarm.TUI.Model.Achievements (attainAchievement') +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI +import System.FilePath (splitDirectories) +import Prelude hiding (Applicative (..)) + +getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) +getNormalizedCurrentScenarioPath = + -- the path should be normalized and good to search in scenario collection + use (gameState . currentScenarioPath) >>= \case + Nothing -> return Nothing + Just p' -> do + gs <- use $ runtimeState . scenarios + Just <$> liftIO (normalizeScenarioPath gs p') + +saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo) +saveScenarioInfoOnFinish p = do + initialRunCode <- use $ gameState . gameControls . initiallyRunCode + t <- liftIO getZonedTime + wc <- use $ gameState . winCondition + let won = case wc of + WinConditions (Won _ _) _ -> True + _ -> False + ts <- use $ gameState . temporal . ticks + + -- NOTE: This traversal is apparently not the same one as used by + -- the scenario selection menu, so the menu needs to be updated separately. + -- See Note [scenario menu update] + let currentScenarioInfo :: Traversal' AppState ScenarioInfo + currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2 + + replHist <- use $ uiState . uiGameplay . uiREPL . replHistory + let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput + currentScenarioInfo + %= updateScenarioInfoOnFinish determinator t ts won + status <- preuse currentScenarioInfo + case status of + Nothing -> return () + Just si -> do + let segments = splitDirectories p + case segments of + firstDir : _ -> do + when (won && firstDir == tutorialsDirname) $ + attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial) + _ -> return () + liftIO $ saveScenarioInfo p si + return status + +-- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit). +saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m () +saveScenarioInfoOnFinishNocheat = do + -- Don't save progress if we are in cheat mode + cheat <- use $ uiState . uiCheatMode + unless cheat $ do + -- the path should be normalized and good to search in scenario collection + getNormalizedCurrentScenarioPath >>= \case + Nothing -> return () + Just p -> void $ saveScenarioInfoOnFinish p + +-- | Write the @ScenarioInfo@ out to disk when exiting a game. +saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () +saveScenarioInfoOnQuit = do + -- Don't save progress if we are in cheat mode + -- NOTE This check is duplicated in "saveScenarioInfoOnFinishNocheat" + cheat <- use $ uiState . uiCheatMode + unless cheat $ do + getNormalizedCurrentScenarioPath >>= \case + Nothing -> return () + Just p -> do + maybeSi <- saveScenarioInfoOnFinish p + -- Note [scenario menu update] + -- Ensures that the scenario selection menu gets updated + -- with the high score/completion status + forM_ + maybeSi + ( uiState + . uiMenu + . _NewGameMenu + . ix 0 + . BL.listSelectedElementL + . _SISingle + . _2 + .= + ) + + -- See what scenario is currently focused in the menu. Depending on how the + -- previous scenario ended (via quit vs. via win), it might be the same as + -- currentScenarioPath or it might be different. + curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath + -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, + -- being sure to preserve the same focused scenario. + sc <- use $ runtimeState . scenarios + forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=) diff --git a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs new file mode 100644 index 000000000..8985c3cf1 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- The main TUI update logic that is called from other controller parts. +module Swarm.TUI.Controller.UpdateUI ( + updateUI, +) where + +import Brick hiding (Direction, Location) +import Brick.Focus + +-- See Note [liftA2 re-export from Prelude] +import Brick.Widgets.List qualified as BL +import Control.Applicative (liftA2, pure) +import Control.Lens as Lens +import Control.Monad (unless, when) +import Data.Foldable (toList) +import Data.List.Extra (enumerate) +import Data.Maybe (isNothing) +import Data.String (fromString) +import Data.Text qualified as T +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Robot +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Substate +import Swarm.Language.Pretty +import Swarm.Language.Typed (Typed (..)) +import Swarm.Language.Types +import Swarm.Language.Value (Value (VExc, VUnit), envTydefs, prettyValue) +import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnFinishNocheat) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Objective qualified as GR +import Witch (into) +import Prelude hiding (Applicative (..)) + +-- | Update the UI. This function is used after running the +-- game for some number of ticks. +updateUI :: EventM Name AppState Bool +updateUI = do + loadVisibleRegion + + -- If the game state indicates a redraw is needed, invalidate the + -- world cache so it will be redrawn. + g <- use gameState + when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache + + -- The hash of the robot whose inventory is currently displayed (if any) + listRobotHash <- fmap fst <$> use (uiState . uiGameplay . uiInventory . uiInventoryList) + + -- The hash of the focused robot (if any) + fr <- use (gameState . to focusedRobot) + let focusedRobotHash = view inventoryHash <$> fr + + -- Check if the inventory list needs to be updated. + shouldUpdate <- use (uiState . uiGameplay . uiInventory . uiInventoryShouldUpdate) + + -- Whether the focused robot is too far away to sense, & whether + -- that has recently changed + dist <- use (gameState . to focusedRange) + farOK <- liftA2 (||) (use (gameState . creativeMode)) (use (gameState . landscape . worldScrollable)) + let tooFar = not farOK && dist == Just Far + farChanged = tooFar /= isNothing listRobotHash + + -- If the robot moved in or out of range, or hashes don't match + -- (either because which robot (or whether any robot) is focused + -- changed, or the focused robot's inventory changed), or the + -- inventory was flagged to be updated, regenerate the inventory list. + inventoryUpdated <- + if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate + then do + Brick.zoom (uiState . uiGameplay . uiInventory) $ do + populateInventoryList $ if tooFar then Nothing else fr + uiInventoryShouldUpdate .= False + pure True + else pure False + + -- Now check if the base finished running a program entered at the REPL. + replUpdated <- case g ^. gameControls . replStatus of + REPLWorking pty (Just v) + -- It did, and the result was the unit value or an exception. Just reset replStatus. + | v `elem` [VUnit, VExc] -> do + gameState . gameControls . replStatus .= REPLDone (Just (pty, v)) + pure True + + -- It did, and returned some other value. Create new 'it' + -- variables, pretty-print the result as a REPL output, with its + -- type, and reset the replStatus. + | otherwise -> do + itIx <- use (gameState . gameControls . replNextValueIndex) + env <- use (gameState . baseEnv) + let finalType = stripCmd (env ^. envTydefs) pty + itName = fromString $ "it" ++ show itIx + out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] + uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLOutput out) + invalidateCacheEntry REPLHistoryCache + vScrollToEnd replScroll + gameState . gameControls . replStatus .= REPLDone (Just (finalType, v)) + gameState . baseEnv . at itName .= Just (Typed v finalType mempty) + gameState . baseEnv . at "it" .= Just (Typed v finalType mempty) + gameState . gameControls . replNextValueIndex %= (+ 1) + pure True + + -- Otherwise, do nothing. + _ -> pure False + + -- If the focused robot's log has been updated and the UI focus + -- isn't currently on the inventory or info panels, attempt to + -- automatically switch to the logger and scroll all the way down so + -- the new message can be seen. + uiState . uiGameplay . uiScrollToEnd .= False + logUpdated <- do + -- If the inventory or info panels are currently focused, it would + -- be rude to update them right under the user's nose, so consider + -- them "sticky". They will be updated as soon as the player moves + -- the focus away. + fring <- use $ uiState . uiGameplay . uiFocusRing + let sticky = focusGetCurrent fring `elem` map (Just . FocusablePanel) [RobotPanel, InfoPanel] + + -- Check if the robot log was updated and we are allowed to change + -- the inventory+info panels. + case maybe False (view robotLogUpdated) fr && not sticky of + False -> pure False + True -> do + -- Reset the log updated flag + zoomGameState $ zoomRobots clearFocusedRobotLogUpdated + + -- Find and focus an equipped "logger" device in the inventory list. + let isLogger (EquippedEntry e) = e ^. entityName == "logger" + isLogger _ = False + focusLogger = BL.listFindBy isLogger + + uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 %= focusLogger + + -- Now inform the UI that it should scroll the info panel to + -- the very end. + uiState . uiGameplay . uiScrollToEnd .= True + pure True + + goalOrWinUpdated <- doGoalUpdates + + let redraw = + g ^. needsRedraw + || inventoryUpdated + || replUpdated + || logUpdated + || goalOrWinUpdated + pure redraw + +-- | Either pops up the updated Goals modal +-- or pops up the Congratulations (Win) modal, or pops +-- up the Condolences (Lose) modal. +-- The Win modal will take precedence if the player +-- has met the necessary conditions to win the game. +-- +-- If the player chooses to "Keep Playing" from the Win modal, the +-- updated Goals will then immediately appear. +-- This is desirable for: +-- * feedback as to the final goal the player accomplished, +-- * as a summary of all of the goals of the game +-- * shows the player more "optional" goals they can continue to pursue +doGoalUpdates :: EventM Name AppState Bool +doGoalUpdates = do + curGoal <- use (uiState . uiGameplay . uiGoal . goalsContent) + isCheating <- use (uiState . uiCheatMode) + curWinCondition <- use (gameState . winCondition) + announcementsSeq <- use (gameState . messageInfo . announcementQueue) + let announcementsList = toList announcementsSeq + + -- Decide whether we need to update the current goal text and pop + -- up a modal dialog. + case curWinCondition of + NoWinCondition -> return False + WinConditions (Unwinnable False) x -> do + -- This clears the "flag" that the Lose dialog needs to pop up + gameState . winCondition .= WinConditions (Unwinnable True) x + openModal $ ScenarioEndModal LoseModal + saveScenarioInfoOnFinishNocheat + return True + WinConditions (Won False ts) x -> do + -- This clears the "flag" that the Win dialog needs to pop up + gameState . winCondition .= WinConditions (Won True ts) x + openModal $ ScenarioEndModal WinModal + saveScenarioInfoOnFinishNocheat + -- We do NOT advance the New Game menu to the next item here (we + -- used to!), because we do not know if the user is going to + -- select 'keep playing' or 'next challenge'. We maintain the + -- invariant that the current menu item is always the same as + -- the scenario currently being played. If the user either (1) + -- quits to the menu or (2) selects 'next challenge' we will + -- advance the menu at that point. + return True + WinConditions _ oc -> do + let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc + -- The "uiGoal" field is initialized with empty members, so we know that + -- this will be the first time showing it if it will be nonempty after previously + -- being empty. + isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal) + goalWasUpdated = isFirstGoalDisplay || not (null announcementsList) + + -- Decide whether to show a pop-up modal congratulating the user on + -- successfully completing the current challenge. + when goalWasUpdated $ do + let hasMultiple = hasMultipleGoals newGoalTracking + defaultFocus = + if hasMultiple + then ObjectivesList + else GoalSummary + + ring = + focusRing $ + map GoalWidgets $ + if hasMultiple + then enumerate + else [GoalSummary] + + -- The "uiGoal" field is necessary at least to "persist" the data that is needed + -- if the player chooses to later "recall" the goals dialog with CTRL+g. + uiState + . uiGameplay + . uiGoal + .= GoalDisplay + newGoalTracking + (GR.makeListWidget newGoalTracking) + (focusSetCurrent (GoalWidgets defaultFocus) ring) + + -- This clears the "flag" that indicate that the goals dialog needs to be + -- automatically popped up. + gameState . messageInfo . announcementQueue .= mempty + + hideGoals <- use $ uiState . uiGameplay . uiHideGoals + unless hideGoals $ + openModal GoalModal + + return goalWasUpdated + +-- | Strips the top-level @Cmd@ from a type, if any (to compute the +-- result type of a REPL command evaluation). +stripCmd :: TDCtx -> Polytype -> Polytype +stripCmd tdCtx (Forall xs ty) = case whnfType tdCtx ty of + TyCmd resTy -> Forall xs resTy + _ -> Forall xs ty diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index 31961b661..3dadac994 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -6,25 +6,37 @@ module Swarm.TUI.Controller.Util where import Brick hiding (Direction) import Brick.Focus -import Control.Lens -import Control.Monad (forM_, unless) -import Control.Monad.IO.Class (liftIO) +import Brick.Keybindings +import Control.Carrier.Lift qualified as Fused +import Control.Carrier.State.Lazy qualified as Fused +import Control.Lens as Lens +import Control.Monad (forM_, unless, when) +import Control.Monad.IO.Class (MonadIO (liftIO), liftIO) +import Control.Monad.State (MonadState, execState) +import Data.List.Extra (enumerate) import Data.Map qualified as M import Data.Set qualified as S +import Data.Text (Text) import Graphics.Vty qualified as V +import Swarm.Effect (TimeIOC, runTimeIO) +import Swarm.Game.CESK (continue) import Swarm.Game.Device import Swarm.Game.Robot (robotCapabilities) +import Swarm.Game.Robot.Concrete import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Substate +import Swarm.Game.Step (finishGameTick) import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.Game.World.Coords import Swarm.Language.Capability (Capability (CDebug)) +import Swarm.Language.Syntax hiding (Key) import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) +import System.Clock (Clock (..), getTime) -- | Pattern synonyms to simplify brick event handler pattern Key :: V.Key -> BrickEvent n e @@ -66,8 +78,7 @@ openModal mt = do -- Set the game to AutoPause if needed ensurePause = do pause <- use $ gameState . temporal . paused - unless (pause || isRunningModal mt) $ do - gameState . temporal . runStatus .= AutoPause + unless (pause || isRunningModal mt) $ gameState . temporal . runStatus .= AutoPause -- | The running modals do not autopause the game. isRunningModal :: ModalType -> Bool @@ -76,6 +87,36 @@ isRunningModal = \case MessagesModal -> True _ -> False +-- | Set the game to Running if it was (auto) paused otherwise to paused. +-- +-- Also resets the last frame time to now. If we are pausing, it +-- doesn't matter; if we are unpausing, this is critical to +-- ensure the next frame doesn't think it has to catch up from +-- whenever the game was paused! +safeTogglePause :: EventM Name AppState () +safeTogglePause = do + curTime <- liftIO $ getTime Monotonic + uiState . uiGameplay . uiTiming . lastFrameTime .= curTime + uiState . uiGameplay . uiShowDebug .= False + p <- gameState . temporal . runStatus Lens.<%= toggleRunStatus + when (p == Running) $ zoomGameState finishGameTick + +-- | Only unpause the game if leaving autopaused modal. +-- +-- Note that the game could have been paused before opening +-- the modal, in that case, leave the game paused. +safeAutoUnpause :: EventM Name AppState () +safeAutoUnpause = do + runs <- use $ gameState . temporal . runStatus + when (runs == AutoPause) safeTogglePause + +toggleModal :: ModalType -> EventM Name AppState () +toggleModal mt = do + modal <- use $ uiState . uiGameplay . uiModal + case modal of + Nothing -> openModal mt + Just _ -> uiState . uiGameplay . uiModal .= Nothing >> safeAutoUnpause + setFocus :: FocusablePanel -> EventM Name AppState () setFocus name = uiState . uiGameplay . uiFocusRing %= focusSetCurrent (FocusablePanel name) @@ -117,3 +158,41 @@ resetViewport :: ViewportScroll Name -> EventM Name AppState () resetViewport n = do vScrollToBeginning n hScrollToBeginning n + +-- | Modifies the game state using a fused-effect state action. +zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> m a +zoomGameState f = do + gs <- use gameState + (gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f))) + gameState .= gs' + return a + +onlyCreative :: (MonadState AppState m) => m () -> m () +onlyCreative a = do + c <- use $ gameState . creativeMode + when c a + +-- | Create a list of handlers with embedding events and using pattern matching. +allHandlers :: + (Ord e2, Enum e1, Bounded e1) => + (e1 -> e2) -> + (e1 -> (Text, EventM Name AppState ())) -> + [KeyEventHandler e2 (EventM Name AppState)] +allHandlers eEmbed f = map handleEvent1 enumerate + where + handleEvent1 e1 = let (n, a) = f e1 in onEvent (eEmbed e1) n a + +runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () +runBaseTerm = maybe (pure ()) startBaseProgram + where + -- The player typed something at the REPL and hit Enter; this + -- function takes the resulting term (if the REPL + -- input is valid) and sets up the base robot to run it. + startBaseProgram t = do + -- Set the REPL status to Working + gameState . gameControls . replStatus .= REPLWorking (t ^. sType) Nothing + -- Set up the robot's CESK machine to evaluate/execute the + -- given term. + gameState . baseRobot . machine %= continue t + -- Finally, be sure to activate the base robot. + gameState %= execState (zoomRobots $ activateRobot 0) diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 846632864..0eebb453e 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -47,11 +47,17 @@ module Swarm.TUI.Model ( -- ** Utility logEvent, + SwarmKeyDispatcher, + KeyEventHandlingState (KeyEventHandlingState), + SwarmKeyDispatchers (..), + keyConfig, + keyDispatchers, -- * App state AppState (AppState), gameState, uiState, + keyEventHandling, runtimeState, -- ** Initialization @@ -67,7 +73,8 @@ module Swarm.TUI.Model ( nextScenario, ) where -import Brick +import Brick (EventM, ViewportScroll, viewportScroll) +import Brick.Keybindings as BK import Brick.Widgets.List qualified as BL import Control.Lens hiding (from, (<.>)) import Control.Monad ((>=>)) @@ -92,6 +99,7 @@ import Swarm.Game.Tick (TickNumber (..)) import Swarm.Game.World.Gen (Seed) import Swarm.Log import Swarm.TUI.Inventory.Sorting +import Swarm.TUI.Model.Event (SwarmEvent) import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name import Swarm.TUI.Model.UI @@ -139,6 +147,20 @@ logEvent src sev who msg el = where l = LogEntry (TickNumber 0) src sev who msg +data KeyEventHandlingState = KeyEventHandlingState + { _keyConfig :: KeyConfig SwarmEvent + , _keyDispatchers :: SwarmKeyDispatchers + } + +type SwarmKeyDispatcher = KeyDispatcher SwarmEvent (EventM Name AppState) + +data SwarmKeyDispatchers = SwarmKeyDispatchers + { mainGameDispatcher :: SwarmKeyDispatcher + , replDispatcher :: SwarmKeyDispatcher + , worldDispatcher :: SwarmKeyDispatcher + , robotDispatcher :: SwarmKeyDispatcher + } + -- ---------------------------------------------------------------------------- -- APPSTATE -- -- ---------------------------------------------------------------------------- @@ -151,44 +173,10 @@ logEvent src sev who msg el = data AppState = AppState { _gameState :: GameState , _uiState :: UIState + , _keyEventHandling :: KeyEventHandlingState , _runtimeState :: RuntimeState } --------------------------------------------------- --- Lenses for AppState - -makeLensesNoSigs ''AppState - --- | The 'GameState' record. -gameState :: Lens' AppState GameState - --- | The 'UIState' record. -uiState :: Lens' AppState UIState - --- | The 'RuntimeState' record -runtimeState :: Lens' AppState RuntimeState - --------------------------------------------------- --- Utility functions - --- | Get the currently focused 'InventoryListEntry' from the robot --- info panel (if any). -focusedItem :: AppState -> Maybe InventoryListEntry -focusedItem s = do - list <- s ^? uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 - (_, entry) <- BL.listSelectedElement list - return entry - --- | Get the currently focused entity from the robot info panel (if --- any). This is just like 'focusedItem' but forgets the --- distinction between plain inventory items and equipped devices. -focusedEntity :: AppState -> Maybe Entity -focusedEntity = - focusedItem >=> \case - Separator _ -> Nothing - InventoryEntry _ e -> Just e - EquippedEntry e -> Just e - ------------------------------------------------------------ -- Functions for updating the UI state ------------------------------------------------------------ @@ -303,3 +291,52 @@ nextScenario = \case then Nothing else BL.listSelectedElement nextMenuList >>= preview _SISingle . snd _ -> Nothing + +-------------------------------------------------- +-- Lenses for KeyEventHandlingState + +makeLensesNoSigs ''KeyEventHandlingState + +-- | Keybindings (possibly customized by player) for 'SwarmEvent's. +keyConfig :: Lens' KeyEventHandlingState (KeyConfig SwarmEvent) + +-- | Dispatchers that will call handler on key combo. +keyDispatchers :: Lens' KeyEventHandlingState SwarmKeyDispatchers + +-------------------------------------------------- +-- Lenses for AppState + +makeLensesNoSigs ''AppState + +-- | The 'GameState' record. +gameState :: Lens' AppState GameState + +-- | The 'UIState' record. +uiState :: Lens' AppState UIState + +-- | The key event handling configuration. +keyEventHandling :: Lens' AppState KeyEventHandlingState + +-- | The 'RuntimeState' record +runtimeState :: Lens' AppState RuntimeState + +-------------------------------------------------- +-- Utility functions + +-- | Get the currently focused 'InventoryListEntry' from the robot +-- info panel (if any). +focusedItem :: AppState -> Maybe InventoryListEntry +focusedItem s = do + list <- s ^? uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 + (_, entry) <- BL.listSelectedElement list + return entry + +-- | Get the currently focused entity from the robot info panel (if +-- any). This is just like 'focusedItem' but forgets the +-- distinction between plain inventory items and equipped devices. +focusedEntity :: AppState -> Maybe Entity +focusedEntity = + focusedItem >=> \case + Separator _ -> Nothing + InventoryEntry _ e -> Just e + EquippedEntry e -> Just e diff --git a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs new file mode 100644 index 000000000..a444313a7 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs @@ -0,0 +1,39 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Collection of helper functions for managing achievements in other controllers. +module Swarm.TUI.Model.Achievements ( + attainAchievement, + attainAchievement', +) where + +import Control.Lens hiding (from, (<.>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState) +import Data.Map qualified as M +import Data.Time (ZonedTime, getZonedTime) +import Swarm.Game.Achievement.Attainment +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Achievement.Persistence +import Swarm.TUI.Model +import Swarm.TUI.Model.UI + +attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m () +attainAchievement a = do + currentTime <- liftIO getZonedTime + attainAchievement' currentTime Nothing a + +attainAchievement' :: + (MonadIO m, MonadState AppState m) => + ZonedTime -> + Maybe FilePath -> + CategorizedAchievement -> + m () +attainAchievement' t p a = do + (uiState . uiAchievements) + %= M.insertWith + (<>) + a + (Attainment a p t) + newAchievements <- use $ uiState . uiAchievements + liftIO $ saveAchievementsInfo $ M.elems newAchievements diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs new file mode 100644 index 000000000..89087e727 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sum types representing the Swarm events +-- abstracted away from keybindings. +module Swarm.TUI.Model.Event ( + SwarmEvent (..), + MainEvent (..), + REPLEvent (..), + WorldEvent (..), + RobotEvent (..), + swarmEvents, + defaultSwarmBindings, +) where + +import Brick.Keybindings +import Control.Arrow ((&&&)) +import Data.Bifunctor (first) +import Data.List.Extra (enumerate) +import Data.Text (Text) +import Graphics.Vty qualified as V +import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..), directionSyntax) + +-- See Note [how Swarm event handlers work] + +data SwarmEvent + = Main MainEvent + | REPL REPLEvent + | World WorldEvent + | Robot RobotEvent + deriving (Eq, Ord, Show) + +swarmEvents :: KeyEvents SwarmEvent +swarmEvents = + keyEvents $ + concat + [ embed Main mainEvents + , embed REPL replEvents + , embed World worldPanelEvents + , embed Robot robotPanelEvents + ] + where + embed f = map (fmap f) . keyEventsList + +defaultSwarmBindings :: [(SwarmEvent, [Binding])] +defaultSwarmBindings = + concat + [ embed Main defaultMainBindings + , embed REPL defaultReplBindings + , embed World defaultWorldPanelBindings + , embed Robot defaultRobotPanelBindings + ] + where + embed = map . first + +-- ---------------------------------------------- +-- MAIN EVENTS +-- ---------------------------------------------- + +-- | Main abstract keybinding events while running the game itself. +-- +-- See 'Swarm.TUI.Controller.MainEventHandler.'. +data MainEvent + = QuitEvent + | ViewHelpEvent + | ViewRobotsEvent + | ViewRecipesEvent + | ViewCommandsEvent + | ViewMessagesEvent + | ViewStructuresEvent + | ViewGoalEvent + | HideRobotsEvent + | ShowCESKDebugEvent + | PauseEvent + | RunSingleTickEvent + | IncreaseTpsEvent + | DecreaseTpsEvent + | FocusWorldEvent + | FocusRobotEvent + | FocusREPLEvent + | FocusInfoEvent + | ToggleCreativeModeEvent + | ToggleWorldEditorEvent + | ToggleREPLVisibilityEvent + deriving (Eq, Ord, Show, Enum, Bounded) + +mainEvents :: KeyEvents MainEvent +mainEvents = allKeyEvents $ \case + QuitEvent -> "quit" + ViewHelpEvent -> "view help" + ViewRobotsEvent -> "view robots" + ViewRecipesEvent -> "view recipes" + ViewCommandsEvent -> "view commands" + ViewMessagesEvent -> "view messages" + ViewStructuresEvent -> "view structures" + ViewGoalEvent -> "view goal" + HideRobotsEvent -> "hide robots" + ShowCESKDebugEvent -> "debug CESK" + PauseEvent -> "pause" + RunSingleTickEvent -> "run single tick" + IncreaseTpsEvent -> "increse TPS" + DecreaseTpsEvent -> "decrease TPS" + FocusWorldEvent -> "focus World" + FocusRobotEvent -> "focus Robot" + FocusREPLEvent -> "focus REPL" + FocusInfoEvent -> "focus Info" + ToggleCreativeModeEvent -> "creative mode" + ToggleWorldEditorEvent -> "world editor" + ToggleREPLVisibilityEvent -> "toggle REPL" + +defaultMainBindings :: [(MainEvent, [Binding])] +defaultMainBindings = allBindings $ \case + QuitEvent -> [ctrl 'q'] + ViewHelpEvent -> [fn 1] + ViewRobotsEvent -> [fn 2] + ViewRecipesEvent -> [fn 3] + ViewCommandsEvent -> [fn 4] + ViewMessagesEvent -> [fn 5] + ViewStructuresEvent -> [fn 6] + ViewGoalEvent -> [ctrl 'g'] + HideRobotsEvent -> [meta 'h'] + ShowCESKDebugEvent -> [meta 'd'] + PauseEvent -> [ctrl 'p'] + RunSingleTickEvent -> [ctrl 'o'] + IncreaseTpsEvent -> [ctrl 'x'] + DecreaseTpsEvent -> [ctrl 'z'] + FocusWorldEvent -> [meta 'w'] + FocusRobotEvent -> [meta 'e'] + FocusREPLEvent -> [meta 'r'] + FocusInfoEvent -> [meta 't'] + ToggleCreativeModeEvent -> [ctrl 'v'] + ToggleWorldEditorEvent -> [] + ToggleREPLVisibilityEvent -> [meta ','] + +-- ---------------------------------------------- +-- REPL EVENTS +-- ---------------------------------------------- + +-- | REPL abstract keybinding events. +-- +-- See 'Swarm.TUI.Controller.REPLEventHandler'. +data REPLEvent + = CancelRunningProgramEvent + | TogglePilotingModeEvent + | ToggleCustomKeyHandlingEvent + deriving (Eq, Ord, Show, Enum, Bounded) + +replEvents :: KeyEvents REPLEvent +replEvents = allKeyEvents $ \case + CancelRunningProgramEvent -> "cancel running program" + ToggleCustomKeyHandlingEvent -> "toggle custom key handling" + TogglePilotingModeEvent -> "toggle piloting mode" + +defaultReplBindings :: [(REPLEvent, [Binding])] +defaultReplBindings = allBindings $ \case + CancelRunningProgramEvent -> [ctrl 'c', bind V.KEsc] + TogglePilotingModeEvent -> [meta 'p'] + ToggleCustomKeyHandlingEvent -> [meta 'k'] + +-- ---------------------------------------------- +-- REPL EVENTS +-- ---------------------------------------------- + +data WorldEvent + = ViewBaseEvent + | ShowFpsEvent + | MoveViewEvent AbsoluteDir + deriving (Eq, Ord, Show) + +instance Enum WorldEvent where + fromEnum = \case + ViewBaseEvent -> 0 + ShowFpsEvent -> 1 + MoveViewEvent d -> 2 + fromEnum d + toEnum = \case + 0 -> ViewBaseEvent + 1 -> ShowFpsEvent + n -> MoveViewEvent . toEnum $ n - 2 + +instance Bounded WorldEvent where + minBound = ViewBaseEvent + maxBound = MoveViewEvent maxBound + +worldPanelEvents :: KeyEvents WorldEvent +worldPanelEvents = allKeyEvents $ \case + ViewBaseEvent -> "view base" + ShowFpsEvent -> "show fps" + MoveViewEvent d -> "move view " <> directionSyntax (DAbsolute d) + +defaultWorldPanelBindings :: [(WorldEvent, [Binding])] +defaultWorldPanelBindings = allBindings $ \case + ViewBaseEvent -> [bind 'c'] + ShowFpsEvent -> [bind 'f'] + MoveViewEvent DWest -> [bind V.KLeft, bind 'h'] + MoveViewEvent DSouth -> [bind V.KDown, bind 'j'] + MoveViewEvent DNorth -> [bind V.KUp, bind 'k'] + MoveViewEvent DEast -> [bind V.KRight, bind 'l'] + +-- ---------------------------------------------- +-- ROBOT EVENTS +-- ---------------------------------------------- + +data RobotEvent + = MakeEntityEvent + | ShowZeroInventoryEntitiesEvent + | CycleInventorySortEvent + | SwitchInventorySortDirection + | SearchInventoryEvent + deriving (Eq, Ord, Show, Enum, Bounded) + +robotPanelEvents :: KeyEvents RobotEvent +robotPanelEvents = allKeyEvents $ \case + MakeEntityEvent -> "make entity" + ShowZeroInventoryEntitiesEvent -> "show zero inventory entities" + CycleInventorySortEvent -> "cycle inventory sort" + SwitchInventorySortDirection -> "switch inventory direction" + SearchInventoryEvent -> "search inventory" + +defaultRobotPanelBindings :: [(RobotEvent, [Binding])] +defaultRobotPanelBindings = allBindings $ \case + MakeEntityEvent -> [bind 'm'] + ShowZeroInventoryEntitiesEvent -> [bind '0'] + CycleInventorySortEvent -> [bind ';'] + SwitchInventorySortDirection -> [bind ':'] + SearchInventoryEvent -> [bind '/'] + +-- ---------------- +-- Helper methods + +allKeyEvents :: (Ord e, Bounded e, Enum e) => (e -> Text) -> KeyEvents e +allKeyEvents f = keyEvents $ map (f &&& id) enumerate + +allBindings :: (Bounded e, Enum e) => (e -> [Binding]) -> [(e, [Binding])] +allBindings f = map (\e -> (e, f e)) enumerate diff --git a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs new file mode 100644 index 000000000..2c2e52261 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Load and show Swarm keybindings. +-- +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Model.KeyBindings ( + initKeyHandlingState, + KeybindingPrint (..), + showKeybindings, + handlerNameKeysDescription, +) where + +import Brick +import Brick.Keybindings as BK +import Control.Carrier.Lift (runM) +import Control.Carrier.Throw.Either (runThrow) +import Control.Effect.Accum +import Control.Effect.Lift +import Control.Effect.Throw +import Control.Lens hiding (from, (<.>)) +import Data.Bifunctor (second) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Game.Failure (Asset (..), LoadingFailure (..), SystemFailure (..)) +import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) +import Swarm.Language.Pretty (prettyText) +import Swarm.TUI.Controller.EventHandlers +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents) + +-- See Note [how Swarm event handlers work] + +loadKeybindingConfig :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m [(SwarmEvent, BindingState)] +loadKeybindingConfig = do + (iniExists, ini) <- sendIO getSwarmConfigIniFile + if not iniExists + then return [] + else do + loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini + case loadedCustomBindings of + Left e -> throwError $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e) + Right bs -> pure $ fromMaybe [] bs + +initKeyHandlingState :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m KeyEventHandlingState +initKeyHandlingState = do + customBindings <- loadKeybindingConfig + let cfg = newKeyConfig swarmEvents defaultSwarmBindings customBindings + dispatchers <- createKeyDispatchers cfg + return $ KeyEventHandlingState cfg dispatchers + +data KeybindingPrint = MarkdownPrint | TextPrint | IniPrint + deriving (Eq, Ord, Show) + +showKeybindings :: KeybindingPrint -> IO Text +showKeybindings kPrint = do + bindings <- runM $ runThrow @SystemFailure initKeyHandlingState + pure $ case bindings of + Left e -> prettyText e + Right bs -> showTable kPrint (bs ^. keyConfig) keySections + where + showTable = \case + MarkdownPrint -> keybindingMarkdownTable + TextPrint -> keybindingTextTable + IniPrint -> keybindingINI + +keySections :: [(Text, [KeyEventHandler SwarmEvent (EventM Name AppState)])] +keySections = + [ ("Main game (always active)", mainEventHandlers) + , ("REPL panel", replEventHandlers) + , ("World view panel", worldEventHandlers) + , ("Robot inventory panel", robotEventHandlers) + ] + +keybindingINI :: Ord k => KeyConfig k -> [(Text, [KeyEventHandler k m])] -> Text +keybindingINI kc sections = + T.intercalate "\n" $ + "[keybindings]\n" + : "; Uncomment the assignment and set comma separated list" + : "; of keybindings or \"unbound\" on the right. See:" + : "; https://hackage.haskell.org/package/brick/docs/Brick-Keybindings-Parse.html#v:parseBinding\n" + : concatMap sectionsINI handlersData + where + handlersData = map (second $ mapMaybe handlerData) sections + handlerData h = case kehEventTrigger h of + ByKey _ -> Nothing + ByEvent k -> Just (k, handlerDescription $ kehHandler h) + section s = "\n;;;; " <> s <> "\n" + sectionsINI (s, hs) = section s : map (keyBindingEventINI kc) hs + +keyBindingEventINI :: Ord k => KeyConfig k -> (k, Text) -> Text +keyBindingEventINI kc (ev, description) = + T.unlines + [ ";; " <> description + , commentDefault <> name <> " = " <> bindingList + ] + where + commentDefault = if custom then "" else "; " + (custom, bindingList) = case lookupKeyConfigBindings kc ev of + Just Unbound -> (True, "unbound") + Just (BindingList bs) -> (True, listBindings bs) + Nothing -> + ( False + , if null (allDefaultBindings kc ev) + then "unbound" + else listBindings $ allDefaultBindings kc ev + ) + listBindings = T.intercalate "," . fmap ppBinding + name = case keyEventName (keyConfigEvents kc) ev of + Just n -> n + Nothing -> error $ "unnamed event: " <> T.unpack description + +handlerNameKeysDescription :: Ord k => KeyConfig k -> KeyEventHandler k m -> (Text, Text, Text) +handlerNameKeysDescription kc keh = (name, keys, desc) + where + desc = handlerDescription $ kehHandler keh + (name, keys) = case kehEventTrigger keh of + ByKey b -> ("(non-customizable key)", ppBinding b) + ByEvent ev -> + let name' = fromMaybe "(unnamed)" $ keyEventName (keyConfigEvents kc) ev + in case lookupKeyConfigBindings kc ev of + Nothing -> + if not (null (allDefaultBindings kc ev)) + then (name', T.intercalate "," $ ppBinding <$> allDefaultBindings kc ev) + else (name', "unbound") + Just Unbound -> + (name', "unbound") + Just (BindingList bs) -> + let result = + if not (null bs) + then T.intercalate "," $ ppBinding <$> bs + else "unbound" + in (name', result) diff --git a/src/swarm-tui/Swarm/TUI/Model/Menu.hs b/src/swarm-tui/Swarm/TUI/Model/Menu.hs index 83c5356e1..793a8f9b0 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Menu.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Menu.hs @@ -41,7 +41,7 @@ import Witch (into) ------------------------------------------------------------ data ScenarioOutcome = WinModal | LoseModal - deriving (Show) + deriving (Show, Eq) data ModalType = HelpModal @@ -57,7 +57,7 @@ data ModalType | KeepPlayingModal | DescriptionModal Entity | GoalModal - deriving (Show) + deriving (Show, Eq) data ButtonAction = Cancel diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 16811ea3c..f76b9a965 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -41,11 +41,8 @@ import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq) import Data.Text (Text) -import Data.Time (ZonedTime, getZonedTime) -import Swarm.Game.Achievement.Attainment -import Swarm.Game.Achievement.Definitions -import Swarm.Game.Achievement.Persistence -import Swarm.Game.Failure (SystemFailure) +import Data.Time (getZonedTime) +import Swarm.Game.Failure (SystemFailure (..)) import Swarm.Game.Land import Swarm.Game.Scenario ( ScenarioInputs (..), @@ -81,7 +78,9 @@ import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Launch.Model (toSerializableParams) import Swarm.TUI.Model +import Swarm.TUI.Model.Achievements import Swarm.TUI.Model.Goal (emptyGoalDisplay) +import Swarm.TUI.Model.KeyBindings import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl import Swarm.TUI.Model.Structure @@ -98,8 +97,8 @@ initAppState :: AppOpts -> m AppState initAppState opts = do - (rs, ui) <- initPersistentState opts - constructAppState rs ui opts + (rs, ui, keyHandling) <- initPersistentState opts + constructAppState rs ui keyHandling opts -- | Add some system failures to the list of messages in the -- 'RuntimeState'. @@ -122,14 +121,15 @@ skipMenu AppOpts {..} = isJust userScenario || isRunningInitialProgram || isJust initPersistentState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => AppOpts -> - m (RuntimeState, UIState) + m (RuntimeState, UIState, KeyEventHandlingState) initPersistentState opts@(AppOpts {..}) = do - (warnings :: Seq SystemFailure, (initRS, initUI)) <- runAccum mempty $ do + (warnings :: Seq SystemFailure, (initRS, initUI, initKs)) <- runAccum mempty $ do rs <- initRuntimeState ui <- initUIState speed (not (skipMenu opts)) cheatMode - return (rs, ui) + ks <- initKeyHandlingState + return (rs, ui, ks) let initRS' = addWarnings initRS (F.toList warnings) - return (initRS', initUI) + return (initRS', initUI, initKs) -- | Construct an 'AppState' from an already-loaded 'RuntimeState' and -- 'UIState', given the 'AppOpts' the app was started with. @@ -137,12 +137,13 @@ constructAppState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => RuntimeState -> UIState -> + KeyEventHandlingState -> AppOpts -> m AppState -constructAppState rs ui opts@(AppOpts {..}) = do +constructAppState rs ui key opts@(AppOpts {..}) = do let gs = initGameState $ rs ^. stdGameConfigInputs case skipMenu opts of - False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs + False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) key rs True -> do let tem = gs ^. landscape . terrainAndEntities (scenario, path) <- @@ -164,7 +165,7 @@ constructAppState rs ui opts@(AppOpts {..}) = do sendIO $ execStateT (startGameWithSeed (scenario, si) $ LaunchParams (pure userSeed) (pure codeToRun)) - (AppState gs ui newRs) + (AppState gs ui key newRs) -- | Load a 'Scenario' and start playing the game. startGame :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe CodeToRun -> m () @@ -235,26 +236,6 @@ scenarioToAppState siPair@(scene, _) lp = do l .= x' return x' -attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m () -attainAchievement a = do - currentTime <- liftIO getZonedTime - attainAchievement' currentTime Nothing a - -attainAchievement' :: - (MonadIO m, MonadState AppState m) => - ZonedTime -> - Maybe FilePath -> - CategorizedAchievement -> - m () -attainAchievement' t p a = do - (uiState . uiAchievements) - %= M.insertWith - (<>) - a - (Attainment a p t) - newAchievements <- use $ uiState . uiAchievements - liftIO $ saveAchievementsInfo $ M.elems newAchievements - -- | Modify the UI state appropriately when starting a new scenario. scenarioToUIState :: Bool -> diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index 2220a1503..0d749b448 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -36,6 +36,7 @@ module Swarm.TUI.View ( import Brick hiding (Direction, Location) import Brick.Focus import Brick.Forms +import Brick.Keybindings (Binding (..), firstActiveBinding, ppBinding) import Brick.Widgets.Border ( hBorder, hBorderWithLabel, @@ -69,6 +70,7 @@ import Data.Set qualified as Set (toList) import Data.Text (Text) import Data.Text qualified as T import Data.Time (NominalDiffTime, defaultTimeLocale, formatTime) +import Graphics.Vty qualified as V import Linear import Network.Wai.Handler.Warp (Port) import Numeric (showFFloat) @@ -125,6 +127,7 @@ import Swarm.Language.Typecheck (inferConst) import Swarm.Log import Swarm.TUI.Border import Swarm.TUI.Controller (ticksPerFrameCap) +import Swarm.TUI.Controller.EventHandlers (allEventHandlers, mainEventHandlers, replEventHandlers, robotEventHandlers, worldEventHandlers) import Swarm.TUI.Controller.Util (hasDebugCapability) import Swarm.TUI.Editor.Model import Swarm.TUI.Editor.View qualified as EV @@ -132,7 +135,10 @@ import Swarm.TUI.Inventory.Sorting (renderSortMethod) import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.View import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent) +import Swarm.TUI.Model.Event qualified as SE import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow) +import Swarm.TUI.Model.KeyBindings (handlerNameKeysDescription) import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI import Swarm.TUI.Panel @@ -623,7 +629,7 @@ drawDialog s = case s ^. uiState . uiGameplay . uiModal of -- | Draw one of the various types of modal dialog. drawModal :: AppState -> ModalType -> Widget Name drawModal s = \case - HelpModal -> helpWidget (s ^. gameState . randomness . seed) (s ^. runtimeState . webPort) + HelpModal -> helpWidget (s ^. gameState . randomness . seed) (s ^. runtimeState . webPort) (s ^. keyEventHandling) RobotsModal -> robotsListWidget s RecipesModal -> availableListWidget (s ^. gameState) RecipeList CommandsModal -> commandsListWidget (s ^. gameState) @@ -782,59 +788,53 @@ robotsListWidget s = hCenter table debugging = creative && cheat g = s ^. gameState -helpWidget :: Seed -> Maybe Port -> Widget Name -helpWidget theSeed mport = - padTop (Pad 1) $ - (hBox . map (padLeftRight 2) $ [helpKeys, info]) - <=> padTop (Pad 1) (hCenter tips) +helpWidget :: Seed -> Maybe Port -> KeyEventHandlingState -> Widget Name +helpWidget theSeed mport keyState = + padLeftRight 2 . vBox $ padTop (Pad 1) <$> [info, helpKeys, tips] where tips = vBox - [ txt "Have questions? Want some tips? Check out:" - , txt " " - , txt $ " - The Swarm wiki, " <> wikiUrl - , txt " - The #swarm IRC channel on Libera.Chat" + [ heading boldAttr "Have questions? Want some tips? Check out:" + , txt " - The Swarm wiki, " <+> hyperlink wikiUrl (txt wikiUrl) + , txt " - The #swarm IRC channel on " <+> hyperlink swarmWebIRC (txt swarmWebIRC) ] info = vBox - [ txt "Configuration" - , txt " " + [ heading boldAttr "Configuration" , txt ("Seed: " <> into @Text (show theSeed)) , txt ("Web server port: " <> maybe "none" (into @Text . show) mport) ] helpKeys = vBox - [ txt "Keybindings" - , txt " " - , mkTable glKeyBindings + [ heading boldAttr "Keybindings" + , keySection "Main (always active)" mainEventHandlers + , keySection "REPL panel" replEventHandlers + , keySection "World view panel" worldEventHandlers + , keySection "Robot inventory panel" robotEventHandlers ] - mkTable = + keySection name handlers = + padBottom (Pad 1) $ + vBox + [ heading italicAttr name + , mkKeyTable handlers + ] + mkKeyTable = BT.renderTable . BT.surroundingBorder False . BT.rowBorders False . BT.table - . map toRow - toRow (k, v) = [padRight (Pad 1) $ txt k, padLeft (Pad 1) $ txt v] - glKeyBindings = - [ ("F1", "Help") - , ("F2", "Robots list") - , ("F3", "Available recipes") - , ("F4", "Available commands") - , ("F5", "Messages") - , ("F6", "Structures") - , ("Ctrl-g", "show goal") - , ("Ctrl-p", "pause") - , ("Ctrl-o", "single step") - , ("Ctrl-z", "decrease speed") - , ("Ctrl-w", "increase speed") - , ("Ctrl-q", "quit or restart the current scenario") - , ("Meta-,", "collapse/expand REPL") - , ("Meta-h", "hide robots for 2s") - , ("Meta-w", "focus on the world map") - , ("Meta-e", "focus on the robot inventory") - , ("Meta-r", "focus on the REPL") - , ("Meta-t", "focus on the info panel") + . map (toRow . keyHandlerToText) + heading attr = padBottom (Pad 1) . withAttr attr . txt + toRow (n, k, d) = + [ padRight (Pad 1) $ txtFilled maxN n + , padLeftRight 1 $ txtFilled maxK k + , padLeft (Pad 1) $ txtFilled maxD d ] + keyHandlerToText = handlerNameKeysDescription (keyState ^. keyConfig) + -- Get maximum width of the table columns so it all neatly aligns + txtFilled n t = padRight (Pad $ max 0 (n - textWidth t)) $ txt t + (maxN, maxK, maxD) = map3 (maximum . map textWidth) . unzip3 $ keyHandlerToText <$> allEventHandlers + map3 f (n, k, d) = (f n, f k, f d) data NotificationList = RecipeList | MessageList @@ -952,30 +952,31 @@ colorSeverity = \case drawModalMenu :: AppState -> Widget Name drawModalMenu s = vLimit 1 . hBox $ map (padLeftRight 1 . drawKeyCmd) globalKeyCmds where - notificationKey :: Getter GameState (Notifications a) -> Text -> Text -> Maybe (KeyHighlight, Text, Text) + notificationKey :: Getter GameState (Notifications a) -> SE.MainEvent -> Text -> Maybe (KeyHighlight, Text, Text) notificationKey notifLens key name | null (s ^. gameState . notifLens . notificationsContent) = Nothing | otherwise = let highlight | s ^. gameState . notifLens . notificationsCount > 0 = Alert | otherwise = NoHighlight - in Just (highlight, key, name) + in Just (highlight, keyM key, name) -- Hides this key if the recognizable structure list is empty structuresKey = if null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions then Nothing - else Just (NoHighlight, "F6", "Structures") + else Just (NoHighlight, keyM SE.ViewStructuresEvent, "Structures") globalKeyCmds = catMaybes - [ Just (NoHighlight, "F1", "Help") - , Just (NoHighlight, "F2", "Robots") - , notificationKey (discovery . availableRecipes) "F3" "Recipes" - , notificationKey (discovery . availableCommands) "F4" "Commands" - , notificationKey messageNotifications "F5" "Messages" + [ Just (NoHighlight, keyM SE.ViewHelpEvent, "Help") + , Just (NoHighlight, keyM SE.ViewRobotsEvent, "Robots") + , notificationKey (discovery . availableRecipes) SE.ViewRecipesEvent "Recipes" + , notificationKey (discovery . availableCommands) SE.ViewCommandsEvent "Commands" + , notificationKey messageNotifications SE.ViewMessagesEvent "Messages" , structuresKey ] + keyM = bindingText s . SE.Main -- | Draw a menu explaining what key commands are available for the -- current panel. This menu is displayed as one or two lines in @@ -1040,15 +1041,28 @@ drawKeyMenu s = True -> "Creative" globalKeyCmds = catMaybes - [ may goal (NoHighlight, "^g", "goal") - , may cheat (NoHighlight, "^v", "creative") - , may cheat (NoHighlight, "^e", "editor") - , Just (NoHighlight, "^p", if isPaused then "unpause" else "pause") - , may isPaused (NoHighlight, "^o", "step") - , may (isPaused && hasDebug) (if s ^. uiState . uiGameplay . uiShowDebug then Alert else NoHighlight, "M-d", "debug") - , Just (NoHighlight, "^zx", "speed") - , Just (NoHighlight, "M-,", if s ^. uiState . uiGameplay . uiShowREPL then "hide REPL" else "show REPL") - , Just (if s ^. uiState . uiGameplay . uiShowRobots then NoHighlight else Alert, "M-h", "hide robots") + [ may goal (NoHighlight, keyM SE.ViewGoalEvent, "goal") + , may cheat (NoHighlight, keyM SE.ToggleCreativeModeEvent, "creative") + , may cheat (NoHighlight, keyM SE.ToggleWorldEditorEvent, "editor") + , Just (NoHighlight, keyM SE.PauseEvent, if isPaused then "unpause" else "pause") + , may isPaused (NoHighlight, keyM SE.RunSingleTickEvent, "step") + , may + (isPaused && hasDebug) + ( if s ^. uiState . uiGameplay . uiShowDebug then Alert else NoHighlight + , keyM SE.ShowCESKDebugEvent + , "debug" + ) + , Just (NoHighlight, keyM SE.IncreaseTpsEvent <> "/" <> keyM SE.DecreaseTpsEvent, "speed") + , Just + ( NoHighlight + , keyM SE.ToggleREPLVisibilityEvent + , if s ^. uiState . uiGameplay . uiShowREPL then "hide REPL" else "show REPL" + ) + , Just + ( if s ^. uiState . uiGameplay . uiShowRobots then NoHighlight else Alert + , keyM SE.HideRobotsEvent + , "hide robots" + ) ] may b = if b then Just else const Nothing @@ -1060,27 +1074,45 @@ drawKeyMenu s = [ ("↓↑", "history") ] ++ [("Enter", "execute") | not isReplWorking] - ++ [("^c", "cancel") | isReplWorking] - ++ [("M-p", renderPilotModeSwitch ctrlMode) | creative] - ++ [("M-k", renderHandlerModeSwitch ctrlMode) | handlerInstalled] + ++ [(keyR SE.CancelRunningProgramEvent, "cancel") | isReplWorking] + ++ [(keyR SE.TogglePilotingModeEvent, renderPilotModeSwitch ctrlMode) | creative] + ++ [(keyR SE.ToggleCustomKeyHandlingEvent, renderHandlerModeSwitch ctrlMode) | handlerInstalled] ++ [("PgUp/Dn", "scroll")] keyCmdsFor (Just (FocusablePanel WorldPanel)) = - [ ("←↓↑→ / hjkl", "scroll") | canScroll - ] - ++ [("c", "recenter") | not viewingBase] - ++ [("f", "FPS")] + [(T.intercalate "/" $ map keyW enumerate, "scroll") | canScroll] + ++ [(keyW SE.ViewBaseEvent, "recenter") | not viewingBase] + ++ [(keyW SE.ShowFpsEvent, "FPS")] keyCmdsFor (Just (FocusablePanel RobotPanel)) = ("Enter", "pop out") : if isJust inventorySearch then [("Esc", "exit search")] else - [ ("m", "make") - , ("0", (if showZero then "hide" else "show") <> " 0") - , (":/;", T.unwords ["Sort:", renderSortMethod inventorySort]) - , ("/", "search") + [ (keyE SE.MakeEntityEvent, "make") + , (keyE SE.ShowZeroInventoryEntitiesEvent, (if showZero then "hide" else "show") <> " 0") + , + ( keyE SE.SwitchInventorySortDirection <> "/" <> keyE SE.CycleInventorySortEvent + , T.unwords ["Sort:", renderSortMethod inventorySort] + ) + , (keyE SE.SearchInventoryEvent, "search") ] keyCmdsFor (Just (FocusablePanel InfoPanel)) = [] keyCmdsFor _ = [] + keyM = bindingText s . SE.Main + keyR = bindingText s . SE.REPL + keyE = bindingText s . SE.Robot + keyW = bindingText s . SE.World + +bindingText :: AppState -> SwarmEvent -> Text +bindingText s e = maybe "" ppBindingShort b + where + conf = s ^. keyEventHandling . keyConfig + b = firstActiveBinding conf e + ppBindingShort = \case + Binding V.KUp m | null m -> "↑" + Binding V.KDown m | null m -> "↓" + Binding V.KLeft m | null m -> "←" + Binding V.KRight m | null m -> "→" + bi -> ppBinding bi data KeyHighlight = NoHighlight | Alert | PanelSpecific diff --git a/src/swarm-tui/Swarm/TUI/View/Util.hs b/src/swarm-tui/Swarm/TUI/View/Util.hs index adc65c962..356593aae 100644 --- a/src/swarm-tui/Swarm/TUI/View/Util.hs +++ b/src/swarm-tui/Swarm/TUI/View/Util.hs @@ -44,10 +44,9 @@ generateModal s mt = Modal mt (dialog (Just $ str title) buttons (maxModalWindow NoMenu -> Just "Quit" _ -> Nothing descriptionWidth = 100 - helpWidth = 80 (title, buttons, requiredWidth) = case mt of - HelpModal -> (" Help ", Nothing, helpWidth) + HelpModal -> (" Help ", Nothing, descriptionWidth) RobotsModal -> ("Robots", Nothing, descriptionWidth) RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) CommandsModal -> ("Available Commands", Nothing, descriptionWidth) diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 5d968d375..a4741c186 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -79,7 +79,7 @@ import Swarm.Game.State.Substate import Swarm.Game.Step.Path.Type import Swarm.Language.Pipeline (processTermEither) import Swarm.Language.Pretty (prettyTextLine) -import Swarm.TUI.Model +import Swarm.TUI.Model hiding (SwarmKeyDispatchers (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.Repl (REPLHistItem, replHistory, replSeq) import Swarm.TUI.Model.UI @@ -167,7 +167,7 @@ mkApp state events = :<|> codeRunHandler events :<|> pathsLogHandler state :<|> cmdMatrixHandler state - :<|> replHandler state + :<|> replHistHandler state :<|> mapViewHandler state robotsHandler :: ReadableIORef AppState -> Handler [Robot] @@ -247,8 +247,8 @@ pathsLogHandler appStateRef = do cmdMatrixHandler :: ReadableIORef AppState -> Handler CommandCatalog cmdMatrixHandler _ = pure getCatalog -replHandler :: ReadableIORef AppState -> Handler [REPLHistItem] -replHandler appStateRef = do +replHistHandler :: ReadableIORef AppState -> Handler [REPLHistItem] +replHistHandler appStateRef = do appState <- liftIO (readIORef appStateRef) let replHistorySeq = appState ^. uiState . uiGameplay . uiREPL . replHistory . replSeq items = toList replHistorySeq diff --git a/swarm.cabal b/swarm.cabal index 296180398..5d711d095 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -664,6 +664,14 @@ library swarm-tui exposed-modules: Swarm.TUI.Border Swarm.TUI.Controller + Swarm.TUI.Controller.EventHandlers + Swarm.TUI.Controller.EventHandlers.Frame + Swarm.TUI.Controller.EventHandlers.Main + Swarm.TUI.Controller.EventHandlers.REPL + Swarm.TUI.Controller.EventHandlers.Robot + Swarm.TUI.Controller.EventHandlers.World + Swarm.TUI.Controller.SaveScenario + Swarm.TUI.Controller.UpdateUI Swarm.TUI.Controller.Util Swarm.TUI.Editor.Controller Swarm.TUI.Editor.Json @@ -679,7 +687,10 @@ library swarm-tui Swarm.TUI.Launch.View Swarm.TUI.List Swarm.TUI.Model + Swarm.TUI.Model.Achievements + Swarm.TUI.Model.Event Swarm.TUI.Model.Goal + Swarm.TUI.Model.KeyBindings Swarm.TUI.Model.Menu Swarm.TUI.Model.Name Swarm.TUI.Model.Repl @@ -704,7 +715,7 @@ library swarm-tui aeson >=2.2 && <2.3, array >=0.5.4 && <0.6, base >=4.14 && <4.20, - brick >=2.1.1 && <2.4, + brick >=2.1.1 && <2.5, brick-list-skip >=0.1.1.2 && <0.2, bytestring >=0.10 && <0.13, clock >=0.8.2 && <0.9, diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 6d7f9c807..2c7d62e20 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -69,6 +69,7 @@ import Swarm.Language.Pipeline (processTerm) import Swarm.Language.Pretty (prettyString) import Swarm.Log import Swarm.TUI.Model ( + KeyEventHandlingState, defaultAppOpts, gameState, runtimeState, @@ -95,7 +96,7 @@ main = do scenarioPaths <- findAllWithExt "data/scenarios" "yaml" let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths scenarioPrograms <- findAllWithExt "data/scenarios" "sw" - (rs, ui) <- do + (rs, ui, key) <- do out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts either (assertFailure . prettyString) return out let scenarioInputs = gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs @@ -108,7 +109,7 @@ main = do , exampleTests scenarioPrograms , scenarioParseTests scenarioInputs parseableScenarios , scenarioParseInvalidTests scenarioInputs unparseableScenarios - , testScenarioSolutions rs' ui + , testScenarioSolutions rs' ui key , testEditorFiles ] @@ -183,8 +184,8 @@ time = \case data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show) -testScenarioSolutions :: RuntimeState -> UIState -> TestTree -testScenarioSolutions rs ui = +testScenarioSolutions :: RuntimeState -> UIState -> KeyEventHandlingState -> TestTree +testScenarioSolutions rs ui key = testGroup "Test scenario solutions" [ testGroup @@ -480,7 +481,7 @@ testScenarioSolutions rs ui = testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree testSolution' s p shouldCheckBadErrors verify = testCase p $ do - out <- runM . runThrow @SystemFailure $ constructAppState rs ui $ defaultAppOpts {userScenario = Just p} + out <- runM . runThrow @SystemFailure $ constructAppState rs ui key $ defaultAppOpts {userScenario = Just p} case out of Left err -> assertFailure $ prettyString err Right appState -> case appState ^. gameState . winSolution of