diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,42 @@ # Revision history for swarm +## **0.2.0.0** - 2022-11-01 + +A bunch of small fixes and improvements; special thanks to new +contributors @0xcefaedfe, @kostmo, @ussgarci, and @valyagolev. Notable changes include: + +- New UI features: + - REPL improvements: + - Expose the last evaluated result as `it`, and previous results + as `itN` ([#734](https://github.com/swarm-game/swarm/pull/734)) + - Allow clicking in the REPL input to move the cursor + ([#750](https://github.com/swarm-game/swarm/pull/750)) + - Autocomplete entity names in the repl ([#798](https://github.com/swarm-game/swarm/pull/798)) + - REPL cursor no longer blinks when REPL panel is not selected ([#801](https://github.com/swarm-game/swarm/pull/801)) + - Improve user experience around quitting & moving between + tutorial challenges ([#754](https://github.com/swarm-game/swarm/pull/754)) + - Add a button to the Quit dialog to restart a + scenario. ([#767](https://github.com/swarm-game/swarm/pull/767)) + - Use scenario name as Goal dialog title ([#774](https://github.com/swarm-game/swarm/pull/774)) + - `autoplay` flag for automatically demonstrating scenario + solutions ([#792](https://github.com/swarm-game/swarm/pull/792)) + - Improved inventory sorting and user-controllable sort criteria ([#793](https://github.com/swarm-game/swarm/pull/793)) + - Ability to temporarily hide robots so you can see what's under + them ([#802](https://github.com/swarm-game/swarm/pull/802)) +- New language features: + - New `void` type ([#735](https://github.com/swarm-game/swarm/pull/735)) +- Bug fixes: + - Fix bug in the first tutorial challenge that froze the game and + ate all memory if the user said anything other than expected + ([#762](https://github.com/swarm-game/swarm/pull/762), [#810](https://github.com/swarm-game/swarm/pull/810)) +- Documentation: + - Generate all wiki "cheat sheets" automatically ([#769](https://github.com/swarm-game/swarm/pull/769)) +- Support for building on GHC 9.4 ([#752](https://github.com/swarm-game/swarm/pull/752)) + +There were several other small fixes and improvements; see the [full +changelog +here](https://github.com/swarm-game/swarm/compare/0.1.1.0...0.2.0.0). + ## **0.1.1.0** - 2022-10-14 A couple new features and an important bugfix for the Hackage release. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,13 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where import Data.Foldable qualified +import Data.Maybe (fromMaybe) import Data.Text (Text, pack) +import Data.Text qualified as T import Data.Text.IO qualified as Text +import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) import Options.Applicative import Swarm.App (appMain) -import Swarm.DocGen (EditorType (..), GenerateDocs (..), SheetType (..), generateDocs) +import Swarm.DocGen (EditorType (..), GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs) import Swarm.Language.LSP (lspMain) import Swarm.Language.Pipeline (processTerm) import Swarm.TUI.Model (AppOpts (..)) @@ -16,6 +20,14 @@ import System.Exit (exitFailure, exitSuccess) import System.IO (hPrint, stderr) +gitInfo :: Maybe GitInfo +gitInfo = either (const Nothing) Just ($$tGitInfoCwdTry) + +commitInfo :: String +commitInfo = case gitInfo of + Nothing -> "" + Just git -> " (" <> giBranch git <> "@" <> take 10 (giHash git) <> ")" + data CLI = Run AppOpts | Format Input @@ -33,7 +45,7 @@ , command "version" (info (pure Version) (progDesc "Get current and upstream version.")) ] ) - <|> Run <$> (AppOpts <$> seed <*> scenario <*> run <*> cheat <*> webPort) + <|> Run <$> (AppOpts <$> seed <*> scenario <*> run <*> autoplay <*> cheat <*> webPort <*> pure gitInfo) where format :: Parser CLI format = @@ -44,7 +56,7 @@ subparser . mconcat $ [ command "recipes" (info (pure RecipeGraph) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes") , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords") - , command "cheatsheet" (info (pure $ CheatSheet $ Just Commands) $ progDesc "Output nice Wiki tables") + , command "cheatsheet" (info (CheatSheet <$> address <*> cheatsheet <**> helper) $ progDesc "Output nice Wiki tables") ] editor :: Parser (Maybe EditorType) editor = @@ -53,6 +65,27 @@ , Just VSCode <$ switch (long "code" <> help "Generate for the VS Code editor") , Just Emacs <$ switch (long "emacs" <> help "Generate for the Emacs editor") ] + address :: Parser PageAddress + address = + let replace a b = T.unpack . T.replace a b . T.pack + opt n = + fmap (fromMaybe "") . optional $ + option + str + ( long n + <> metavar "ADDRESS" + <> help ("Set the address of " <> replace "-" " " n <> ". Default no link.") + ) + in PageAddress <$> opt "entities-page" <*> opt "commands-page" <*> opt "capabilities-page" <*> opt "recipes-page" + cheatsheet :: Parser (Maybe SheetType) + cheatsheet = + Data.Foldable.asum + [ pure Nothing + , Just Entities <$ switch (long "entities" <> help "Generate entities page (uses data from entities.yaml)") + , Just Recipes <$ switch (long "recipes" <> help "Generate recipes page (uses data from recipes.yaml)") + , Just Capabilities <$ switch (long "capabilities" <> help "Generate capabilities page (uses entity map)") + , Just Commands <$ switch (long "commands" <> help "Generate commands page (uses constInfo, constCaps and inferConst)") + ] seed :: Parser (Maybe Int) seed = optional $ option auto (long "seed" <> short 's' <> metavar "INT" <> help "Seed to use for world generation") webPort :: Parser (Maybe Int) @@ -68,8 +101,10 @@ scenario = optional $ strOption (long "scenario" <> short 'c' <> metavar "FILE" <> help "Name of a scenario to load") run :: Parser (Maybe String) run = optional $ strOption (long "run" <> short 'r' <> metavar "FILE" <> help "Run the commands in a file at startup") + autoplay :: Parser Bool + autoplay = switch (long "autoplay" <> short 'a' <> help "Automatically run the solution defined in the scenario, if there is one. Mutually exclusive with --run.") cheat :: Parser Bool - cheat = switch (long "cheat" <> short 'x' <> help "Enable cheat mode") + cheat = switch (long "cheat" <> short 'x' <> help "Enable cheat mode. This allows toggling Creative Mode with Ctrl+v and unlocks \"Testing\" scenarios in the menu.") cliInfo :: ParserInfo CLI cliInfo = @@ -105,7 +140,7 @@ showVersion :: IO () showVersion = do putStrLn $ "Swarm game - " <> version <> commitInfo - up <- getNewerReleaseVersion + up <- getNewerReleaseVersion gitInfo either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up main :: IO () diff --git a/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml b/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml --- a/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml +++ b/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml @@ -45,8 +45,6 @@ - name: judge dir: [0,0] system: true - display: - invisible: true program: | def until = \c. b <- c; if b {} {until c} end; until (d <- scan down; return (d == inl ())); diff --git a/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml b/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml --- a/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml +++ b/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml @@ -46,8 +46,6 @@ - name: judge dir: [0,0] system: true - display: - invisible: true program: | def until = \c. b <- c; if b {} {until c} end; until (d <- scan down; return (d == inl ())); diff --git a/data/scenarios/Challenges/hanoi.yaml b/data/scenarios/Challenges/hanoi.yaml --- a/data/scenarios/Challenges/hanoi.yaml +++ b/data/scenarios/Challenges/hanoi.yaml @@ -37,8 +37,6 @@ - name: invariant dir: [0,0] system: true - display: - invisible: true devices: - logger inventory: @@ -66,8 +64,6 @@ - name: increasing dir: [0,0] system: true - display: - invisible: true inventory: - [1, OK] devices: @@ -83,8 +79,6 @@ - name: count dir: [0,0] system: true - display: - invisible: true inventory: - [1, two] - [0, three] diff --git a/data/scenarios/Challenges/teleport.yaml b/data/scenarios/Challenges/teleport.yaml --- a/data/scenarios/Challenges/teleport.yaml +++ b/data/scenarios/Challenges/teleport.yaml @@ -29,8 +29,6 @@ - [0, lambda] - name: portkey1 system: true - display: - invisible: true loc: [0,0] dir: [0,0] program: | @@ -44,8 +42,6 @@ ); - name: portkey2 system: true - display: - invisible: true loc: [16,0] dir: [0,0] program: | diff --git a/data/scenarios/Testing/562-lodestone.sw b/data/scenarios/Testing/562-lodestone.sw --- a/data/scenarios/Testing/562-lodestone.sw +++ b/data/scenarios/Testing/562-lodestone.sw @@ -37,9 +37,12 @@ log "Hi!"; require "branch predictor"; repeat ( - turn east; m2; x <- until (ishere "bit (0)") {harvest}; turn back; m2; place x + log "I am going for a bit"; + turn east; m2; x <- until (ishere "bit (0)") {harvest}; turn back; m2; place x; + log "I brought a bit"; )}; until (ishere "bit (0)") {grab}; until (ishere "bit (0)") {grab}; +make "bit (1)"; make "drill bit" diff --git a/data/scenarios/Testing/562-lodestone.yaml b/data/scenarios/Testing/562-lodestone.yaml --- a/data/scenarios/Testing/562-lodestone.yaml +++ b/data/scenarios/Testing/562-lodestone.yaml @@ -1,14 +1,15 @@ version: 1 name: Test lodestone description: Pick or drill lodestone and use it to flip bits. -goal: - - To create a drill bit, you will need to flip the available bit. -win: | - try { - as base {has "drill bit"}; - } { return false } +objectives: + - goal: + - To create a drill bit, you will need to flip the available bit. + condition: | + try { + as base {has "drill bit"}; + } { return false } solution: | - run "562-lodestone.sw" + run "scenarios/Testing/562-lodestone.sw" robots: - name: base dir: [1,0] diff --git a/data/scenarios/Tutorials/backstory.yaml b/data/scenarios/Tutorials/backstory.yaml --- a/data/scenarios/Tutorials/backstory.yaml +++ b/data/scenarios/Tutorials/backstory.yaml @@ -23,7 +23,10 @@ idea. - To prepare you, this simulator will walk you through a series of hands-on exercises that introduce you to the way robots work and the programming - language you will use to control them. + language you will use to control them. Note that your progress through + the tutorials will be saved automatically. You can return to + the menu at any time to jump around between tutorials or pick + up again where you left off. - | When you're ready for your first challenge, close this dialog with Esc or Ctrl-G, and type at the prompt: diff --git a/data/scenarios/Tutorials/build.yaml b/data/scenarios/Tutorials/build.yaml --- a/data/scenarios/Tutorials/build.yaml +++ b/data/scenarios/Tutorials/build.yaml @@ -20,7 +20,8 @@ TIP: You can use the name of the flower directly ("pickerelweed"), or you can use bind notation: `f <- harvest; ... ; place f;`. - | - TIP: Newly built robots always start out facing north. + TIP: Newly built robots start out facing the same + direction as their parent, which in the tutorials will always be north. condition: | try { teleport self (0,-1); diff --git a/data/scenarios/Tutorials/crash-secret.sw b/data/scenarios/Tutorials/crash-secret.sw --- a/data/scenarios/Tutorials/crash-secret.sw +++ b/data/scenarios/Tutorials/crash-secret.sw @@ -60,6 +60,6 @@ iterate allOK (foreachF 1 16 $ tryGive $ "Send a robot to `salvage` me and come back to `give base \"Win\"`.\n" ++ "When the rescue robot stands where I am and executes `salvage`,\n" - ++ "all my inventory and logs will go to it, namely the \"Win\".\n" + ++ "all my inventory and logs will go to it, including the \"Win\".\n" ++ "Once you have brought the \"Win\" to your base, you will win!" ) diff --git a/data/scenarios/Tutorials/crash.yaml b/data/scenarios/Tutorials/crash.yaml --- a/data/scenarios/Tutorials/crash.yaml +++ b/data/scenarios/Tutorials/crash.yaml @@ -9,17 +9,17 @@ - | In this challenge, you should start by sending a robot to walk four steps straight east into the mountain, - crashing deliberately. However, you must (1) make sure it has a `logger`, - so we can see what command failed, - and (2) use the bind syntax `r <- build {COMMANDS}` so you can refer to - the newly built robot later. All together, it might look something like - this: + crashing deliberately. However, you must make sure it has a `logger`, + so we can see what command failed. The simplest way to ensure + that is to have it execute the `log` command; `build` will + ensure it has the devices it needs to execute its commands. + For example: - | - r <- build {log "Hi!"; turn east; move; move; move; log "3"; move; log "OK"} - - (`build` will make sure the robot has a `logger` since its program includes - calls to the `log` command.) - - After the robot crashes, execute `view r` to see how far it got. - Further instructions should appear in the crashed robot's log. + build {log "Hi!"; turn east; move; move; move; log "3"; move; log "OK"} + - After the robot crashes, execute `view it0` (or whichever + `itN` variable corresponds to the result of the `build` + command) to see how far it got. Further instructions should + appear in the crashed robot's log. condition: | try { as base {has "Win"} diff --git a/data/scenarios/Tutorials/grab.yaml b/data/scenarios/Tutorials/grab.yaml --- a/data/scenarios/Tutorials/grab.yaml +++ b/data/scenarios/Tutorials/grab.yaml @@ -7,9 +7,10 @@ - Previously you learned how to make new things (like a branch predictor) from ingredients. Now you will learn how to obtain the ingredients you need. - There are some trees ahead of your robot; `move` to each one and `grab` it. - - You can learn more by reading about the grabber device in your inventory. - - | - TIP: You can use the arrow key Up ('↑') to reuse your previous commands. + - You can learn more by reading about the grabber device in your + inventory. Remember, if the description does not fit in the + lower left info box, you can either hit `Enter` to pop out the + description, or focus the info box in order to scroll. condition: | try { t <- as base {count "tree"}; diff --git a/data/scenarios/Tutorials/move.yaml b/data/scenarios/Tutorials/move.yaml --- a/data/scenarios/Tutorials/move.yaml +++ b/data/scenarios/Tutorials/move.yaml @@ -32,9 +32,14 @@ - goal: - Well done! In addition to `move`, you can use the `turn` command to turn your robot, for example, `turn right` or `turn east`. - - Switch to the inventory view (by clicking on it, or typing `Alt+E`) - and select the treads device to read about the details. - You can come back to the REPL prompt by clicking on it or typing `Alt+R`. + - Switch to the inventory view in the upper left (by clicking on it or typing `Alt+E`) + and select the `treads` device to read about the details. + If the bottom-left info panel is not big enough to read the + whole thing, you can hit `Enter` on the `treads` device to pop + out the description, or you can focus the info panel (with + `Alt+T` or by clicking) and scroll it with arrow keys or PgUp/PgDown. + When you're done reading, you can come back to the REPL prompt + by clicking on it or typing `Alt+R`. - Afterwards, move your robot to the coordinates (8,4) in the northeast corner marked with two flowers. - | @@ -149,8 +154,6 @@ - name: check1 loc: [2,0] system: true - display: - invisible: true program: | def until = \c. b <- c; if b {} {until c} end; l <- whereami; @@ -164,8 +167,6 @@ - name: check2 loc: [8,0] system: true - display: - invisible: true program: | def until = \c. b <- c; if b {} {until c} end; l <- whereami; @@ -179,8 +180,6 @@ - name: check3 loc: [8,4] system: true - display: - invisible: true program: | def until = \c. b <- c; if b {} {until c} end; l <- whereami; @@ -194,8 +193,6 @@ - name: check4 loc: [8,8] system: true - display: - invisible: true program: | def until = \c. b <- c; if b {} {until c} end; l <- whereami; @@ -211,36 +208,24 @@ ################# - name: 1P horizontal wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 2P horizontal wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3P horizontal wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" ################# ## VERTICAL ## ################# - name: 1P vertical wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 2P vertical wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3P vertical wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" ################# ## CORNERS ## @@ -257,72 +242,48 @@ ######### - name: 1P lower left corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 2P lower left corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3P lower left corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" ######### ## B ## ######### - name: 1P lower right corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 2P lower right corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3P lower right corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" ######### ## C ## ######### - name: 1P upper right corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 2P upper right corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3P upper right corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" ######### ## D ## ######### - name: 1P upper left corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 2P upper left corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3P upper left corner system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" ################# ## SEPARATORS ## @@ -330,43 +291,29 @@ # 1 - name: 1S down and horizontal wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 1S up and horizontal wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" # 2 - name: 2S left and vertical wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 2S up and horizontal wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" # 3 - name: 3S left and vertical wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3S down and horizontal wall system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" ################# ## GATES ## ################# - name: 1G system: true - display: - invisible: true program: | def until = \c. b <- c; if b {} {until c} end; c1 <- robotNamed "check1"; @@ -374,31 +321,21 @@ grab - name: 2G system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3G system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" ################# ## GARDENERS ## ################# - name: 1P flower system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 2P flower system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" - name: 3P flower system: true - display: - invisible: true program: run "scenarios/Tutorials/move_system.sw" entities: - name: Win diff --git a/data/scenarios/Tutorials/requireinv.yaml b/data/scenarios/Tutorials/requireinv.yaml --- a/data/scenarios/Tutorials/requireinv.yaml +++ b/data/scenarios/Tutorials/requireinv.yaml @@ -34,15 +34,13 @@ ifC (has "tree") {return false} {return true} } { return false } solution: | - def m4 = move; move; move; move end; + def x4 = \c. c;c;c;c end; def mp = move; place "rock" end; - def mp4 = mp; mp; mp; mp end; - def rr = move; turn right; mp4; turn back; m4; turn right end; + def rr = turn right; move; turn right; x4 mp; turn back; x4 move end; build { - require "treads"; require "grabber"; // #540 + require "treads"; require "grabber"; require "lambda"; // #540 require 16 "rock"; - turn right; - rr; rr; rr; rr + x4 rr }; robots: - name: base @@ -62,6 +60,7 @@ - [16, treads] - [16, grabber] - [16, scanner] + - [16, lambda] - [100, rock] world: default: [blank] diff --git a/data/scenarios/Tutorials/scan.yaml b/data/scenarios/Tutorials/scan.yaml --- a/data/scenarios/Tutorials/scan.yaml +++ b/data/scenarios/Tutorials/scan.yaml @@ -30,7 +30,7 @@ } robots: - name: base - dir: [1,0] + dir: [0,1] heavy: true display: char: Ω diff --git a/data/scenarios/Tutorials/types.yaml b/data/scenarios/Tutorials/types.yaml --- a/data/scenarios/Tutorials/types.yaml +++ b/data/scenarios/Tutorials/types.yaml @@ -8,8 +8,7 @@ every expression in the language has a type, and all the types must match up properly before a program can be executed. - To see the type of an expression, enter the expression at the - REPL prompt without hitting Return. If the expression type - checks, + REPL prompt (you do not need to execute it). If the expression type checks, its type will be displayed in gray text at the top right of the window. - For example, if you try typing `move`, you can see that it has type `cmd unit`, which means that `move` is a command which diff --git a/editors/emacs/swarm-mode.el b/editors/emacs/swarm-mode.el --- a/editors/emacs/swarm-mode.el +++ b/editors/emacs/swarm-mode.el @@ -100,7 +100,7 @@ "west" "down" )) - (x-types '("int" "text" "dir" "bool" "cmd")) + (x-types '("int" "text" "dir" "bool" "cmd" "void" "unit")) (x-keywords-regexp (regexp-opt x-keywords 'words)) (x-builtins-regexp (regexp-opt x-builtins 'words)) diff --git a/editors/vscode/syntaxes/swarm.tmLanguage.json b/editors/vscode/syntaxes/swarm.tmLanguage.json --- a/editors/vscode/syntaxes/swarm.tmLanguage.json +++ b/editors/vscode/syntaxes/swarm.tmLanguage.json @@ -16,9 +16,8 @@ "begin": "def\\s+(\\w+)\\s*(:((\\s*(cmd|dir|string|int|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=", "end": "end", "beginCaptures": { - "1": {"name": "variable.other"}, - "3": {"name": "storage.type"}, - "5": {"name": "storage.modifier"} + "1": {"name": "entity.name.function"}, + "3": {"name": "entity.name.type"} }, "patterns": [ {"include": "#keywords"}, @@ -30,12 +29,11 @@ }, { "name": "keyword.control.dictionary.let", - "begin": "\\s*let\\s+(\\w+)\\s*(:((\\s*(cmd|dir|string|int|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=", + "begin": "\\s*let\\s+(\\w+)\\s*(:((\\s*(cmd|dir|text|int|void|unit|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=", "end": "\\s*in", "beginCaptures": { - "1": {"name": "variable.other"}, - "3": {"name": "storage.type"}, - "5": {"name": "storage.modifier"} + "1": {"name": "entity.name.function"}, + "3": {"name": "entity.name.type"} }, "patterns": [ {"include": "#keywords"}, @@ -94,7 +92,7 @@ "match": "\\b(?i)(left|right|back|forward|north|south|east|west|down)\\b" }, { - "name": "variable.other" , + "name": "variable.parameter", "match": "\\b(?i)([a-z]\\w*)\\b" } ] diff --git a/src/Swarm/App.hs b/src/Swarm/App.hs --- a/src/Swarm/App.hs +++ b/src/Swarm/App.hs @@ -70,7 +70,7 @@ writeBChan chan Frame _ <- forkIO $ do - upRel <- getNewerReleaseVersion + upRel <- getNewerReleaseVersion (repoGitInfo opts) writeBChan chan (UpstreamVersion upRel) -- Start the web service with a reference to the game state @@ -108,9 +108,11 @@ AppOpts { userSeed = Nothing , userScenario = demoScenario - , toRun = Nothing + , scriptToRun = Nothing + , autoPlay = False , cheatMode = False , userWebPort = Nothing + , repoGitInfo = Nothing } case res of Left errMsg -> T.putStrLn errMsg diff --git a/src/Swarm/DocGen.hs b/src/Swarm/DocGen.hs --- a/src/Swarm/DocGen.hs +++ b/src/Swarm/DocGen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Swarm.DocGen ( generateDocs, @@ -14,39 +15,49 @@ editorList, -- ** Wiki pages + PageAddress (..), commandsPage, + capabilityPage, + noPageAddresses, ) where +import Control.Arrow (left) import Control.Lens (view, (^.)) +import Control.Lens.Combinators (to) import Control.Monad (zipWithM, zipWithM_, (<=<)) -import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Except (ExceptT, liftIO, runExceptT) import Data.Bifunctor (Bifunctor (bimap)) import Data.Containers.ListUtils (nubOrd) -import Data.Foldable (toList) +import Data.Foldable (find, toList) import Data.List (transpose) import Data.Map.Lazy (Map) import Data.Map.Lazy qualified as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text, unpack) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Tuple (swap) -import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName, loadEntities) +import Data.Yaml (decodeFileEither) +import Data.Yaml.Aeson (prettyPrintParseException) +import Swarm.Game.Display (displayChar) +import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities) import Swarm.Game.Entity qualified as E -import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements) +import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight) import Swarm.Game.Robot (installedDevices, instantiateRobot, robotInventory) import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots) import Swarm.Game.WorldGen (testWorld2Entites) -import Swarm.Language.Capability (capabilityName, constCaps) +import Swarm.Language.Capability (Capability) +import Swarm.Language.Capability qualified as Capability import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax (Const (..)) import Swarm.Language.Syntax qualified as Syntax import Swarm.Language.Typecheck (inferConst) -import Swarm.Util (isRightOr) +import Swarm.Util (getDataFileNameSafe, isRightOr) import Text.Dot (Dot, NodeId, (.->.)) import Text.Dot qualified as Dot +import Witch (from) -- ============================================================================ -- MAIN ENTRYPOINT TO CLI DOCUMENTATION GENERATOR @@ -61,7 +72,7 @@ RecipeGraph :: GenerateDocs -- | Keyword lists for editors. EditorKeywords :: Maybe EditorType -> GenerateDocs - CheatSheet :: Maybe SheetType -> GenerateDocs + CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs deriving (Eq, Show) data EditorType = Emacs | VSCode @@ -70,6 +81,17 @@ data SheetType = Entities | Commands | Capabilities | Recipes deriving (Eq, Show, Enum, Bounded) +data PageAddress = PageAddress + { entityAddress :: Text + , commandsAddress :: Text + , capabilityAddress :: Text + , recipesAddress :: Text + } + deriving (Eq, Show) + +noPageAddresses :: PageAddress +noPageAddresses = PageAddress "" "" "" "" + generateDocs :: GenerateDocs -> IO () generateDocs = \case RecipeGraph -> generateRecipe >>= putStrLn @@ -84,11 +106,23 @@ putStrLn $ replicate 40 '-' generateEditorKeywords et mapM_ editorGen [minBound .. maxBound] - CheatSheet s -> case s of - Nothing -> error "Not implemented" + CheatSheet address s -> case s of + Nothing -> error "Not implemented for all Wikis" Just st -> case st of Commands -> T.putStrLn commandsPage - _ -> error "Not implemented" + Capabilities -> simpleErrorHandle $ do + entities <- loadEntities >>= guardRight "load entities" + liftIO $ T.putStrLn $ capabilityPage address entities + Entities -> simpleErrorHandle $ do + let loadEntityList fp = left (from . prettyPrintParseException) <$> decodeFileEither fp + let f = "entities.yaml" + Just fileName <- liftIO $ getDataFileNameSafe f + entities <- liftIO (loadEntityList fileName) >>= guardRight "load entities" + liftIO $ T.putStrLn $ entitiesPage address entities + Recipes -> simpleErrorHandle $ do + entities <- loadEntities >>= guardRight "load entities" + recipes <- loadRecipes entities >>= guardRight "load recipes" + liftIO $ T.putStrLn $ recipePage address recipes -- ---------------------------------------------------------------------------- -- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED @@ -175,6 +209,12 @@ maxWidths :: [[Text]] -> [Int] maxWidths = map (maximum . map T.length) . transpose +addLink :: Text -> Text -> Text +addLink l t = T.concat ["[", t, "](", l, ")"] + +tshow :: Show a => a -> Text +tshow = T.pack . show + -- --------- -- COMMANDS -- --------- @@ -186,13 +226,11 @@ commandToList c = map escapeTable - [ addLink (T.pack $ "#" <> show c) . codeQuote $ constSyntax c + [ addLink ("#" <> tshow c) . codeQuote $ constSyntax c , codeQuote . prettyText $ inferConst c - , maybe "" capabilityName $ constCaps c + , maybe "" Capability.capabilityName $ Capability.constCaps c , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c ] - where - addLink l t = T.concat ["[", t, "](", l, ")"] constTable :: [Const] -> Text constTable cs = T.unlines $ header <> map (listToRow mw) commandRows @@ -208,7 +246,7 @@ , "" , "- syntax: " <> codeQuote (constSyntax c) , "- type: " <> (codeQuote . prettyText $ inferConst c) - , maybe "" (("- required capabilities: " <>) . capabilityName) $ constCaps c + , maybe "" (("- required capabilities: " <>) . Capability.capabilityName) $ Capability.constCaps c , "" , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c ] @@ -228,6 +266,136 @@ , "# Detailed descriptions" ] <> map commandToSection (commands <> builtinFunctions <> operators) + +-- ------------- +-- CAPABILITIES +-- ------------- + +capabilityHeader :: [Text] +capabilityHeader = ["Name", "Commands", "Entities"] + +capabilityRow :: PageAddress -> EntityMap -> Capability -> [Text] +capabilityRow PageAddress {..} em cap = + map + escapeTable + [ Capability.capabilityName cap + , T.intercalate ", " (linkCommand <$> cs) + , T.intercalate ", " (linkEntity . view entityName <$> es) + ] + where + linkEntity t = + if T.null entityAddress + then t + else addLink (entityAddress <> "#" <> T.replace " " "-" t) t + linkCommand c = + ( if T.null commandsAddress + then id + else addLink (commandsAddress <> "#" <> tshow c) + ) + . codeQuote + $ constSyntax c + + cs = [c | c <- Syntax.allConst, let mcap = Capability.constCaps c, isJust $ find (== cap) mcap] + es = fromMaybe [] $ E.entitiesByCap em Map.!? cap + +capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text +capabilityTable a em cs = T.unlines $ header <> map (listToRow mw) capabilityRows + where + mw = maxWidths (capabilityHeader : capabilityRows) + capabilityRows = map (capabilityRow a em) cs + header = [listToRow mw capabilityHeader, separatingLine mw] + +capabilityPage :: PageAddress -> EntityMap -> Text +capabilityPage a em = capabilityTable a em [minBound .. maxBound] + +-- --------- +-- Entities +-- --------- + +entityHeader :: [Text] +entityHeader = ["?", "Name", "Capabilities", "Properties*", "Portable"] + +entityToList :: Entity -> [Text] +entityToList e = + map + escapeTable + [ codeQuote . T.singleton $ e ^. entityDisplay . to displayChar + , addLink ("#" <> linkID) $ view entityName e + , T.intercalate ", " $ Capability.capabilityName <$> view E.entityCapabilities e + , T.intercalate ", " . map tshow . filter (/= E.Portable) $ toList props + , if E.Portable `elem` props + then ":heavy_check_mark:" + else ":negative_squared_cross_mark:" + ] + where + props = view E.entityProperties e + linkID = T.replace " " "-" $ view entityName e + +entityTable :: [Entity] -> Text +entityTable es = T.unlines $ header <> map (listToRow mw) entityRows + where + mw = maxWidths (entityHeader : entityRows) + entityRows = map entityToList es + header = [listToRow mw entityHeader, separatingLine mw] + +entityToSection :: Entity -> Text +entityToSection e = + T.unlines $ + [ "## " <> view E.entityName e + , "" + , " - Char: " <> (codeQuote . T.singleton $ e ^. entityDisplay . to displayChar) + ] + <> [" - Properties: " <> T.intercalate ", " (map tshow $ toList props) | not $ null props] + <> [" - Capabilities: " <> T.intercalate ", " (Capability.capabilityName <$> caps) | not $ null caps] + <> ["\n"] + <> [T.intercalate "\n\n" $ view E.entityDescription e] + where + props = view E.entityProperties e + caps = view E.entityCapabilities e + +entitiesPage :: PageAddress -> [Entity] -> Text +entitiesPage _a es = + T.intercalate "\n\n" $ + [ "# Entities" + , "This is a quick-overview table of entities - click the name for detailed description." + , "*) As a note, most entities have the Portable property, so we show it in a separate column." + , entityTable es + ] + <> map entityToSection es + +-- ------------- +-- RECIPES +-- ------------- + +recipeHeader :: [Text] +recipeHeader = ["In", "Out", "Required", "Time", "Weight"] + +recipeRow :: PageAddress -> Recipe Entity -> [Text] +recipeRow PageAddress {..} r = + map + escapeTable + [ T.intercalate ", " (map formatCE $ view recipeInputs r) + , T.intercalate ", " (map formatCE $ view recipeOutputs r) + , T.intercalate ", " (map formatCE $ view recipeRequirements r) + , tshow $ view recipeTime r + , tshow $ view recipeWeight r + ] + where + formatCE (c, e) = T.unwords [tshow c, linkEntity $ view entityName e] + linkEntity t = + if T.null entityAddress + then t + else addLink (entityAddress <> "#" <> T.replace " " "-" t) t + +recipeTable :: PageAddress -> [Recipe Entity] -> Text +recipeTable a rs = T.unlines $ header <> map (listToRow mw) recipeRows + where + mw = maxWidths (recipeHeader : recipeRows) + recipeRows = map (recipeRow a) rs + header = [listToRow mw recipeHeader, separatingLine mw] + +recipePage :: PageAddress -> [Recipe Entity] -> Text +recipePage = recipeTable -- ---------------------------------------------------------------------------- -- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES diff --git a/src/Swarm/Game/Display.hs b/src/Swarm/Game/Display.hs --- a/src/Swarm/Game/Display.hs +++ b/src/Swarm/Game/Display.hs @@ -41,11 +41,13 @@ import Data.Hashable (Hashable) import Data.Map (Map) import Data.Map qualified as M +import Data.Maybe (fromMaybe, isJust) import Data.Yaml import GHC.Generics (Generic) import Swarm.Language.Syntax (Direction (..)) import Swarm.TUI.Attr (entityAttr, robotAttr, worldPrefix) import Swarm.Util (maxOn, (?)) +import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE) -- | Display priority. Entities with higher priority will be drawn on -- top of entities with lower priority. @@ -98,14 +100,21 @@ invisible :: Lens' Display Bool instance FromJSON Display where - parseJSON = withObject "Display" $ \v -> - Display - <$> v .:? "char" .!= ' ' - <*> v .:? "orientationMap" .!= M.empty - <*> v .:? "curOrientation" - <*> (fmap (worldPrefix <>) <$> v .:? "attr") .!= entityAttr - <*> v .:? "priority" .!= 1 - <*> v .:? "invisible" .!= False + parseJSON v = runE (parseJSONE v) (defaultEntityDisplay ' ') + +instance FromJSONE Display Display where + parseJSONE = withObjectE "Display" $ \v -> do + defD <- getE + mc <- liftE $ v .:? "char" + let c = fromMaybe (defD ^. defaultChar) mc + let dOM = if isJust mc then mempty else defD ^. orientationMap + liftE $ + Display c + <$> v .:? "orientationMap" .!= dOM + <*> v .:? "curOrientation" .!= (defD ^. curOrientation) + <*> (fmap (worldPrefix <>) <$> v .:? "attr") .!= (defD ^. displayAttr) + <*> v .:? "priority" .!= (defD ^. displayPriority) + <*> v .:? "invisible" .!= (defD ^. invisible) instance ToJSON Display where toJSON d = diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -97,6 +97,7 @@ import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Set (Set) +import Data.Set qualified as Set (fromList) import Data.Set.Lens (setOf) import Data.Text (Text) import Data.Text qualified as T @@ -219,7 +220,7 @@ -- grabbed. _entityYields :: Maybe Text , -- | Properties of the entity. - _entityProperties :: [EntityProperty] + _entityProperties :: Set EntityProperty , -- | Capabilities provided by this entity. _entityCapabilities :: [Capability] , -- | Inventory of other entities held by this entity. @@ -274,7 +275,7 @@ [Capability] -> Entity mkEntity disp nm descr props caps = - rehashEntity $ Entity 0 disp nm Nothing descr Nothing Nothing Nothing props caps empty + rehashEntity $ Entity 0 disp nm Nothing descr Nothing Nothing Nothing (Set.fromList props) caps empty ------------------------------------------------------------ -- Entity map @@ -330,7 +331,7 @@ <*> v .:? "orientation" <*> v .:? "growth" <*> v .:? "yields" - <*> v .:? "properties" .!= [] + <*> v .:? "properties" .!= mempty <*> v .:? "capabilities" .!= [] <*> pure empty ) @@ -431,7 +432,7 @@ entityYields = hashedLens _entityYields (\e x -> e {_entityYields = x}) -- | The properties enjoyed by this entity. -entityProperties :: Lens' Entity [EntityProperty] +entityProperties :: Lens' Entity (Set EntityProperty) entityProperties = hashedLens _entityProperties (\e x -> e {_entityProperties = x}) -- | Test whether an entity has a certain property. diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs --- a/src/Swarm/Game/Robot.hs +++ b/src/Swarm/Game/Robot.hs @@ -41,6 +41,7 @@ defReqs, defVals, defStore, + emptyRobotContext, -- ** Lenses robotEntity, @@ -95,13 +96,14 @@ import GHC.Generics (Generic) import Linear import Swarm.Game.CESK -import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay) +import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Value as V import Swarm.Language.Capability (Capability) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Requirement (ReqCtx) import Swarm.Language.Syntax (toDirection) +import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Types (TCtx) import Swarm.Util () import Swarm.Util.Yaml @@ -127,6 +129,31 @@ makeLenses ''RobotContext +emptyRobotContext :: RobotContext +emptyRobotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty emptyStore + +type instance Index RobotContext = Ctx.Var +type instance IxValue RobotContext = Typed Value + +instance Ixed RobotContext +instance At RobotContext where + at name = lens getter setter + where + getter ctx = + do + typ <- Ctx.lookup name (ctx ^. defTypes) + val <- Ctx.lookup name (ctx ^. defVals) + req <- Ctx.lookup name (ctx ^. defReqs) + return $ Typed val typ req + setter ctx Nothing = + ctx & defTypes %~ Ctx.delete name + & defVals %~ Ctx.delete name + & defReqs %~ Ctx.delete name + setter ctx (Just (Typed val typ req)) = + ctx & defTypes %~ Ctx.addBinding name typ + & defVals %~ Ctx.addBinding name val + & defReqs %~ Ctx.addBinding name req + data LogSource = Said | Logged | ErrorTrace deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) @@ -472,7 +499,7 @@ , _robotLog = Seq.empty , _robotLogUpdated = False , _robotLocation = loc - , _robotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty emptyStore + , _robotContext = emptyRobotContext , _robotID = rid , _robotParentID = pid , _robotHeavy = heavy @@ -489,20 +516,23 @@ -- | We can parse a robot from a YAML file if we have access to an -- 'EntityMap' in which we can look up the names of entities. instance FromJSONE EntityMap TRobot where - parseJSONE = withObjectE "robot" $ \v -> + parseJSONE = withObjectE "robot" $ \v -> do -- Note we can't generate a unique ID here since we don't have -- access to a 'State GameState' effect; a unique ID will be -- filled in later when adding the robot to the world. + sys <- liftE $ v .:? "system" .!= False + let defDisplay = defaultRobotDisplay & invisible .~ sys + mkRobot () Nothing <$> liftE (v .: "name") <*> liftE (v .:? "description" .!= []) <*> liftE (v .:? "loc") <*> liftE (v .:? "dir" .!= zero) - <*> liftE (v .:? "display" .!= defaultRobotDisplay) + <*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay) <*> liftE (mkMachine <$> (v .:? "program")) <*> v ..:? "devices" ..!= [] <*> v ..:? "inventory" ..!= [] - <*> liftE (v .:? "system" .!= False) + <*> pure sys <*> liftE (v .:? "heavy" .!= False) <*> pure 0 where diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -25,6 +25,7 @@ -- * WorldDescription Cell (..), WorldDescription (..), + IndexedTRobot, -- * Scenario Scenario, @@ -52,7 +53,6 @@ ) where import Control.Algebra (Has) -import Control.Arrow ((&&&)) import Control.Carrier.Lift (Lift, sendIO) import Control.Carrier.Throw.Either (Throw, throwError) import Control.Lens hiding (from, (<.>)) @@ -116,13 +116,17 @@ -- Robot map ------------------------------------------------------------ +-- | A robot template paired with its definition's index within +-- the Scenario file +type IndexedTRobot = (Int, TRobot) + -- | A map from names to robots, used to look up robots in scenario -- descriptions. -type RobotMap = Map Text TRobot +type RobotMap = Map Text IndexedTRobot -- | Create a 'RobotMap' from a list of robot templates. buildRobotMap :: [TRobot] -> RobotMap -buildRobotMap = M.fromList . map (view trobotName &&& id) +buildRobotMap rs = M.fromList $ zipWith (\x y -> (view trobotName y, (x, y))) [0 ..] rs ------------------------------------------------------------ -- Lookup utilities @@ -144,7 +148,7 @@ -- | Look up a robot by name in a 'RobotMap', throwing a parse error -- if it is not found. -getRobot :: Text -> ParserE RobotMap TRobot +getRobot :: Text -> ParserE RobotMap IndexedTRobot getRobot = getThing "robot" M.lookup ------------------------------------------------------------ @@ -156,7 +160,7 @@ data Cell = Cell { cellTerrain :: TerrainType , cellEntity :: Maybe Entity - , cellRobots :: [TRobot] + , cellRobots :: [IndexedTRobot] } deriving (Eq, Show) diff --git a/src/Swarm/Game/ScenarioInfo.hs b/src/Swarm/Game/ScenarioInfo.hs --- a/src/Swarm/Game/ScenarioInfo.hs +++ b/src/Swarm/Game/ScenarioInfo.hs @@ -25,6 +25,7 @@ scenarioBestTime, scenarioBestTicks, updateScenarioInfoOnQuit, + ScenarioInfoPair, -- * Scenario collection ScenarioCollection (..), @@ -130,6 +131,8 @@ toEncoding = genericToEncoding scenarioOptions toJSON = genericToJSON scenarioOptions +type ScenarioInfoPair = (Scenario, ScenarioInfo) + scenarioOptions :: Options scenarioOptions = defaultOptions @@ -173,12 +176,12 @@ -- | A scenario item is either a specific scenario, or a collection of -- scenarios (*e.g.* the scenarios contained in a subdirectory). -data ScenarioItem = SISingle Scenario ScenarioInfo | SICollection Text ScenarioCollection +data ScenarioItem = SISingle ScenarioInfoPair | SICollection Text ScenarioCollection deriving (Eq, Show) -- | Retrieve the name of a scenario item. scenarioItemName :: ScenarioItem -> Text -scenarioItemName (SISingle s _ss) = s ^. scenarioName +scenarioItemName (SISingle (s, _ss)) = s ^. scenarioName scenarioItemName (SICollection name _) = name -- | A scenario collection is a tree of scenarios, keyed by name, @@ -330,7 +333,7 @@ False -> do s <- loadScenarioFile em path si <- loadScenarioInfo path - return $ SISingle s si + return $ SISingle (s, si) ------------------------------------------------------------ -- Some lenses + prisms diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -38,6 +38,7 @@ robotsByLocation, robotsAtLocation, robotsInArea, + baseRobot, activeRobots, waitingRobots, availableRecipes, @@ -61,6 +62,7 @@ viewCenter, needsRedraw, replStatus, + replNextValueIndex, replWorking, replActiveType, messageQueue, @@ -79,6 +81,7 @@ scenarioToGameState, initGameStateForScenario, classicGame0, + CodeToRun (..), -- * Utilities applyViewCenterRule, @@ -117,7 +120,7 @@ import Data.IntSet (IntSet) import Data.IntSet qualified as IS import Data.IntSet.Lens (setOf) -import Data.List (partition) +import Data.List (partition, sortOn) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map (Map) @@ -153,6 +156,7 @@ import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Language.Pipeline.QQ (tmQ) import Swarm.Language.Syntax (Const, Term (TText), allConst) +import Swarm.Language.Typed (Typed (Typed)) import Swarm.Language.Types import Swarm.Util (getDataFileNameSafe, getElemsInArea, isRightOr, manhattan, uniq, (<+=), (<<.=), (?)) import System.Clock qualified as Clock @@ -163,6 +167,10 @@ -- Subsidiary data types ------------------------------------------------------------ +data CodeToRun + = SuggestedSolution ProcessedTerm + | ScriptPath FilePath + -- | The 'ViewCenterRule' specifies how to determine the center of the -- world viewport. data ViewCenterRule @@ -178,12 +186,12 @@ data REPLStatus = -- | The REPL is not doing anything actively at the moment. -- We persist the last value and its type though. - REPLDone (Maybe (Polytype, Value)) + REPLDone (Maybe (Typed Value)) | -- | A command entered at the REPL is currently being run. The -- 'Polytype' represents the type of the expression that was -- entered. The @Maybe Value@ starts out as @Nothing@ and gets -- filled in with a result once the command completes. - REPLWorking Polytype (Maybe Value) + REPLWorking (Typed (Maybe Value)) deriving (Eq, Show, Generic, FromJSON, ToJSON) data WinCondition @@ -285,6 +293,7 @@ , _viewCenter :: V2 Int64 , _needsRedraw :: Bool , _replStatus :: REPLStatus + , _replNextValueIndex :: Integer , _messageQueue :: Seq LogEntry , _lastSeenMessageTime :: Integer , _focusedRobotID :: RID @@ -361,6 +370,10 @@ rl = gs ^. robotsByLocation rids = concatMap IS.elems $ getElemsInArea o d rl +-- | The base robot, if it exists. +baseRobot :: Traversal' GameState Robot +baseRobot = robotMap . ix 0 + -- | The list of entities that have been discovered. allDiscoveredEntities :: Lens' GameState Inventory @@ -442,6 +455,9 @@ -- | The current status of the REPL. replStatus :: Lens' GameState REPLStatus +-- | The index of the next it{index} value +replNextValueIndex :: Lens' GameState Integer + -- | A queue of global messages. -- -- Note that we put the newest entry to the right. @@ -499,14 +515,14 @@ replWorking = to (\s -> matchesWorking $ s ^. replStatus) where matchesWorking (REPLDone _) = False - matchesWorking (REPLWorking _ _) = True + matchesWorking (REPLWorking _) = True -- | Either the type of the command being executed, or of the last command replActiveType :: Getter REPLStatus (Maybe Polytype) replActiveType = to getter where - getter (REPLDone (Just (typ, _))) = Just typ - getter (REPLWorking typ _) = Just typ + getter (REPLDone (Just (Typed _ typ _))) = Just typ + getter (REPLWorking (Typed _ typ _)) = Just typ getter _ = Nothing -- | Get the notification list of messages from the point of view of focused robot. @@ -714,6 +730,7 @@ , _viewCenter = V2 0 0 , _needsRedraw = False , _replStatus = REPLDone Nothing + , _replNextValueIndex = 0 , _messageQueue = Empty , _lastSeenMessageTime = -1 , _focusedRobotID = 0 @@ -722,7 +739,7 @@ } -- | Set a given scenario as the currently loaded scenario in the game state. -scenarioToGameState :: Scenario -> Maybe Seed -> Maybe String -> GameState -> IO GameState +scenarioToGameState :: Scenario -> Maybe Seed -> Maybe CodeToRun -> GameState -> IO GameState scenarioToGameState scenario userSeed toRun g = do -- Decide on a seed. In order of preference, we will use: -- 1. seed value provided by the user @@ -764,7 +781,8 @@ -- otherwise the store of definition cells is not saved (see #333) _replStatus = case toRun of Nothing -> REPLDone Nothing - Just _ -> REPLWorking PolyUnit Nothing + Just _ -> REPLWorking (Typed Nothing PolyUnit mempty) + , _replNextValueIndex = 0 , _messageQueue = Empty , _focusedRobotID = baseID , _ticks = 0 @@ -779,14 +797,42 @@ -- the others existed only to serve as a template for robots drawn -- in the world map locatedRobots = filter (isJust . view trobotLocation) $ scenario ^. scenarioRobots + getCodeToRun x = case x of + SuggestedSolution s -> s + ScriptPath (into @Text -> f) -> [tmQ| run($str:f) |] + + -- Rules for selecting the "base" robot: + -- ------------------------------------- + -- What follows is a thorough description of how the base + -- choice is made as of the most recent study of the code. + -- This level of detail is not meant to be public-facing. + -- + -- For an abbreviated explanation, see the "Base robot" section of the + -- "Scenario Authoring Guide". + -- https://github.com/swarm-game/swarm/tree/main/data/scenarios#base-robot + -- + -- Precedence rules: + -- 1. Prefer those robots defined with a loc in the Scenario file + -- 1.a. If multiple robots define a loc, use the robot that is defined + -- first within the Scenario file. + -- 1.b. Note that if a robot is both given a loc AND is specified in the + -- world map, then two instances of the robot shall be created. The + -- instance with the loc shall be preferred as the base. + -- 2. Fall back to robots generated from templates via the map and palette. + -- 2.a. If multiple robots are specified in the map, prefer the one that + -- is defined first within the Scenario file. + -- 2.b. If multiple robots are instantiated from the same template, then + -- prefer the one closest to the upper-left of the screen, with higher rows given precedence over columns. + robotsByBasePrecedence = locatedRobots ++ map snd (sortOn fst genRobots) + robotList = - zipWith instantiateRobot [baseID ..] (locatedRobots ++ genRobots) + zipWith instantiateRobot [baseID ..] robotsByBasePrecedence -- If the --run flag was used, use it to replace the CESK machine of the -- robot whose id is 0, i.e. the first robot listed in the scenario. & ix baseID . machine - %~ case toRun of + %~ case getCodeToRun <$> toRun of Nothing -> id - Just (into @Text -> f) -> const (initMachine [tmQ| run($str:f) |] Ctx.empty emptyStore) + Just pt -> const $ initMachine pt Ctx.empty emptyStore -- If we are in creative mode, give base all the things & ix baseID . robotInventory %~ case scenario ^. scenarioCreative of @@ -817,7 +863,7 @@ -- | Take a world description, parsed from a scenario file, and turn -- it into a list of located robots and a world function. -buildWorld :: EntityMap -> WorldDescription -> ([TRobot], Seed -> WorldFun Int Entity) +buildWorld :: EntityMap -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity) buildWorld em WorldDescription {..} = (robots, first fromEnum . wf) where rs = fromIntegral $ length area @@ -836,7 +882,7 @@ Just (Cell t e _) -> const (worldFunFromArray worldArray (t, e)) -- Get all the robots described in cells and set their locations appropriately - robots :: [TRobot] + robots :: [IndexedTRobot] robots = area & traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices @@ -844,15 +890,18 @@ & concatMap ( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robotList) -> let robotWithLoc = trobotLocation ?~ W.coordsToLoc (Coords (ulr + r, ulc + c)) - in map robotWithLoc robotList + in map (fmap robotWithLoc) robotList ) -- | Create an initial game state for a specific scenario. -initGameStateForScenario :: String -> Maybe Seed -> Maybe String -> ExceptT Text IO GameState +-- Note that this function is used only for unit tests, integration tests, and benchmarks. +-- +-- In normal play, the code path that gets executed is scenarioToAppState. +initGameStateForScenario :: String -> Maybe Seed -> Maybe FilePath -> ExceptT Text IO GameState initGameStateForScenario sceneName userSeed toRun = do g <- initGameState (scene, path) <- loadScenario sceneName (g ^. entityMap) - gs <- liftIO $ scenarioToGameState scene userSeed toRun g + gs <- liftIO $ scenarioToGameState scene userSeed (ScriptPath <$> toRun) g normalPath <- liftIO $ normalizeScenarioPath (gs ^. scenarios) path t <- liftIO getZonedTime return $ @@ -862,5 +911,6 @@ -- | For convenience, the 'GameState' corresponding to the classic -- game with seed 0. +-- This is used only for benchmarks and unit tests. classicGame0 :: ExceptT Text IO GameState classicGame0 = initGameStateForScenario "classic" (Just 0) Nothing diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -17,6 +17,7 @@ -- interpreter for the Swarm language. module Swarm.Game.Step where +import Control.Applicative (liftA2) import Control.Carrier.Error.Either (runError) import Control.Carrier.State.Lazy import Control.Carrier.Throw.Either (ThrowC, runThrow) @@ -65,6 +66,7 @@ import Swarm.Language.Pipeline.QQ (tmQ) import Swarm.Language.Requirement qualified as R import Swarm.Language.Syntax +import Swarm.Language.Typed (Typed (..)) import Swarm.Util import System.Clock (TimeSpec) import System.Clock qualified @@ -110,10 +112,10 @@ Just r -> do res <- use replStatus case res of - REPLWorking ty Nothing -> case getResult r of + REPLWorking (Typed Nothing ty req) -> case getResult r of Just (v, s) -> do - replStatus .= REPLWorking ty (Just v) - robotMap . ix 0 . robotContext . defStore .= s + replStatus .= REPLWorking (Typed (Just v) ty req) + baseRobot . robotContext . defStore .= s Nothing -> return () _otherREPLStatus -> return () Nothing -> return () @@ -1103,14 +1105,16 @@ Listen -> do gs <- get @GameState loc <- use robotLocation + rid <- use robotID creative <- use creativeMode system <- use systemRobot mq <- use messageQueue - let recentAndClose e = system || creative || messageIsRecent gs e && messageIsFromNearby loc e - limitLast = \case + let isClose e = system || creative || messageIsFromNearby loc e + let notMine e = rid /= e ^. leRobotID + let limitLast = \case _s Seq.:|> l -> Just $ l ^. leText _ -> Nothing - mm = limitLast $ Seq.takeWhileR recentAndClose mq + let mm = limitLast . Seq.filter (liftA2 (&&) notMine isClose) $ Seq.takeWhileR (messageIsRecent gs) mq return $ maybe (In (TConst Listen) mempty s (FExec : k)) -- continue listening @@ -1344,7 +1348,7 @@ ["A robot built by the robot named " <> r ^. robotName <> "."] (Just (r ^. robotLocation)) ( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir) - ? east + ? north ) defaultRobotDisplay (In cmd e s [FExec]) diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -75,11 +75,11 @@ -- | Convert an (x,y) location to a 'Coords' value. locToCoords :: V2 Int64 -> Coords -locToCoords (V2 x y) = Coords (- y, x) +locToCoords (V2 x y) = Coords (-y, x) -- | Convert 'Coords' to an (x,y) location. coordsToLoc :: Coords -> V2 Int64 -coordsToLoc (Coords (r, c)) = V2 c (- r) +coordsToLoc (Coords (r, c)) = V2 c (-r) ------------------------------------------------------------ -- World function diff --git a/src/Swarm/Game/WorldGen.hs b/src/Swarm/Game/WorldGen.hs --- a/src/Swarm/Game/WorldGen.hs +++ b/src/Swarm/Game/WorldGen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Swarm.Game.WorldGen @@ -14,12 +15,14 @@ import Data.Array.IArray import Data.Bifunctor (second) import Data.Bool +import Data.ByteString (ByteString) import Data.Enumeration import Data.Hash.Murmur import Data.Int (Int64) import Data.List (find) import Data.Maybe (fromMaybe, mapMaybe) import Data.Set qualified as S +import Data.Tagged import Data.Text (Text) import Data.Text qualified as T import Numeric.Noise.Perlin @@ -27,6 +30,7 @@ import Swarm.Game.Terrain import Swarm.Game.World import Witch +import Witch.Encoding qualified as Encoding -- | A simple test world used for a while during early development. testWorld1 :: Coords -> (TerrainType, Maybe Text) @@ -92,7 +96,7 @@ (bool Soft Hard (sample ix pn1 > 0)) (bool Natural Artificial (sample ix pn2 > 0)) where - h = murmur3 0 . into . show $ ix + h = murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ ix genBiome Big Hard Natural | sample ix cl0 > 0.5 = (StoneT, Just "mountain") diff --git a/src/Swarm/Language/Parse.hs b/src/Swarm/Language/Parse.hs --- a/src/Swarm/Language/Parse.hs +++ b/src/Swarm/Language/Parse.hs @@ -81,7 +81,8 @@ reservedWords = map (syntax . constInfo) (filter isUserFunc allConst) ++ map (dirSyntax . dirInfo) allDirs - ++ [ "unit" + ++ [ "void" + , "unit" , "int" , "text" , "dir" @@ -204,7 +205,8 @@ parseTypeAtom :: Parser Type parseTypeAtom = - TyUnit <$ reserved "unit" + TyVoid <$ reserved "void" + <|> TyUnit <$ reserved "unit" <|> TyVar <$> identifier <|> TyInt <$ reserved "int" <|> TyText <$ reserved "text" diff --git a/src/Swarm/Language/Pretty.hs b/src/Swarm/Language/Pretty.hs --- a/src/Swarm/Language/Pretty.hs +++ b/src/Swarm/Language/Pretty.hs @@ -55,6 +55,7 @@ pparens False = id instance PrettyPrec BaseTy where + prettyPrec _ BVoid = "void" prettyPrec _ BUnit = "unit" prettyPrec _ BInt = "int" prettyPrec _ BDir = "dir" diff --git a/src/Swarm/Language/Typecheck.hs b/src/Swarm/Language/Typecheck.hs --- a/src/Swarm/Language/Typecheck.hs +++ b/src/Swarm/Language/Typecheck.hs @@ -42,6 +42,7 @@ check, decomposeCmdTy, decomposeFunTy, + isSimpleUType, ) where import Control.Category ((>>>)) diff --git a/src/Swarm/Language/Typed.hs b/src/Swarm/Language/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Typed.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Swarm.Language.Typed (Typed (..), value, polytype, requires) where + +import Control.Lens (makeLenses) +import Data.Aeson (ToJSON) +import Data.Aeson.Types (FromJSON) +import GHC.Generics (Generic) +import Swarm.Language.Requirement (Requirements) +import Swarm.Language.Types (Polytype) + +-- | A value, or a hole, or something else that has its type & requirements fixed +data Typed v = Typed + { _value :: v + , _polytype :: Polytype + , _requires :: Requirements + } + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +makeLenses ''Typed diff --git a/src/Swarm/Language/Types.hs b/src/Swarm/Language/Types.hs --- a/src/Swarm/Language/Types.hs +++ b/src/Swarm/Language/Types.hs @@ -23,6 +23,7 @@ tyVars, pattern TyBase, pattern TyVar, + pattern TyVoid, pattern TyUnit, pattern TyInt, pattern TyText, @@ -39,6 +40,7 @@ UType, pattern UTyBase, pattern UTyVar, + pattern UTyVoid, pattern UTyUnit, pattern UTyInt, pattern UTyText, @@ -97,7 +99,9 @@ -- | Base types. data BaseTy - = -- | The unit type, with a single inhabitant. + = -- | The void type, with no inhabitants. + BVoid + | -- | The unit type, with a single inhabitant. BUnit | -- | Signed, arbitrary-size integers. BInt @@ -290,6 +294,9 @@ pattern TyVar :: Var -> Type pattern TyVar v = Fix (TyVarF v) +pattern TyVoid :: Type +pattern TyVoid = Fix (TyBaseF BVoid) + pattern TyUnit :: Type pattern TyUnit = Fix (TyBaseF BUnit) @@ -334,6 +341,9 @@ pattern UTyVar :: Var -> UType pattern UTyVar v = UTerm (TyVarF v) + +pattern UTyVoid :: UType +pattern UTyVoid = UTerm (TyBaseF BVoid) pattern UTyUnit :: UType pattern UTyUnit = UTerm (TyBaseF BUnit) diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -40,8 +40,8 @@ import Brick hiding (Direction) import Brick.Focus -import Brick.Forms import Brick.Widgets.Dialog +import Brick.Widgets.Edit (handleEditorEvent) import Brick.Widgets.List (handleListEvent) import Brick.Widgets.List qualified as BL import Control.Carrier.Lift qualified as Fused @@ -57,6 +57,7 @@ import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.String (fromString) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Time (getZonedTime) @@ -77,7 +78,9 @@ import Swarm.Language.Pretty import Swarm.Language.Requirement qualified as R import Swarm.Language.Syntax +import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Types +import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) import Swarm.TUI.List import Swarm.TUI.Model import Swarm.TUI.View (generateModal) @@ -155,10 +158,10 @@ -- Extract the first tutorial challenge and run it let firstTutorial = case scOrder tutorialCollection of Just (t : _) -> case M.lookup t (scMap tutorialCollection) of - Just (SISingle scene si) -> (scene, si) + Just (SISingle siPair) -> siPair _ -> error "No first tutorial found!" _ -> error "No first tutorial found!" - uncurry startGame firstTutorial Nothing + startGame firstTutorial Nothing Messages -> do runtimeState . eventLog . notificationsCount .= 0 uiState . uiMenu .= MessagesMenu @@ -194,7 +197,7 @@ Key V.KEnter -> case snd <$> BL.listSelectedElement curMenu of Nothing -> continueWithoutRedraw - Just (SISingle scene si) -> startGame scene si Nothing + Just (SISingle siPair) -> startGame siPair Nothing Just (SICollection _ c) -> do cheat <- use $ uiState . uiCheatMode uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList cheat c) scenarioStack) @@ -255,6 +258,16 @@ ControlKey 'g' -> case s ^. uiState . uiGoal of Just g | g /= [] -> toggleModal (GoalModal g) _ -> continueWithoutRedraw + MetaKey 'h' -> do + t <- liftIO $ getTime Monotonic + h <- use $ uiState . uiHideRobotsUntil + if h >= t + then -- ignore repeated keypresses + continueWithoutRedraw + else -- hide for two seconds + do + uiState . uiHideRobotsUntil .= t + TimeSpec 2 0 + invalidateCacheEntry WorldCache -- pausing and stepping ControlKey 'p' | isRunning -> safeTogglePause ControlKey 'o' | isRunning -> do @@ -279,10 +292,10 @@ WorldPanel -> do mouseCoordsM <- Brick.zoom gameState (mouseLocToWorldCoords mouseLoc) uiState . uiWorldCursor .= mouseCoordsM - REPLPanel -> - -- Do not clear the world cursor when going back to the REPL - continueWithoutRedraw - _ -> uiState . uiWorldCursor .= Nothing >> continueWithoutRedraw + REPLInput -> do + setFocus REPLPanel + handleREPLEvent ev + _ -> continueWithoutRedraw MouseUp n _ _mouseLoc -> do case n of InventoryListItem pos -> uiState . uiInventory . traverse . _2 %= BL.listMoveTo pos @@ -370,7 +383,9 @@ toggleModal QuitModal case dialogSelection <$> mdialog of Just (Just QuitButton) -> quitGame - Just (Just (NextButton scene)) -> saveScenarioInfoOnQuit >> uncurry startGame scene Nothing + Just (Just KeepPlayingButton) -> toggleModal KeepPlayingModal + Just (Just (StartOverButton currentSeed siPair)) -> restartGame currentSeed siPair + Just (Just (NextButton siPair)) -> saveScenarioInfoOnQuit >> startGame siPair Nothing _ -> return () ev -> do Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev) @@ -419,7 +434,7 @@ -- * returns to the previous menu quitGame :: EventM Name AppState () quitGame = do - history <- use $ uiState . uiReplHistory + history <- use $ uiState . uiREPL . replHistory let hist = mapMaybe getREPLEntry $ getLatestREPLHistoryItems maxBound history liftIO $ (`T.appendFile` T.unlines hist) =<< getSwarmHistoryPath True saveScenarioInfoOnQuit @@ -582,16 +597,22 @@ -- Now check if the base finished running a program entered at the REPL. replUpdated <- case g ^. replStatus of -- It did, and the result was the unit value. Just reset replStatus. - REPLWorking _ (Just VUnit) -> do - gameState . replStatus .= REPLDone (Just (PolyUnit, VUnit)) + REPLWorking (Typed (Just VUnit) typ reqs) -> do + gameState . replStatus .= REPLDone (Just $ Typed VUnit typ reqs) pure True -- It did, and returned some other value. Pretty-print the -- result as a REPL output, with its type, and reset the replStatus. - REPLWorking pty (Just v) -> do - let out = T.intercalate " " [into (prettyValue v), ":", prettyText (stripCmd pty)] - uiState . uiReplHistory %= addREPLItem (REPLOutput out) - gameState . replStatus .= REPLDone (Just (pty, v)) + REPLWorking (Typed (Just v) pty reqs) -> do + let finalType = stripCmd pty + let val = Typed v finalType reqs + itIx <- use (gameState . replNextValueIndex) + let itName = fromString $ "it" ++ show itIx + let out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] + uiState . uiREPL . replHistory %= addREPLItem (REPLOutput out) + gameState . replStatus .= REPLDone (Just val) + gameState . baseRobot . robotContext . at itName .= Just val + gameState . replNextValueIndex %= (+ 1) pure True -- Otherwise, do nothing. @@ -677,6 +698,8 @@ gs <- use gameState gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size)) +-- | Strips top-level `cmd` from type (in case of REPL evaluation), +-- and returns a boolean to indicate if it happened stripCmd :: Polytype -> Polytype stripCmd (Forall xs (TyCmd ty)) = Forall xs ty stripCmd pty = pty @@ -685,147 +708,195 @@ -- REPL events ------------------------------------------------------------ +-- | Set the REPLForm to the given value, resetting type error checks to Nothing +-- and removing uiError. +resetREPL :: T.Text -> REPLPrompt -> UIState -> UIState +resetREPL t r ui = + ui + & uiREPL . replPromptText .~ t + & uiREPL . replPromptType .~ r + & uiError .~ Nothing + -- | Handle a user input event for the REPL. handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEvent = \case ControlKey 'c' -> do - gameState . robotMap . ix 0 . machine %= cancel - uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "") + gameState . baseRobot . machine %= cancel + uiState . uiREPL . replPromptType .= CmdPrompt [] Key V.KEnter -> do s <- get - let entry = formState (s ^. uiState . uiReplForm) - topTypeCtx = s ^. gameState . robotMap . ix 0 . robotContext . defTypes - topReqCtx = s ^. gameState . robotMap . ix 0 . robotContext . defReqs - topValCtx = s ^. gameState . robotMap . ix 0 . robotContext . defVals - topStore = - fromMaybe emptyStore $ - s ^? gameState . robotMap . at 0 . _Just . robotContext . defStore - startBaseProgram t@(ProcessedTerm _ (Module ty _) _ _) = - (gameState . replStatus .~ REPLWorking ty Nothing) - . (gameState . robotMap . ix 0 . machine .~ initMachine t topValCtx topStore) + let topCtx = topContext s + repl = s ^. uiState . uiREPL + uinput = repl ^. replPromptText + + startBaseProgram t@(ProcessedTerm _ (Module ty _) reqs _) = + (gameState . replStatus .~ REPLWorking (Typed Nothing ty reqs)) + . (gameState . baseRobot . machine .~ initMachine t (topCtx ^. defVals) (topCtx ^. defStore)) . (gameState %~ execState (activateRobot 0)) if not $ s ^. gameState . replWorking - then case entry of - CmdPrompt uinput _ -> - case processTerm' topTypeCtx topReqCtx uinput of + then case repl ^. replPromptType of + CmdPrompt _ -> + case processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput of Right mt -> do - uiState %= resetWithREPLForm (set promptUpdateL "" (s ^. uiState)) - uiState . uiReplHistory %= addREPLItem (REPLEntry uinput) + uiState %= resetREPL "" (CmdPrompt []) + uiState . uiREPL . replHistory %= addREPLItem (REPLEntry uinput) modify $ maybe id startBaseProgram mt Left err -> uiState . uiError ?= err - SearchPrompt t hist -> - case lastEntry t hist of - Nothing -> uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "") + SearchPrompt hist -> + case lastEntry uinput hist of + Nothing -> uiState %= resetREPL "" (CmdPrompt []) Just found - | T.null t -> uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "") + | T.null uinput -> uiState %= resetREPL "" (CmdPrompt []) | otherwise -> do - uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt found) + uiState %= resetREPL found (CmdPrompt []) modify validateREPLForm else continueWithoutRedraw Key V.KUp -> modify $ adjReplHistIndex Older Key V.KDown -> modify $ adjReplHistIndex Newer ControlKey 'r' -> do s <- get - case s ^. uiState . uiReplForm . to formState of - CmdPrompt uinput _ -> - let newform = mkReplForm $ SearchPrompt uinput (s ^. uiState . uiReplHistory) - in uiState . uiReplForm .= newform - SearchPrompt ftext rh -> case lastEntry ftext rh of + let uinput = s ^. uiState . uiREPL . replPromptText + case s ^. uiState . uiREPL . replPromptType of + CmdPrompt _ -> uiState . uiREPL . replPromptType .= SearchPrompt (s ^. uiState . uiREPL . replHistory) + SearchPrompt rh -> case lastEntry uinput rh of Nothing -> pure () - Just found -> - let newform = mkReplForm $ SearchPrompt ftext (removeEntry found rh) - in uiState . uiReplForm .= newform + Just found -> uiState . uiREPL . replPromptType .= SearchPrompt (removeEntry found rh) CharKey '\t' -> do - formSt <- use $ uiState . uiReplForm . to formState - newform <- gets $ mkReplForm . flip tabComplete formSt - uiState . uiReplForm .= newform + s <- get + let names = s ^.. gameState . baseRobot . robotContext . defTypes . to assocs . traverse . _1 + uiState . uiREPL %= tabComplete names (s ^. gameState . entityMap) modify validateREPLForm EscapeKey -> do - formSt <- use $ uiState . uiReplForm . to formState + formSt <- use $ uiState . uiREPL . replPromptType case formSt of CmdPrompt {} -> continueWithoutRedraw - SearchPrompt _ _ -> - uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "") + SearchPrompt _ -> + uiState %= resetREPL "" (CmdPrompt []) ControlKey 'd' -> do - text <- use $ uiState . uiReplForm . to formState . promptTextL + text <- use $ uiState . uiREPL . replPromptText if text == T.empty then toggleModal QuitModal else continueWithoutRedraw + -- finally if none match pass the event to the editor ev -> do - replForm <- use $ uiState . uiReplForm - f' <- nestEventM' replForm (handleFormEvent ev) - case formState f' of - CmdPrompt {} -> do - uiState . uiReplForm .= f' - modify validateREPLForm - SearchPrompt t _ -> do - -- TODO: why does promptUpdateL not update the uiState? - newform <- use $ uiState . to (set promptUpdateL t) - uiState . uiReplForm .= newform + Brick.zoom (uiState . uiREPL . replPromptEditor) (handleEditorEvent ev) + uiState . uiREPL . replPromptType %= \case + CmdPrompt _ -> CmdPrompt [] -- reset completions on any event passed to editor + SearchPrompt a -> SearchPrompt a + modify validateREPLForm --- | Try to complete the last word in a partially entered REPL prompt using --- things reserved words and names in scope. -tabComplete :: AppState -> REPLPrompt -> REPLPrompt -tabComplete _ p@(SearchPrompt {}) = p -tabComplete s (CmdPrompt t mms) - | (m : ms) <- mms = CmdPrompt (replaceLast m t) (ms ++ [m]) - | T.null lastWord = CmdPrompt t [] - | otherwise = case matches of - [] -> CmdPrompt t [] - [m] -> CmdPrompt (completeWith m) [] - (m : ms) -> CmdPrompt (completeWith m) (ms ++ [m]) +data CompletionType + = FunctionName + | EntityName + deriving (Eq) + +-- | Try to complete the last word in a partially-entered REPL prompt using +-- reserved words and names in scope (in the case of function names) or +-- entity names (in the case of string literals). +tabComplete :: [Var] -> EntityMap -> REPLState -> REPLState +tabComplete names em repl = case repl ^. replPromptType of + SearchPrompt _ -> repl + CmdPrompt mms + -- Case 1: If completion candidates have already been + -- populated via case (3), cycle through them. + -- Note that tabbing through the candidates *does* update the value + -- of "t", which one might think would narrow the candidate list + -- to only that match and therefore halt the cycling. + -- However, the candidate list only gets recomputed (repopulated) + -- if the user subsequently presses a non-Tab key. Thus the current + -- value of "t" is ignored for all Tab presses subsequent to the + -- first. + | (m : ms) <- mms -> setCmd (replacementFunc m) (ms ++ [m]) + -- Case 2: Require at least one letter to be typed in order to offer completions for + -- function names. + -- We allow suggestions for Entity Name strings without anything having been typed. + | T.null lastWord && completionType == FunctionName -> setCmd t [] + -- Case 3: Typing another character in the REPL clears the completion candidates from + -- the CmdPrompt, so when Tab is pressed again, this case then gets executed and + -- repopulates them. + | otherwise -> case candidateMatches of + [] -> setCmd t [] + [m] -> setCmd (completeWith m) [] + -- Perform completion with the first candidate, then populate the list + -- of all candidates with the current completion moved to the back + -- of the queue. + (m : ms) -> setCmd (completeWith m) (ms ++ [m]) where - completeWith m = T.append t (T.drop (T.length lastWord) m) - lastWord = T.takeWhileEnd isIdentChar t - names = s ^.. gameState . robotMap . ix 0 . robotContext . defTypes . to assocs . traverse . _1 + -- checks the "parity" of the number of quotes. If odd, then there is an open quote. + hasOpenQuotes = (== 1) . (`mod` 2) . T.count "\"" + + completionType = + if hasOpenQuotes t + then EntityName + else FunctionName + + replacementFunc = T.append $ T.dropWhileEnd replacementBoundaryPredicate t + completeWith m = T.append t $ T.drop (T.length lastWord) m + lastWord = T.takeWhileEnd replacementBoundaryPredicate t + candidateMatches = filter (lastWord `T.isPrefixOf`) replacementCandidates + + (replacementCandidates, replacementBoundaryPredicate) = case completionType of + EntityName -> (entityNames, (/= '"')) + FunctionName -> (possibleWords, isIdentChar) + possibleWords = reservedWords ++ names - matches = filter (lastWord `T.isPrefixOf`) possibleWords + entityNames = M.keys $ entitiesByName em + + t = repl ^. replPromptText + setCmd nt ms = + repl + & replPromptText .~ nt + & replPromptType .~ CmdPrompt ms + -- | Validate the REPL input when it changes: see if it parses and -- typechecks, and set the color accordingly. validateREPLForm :: AppState -> AppState validateREPLForm s = case replPrompt of - CmdPrompt "" _ -> - let theType = s ^. gameState . replStatus . replActiveType - in s & uiState . uiReplType .~ theType - CmdPrompt uinput _ -> - let result = processTerm' topTypeCtx topReqCtx uinput - theType = case result of - Right (Just (ProcessedTerm _ (Module ty _) _ _)) -> Just ty - _ -> Nothing - in s - & uiState . uiReplForm %~ validate result - & uiState . uiReplType .~ theType - SearchPrompt _ _ -> s + CmdPrompt _ + | T.null uinput -> + let theType = s ^. gameState . replStatus . replActiveType + in s & uiState . uiREPL . replType .~ theType + CmdPrompt _ + | otherwise -> + let result = processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput + theType = case result of + Right (Just (ProcessedTerm _ (Module ty _) _ _)) -> Just ty + _ -> Nothing + in s + & uiState . uiREPL . replValid .~ isRight result + & uiState . uiREPL . replType .~ theType + SearchPrompt _ -> s where - replPrompt = s ^. uiState . uiReplForm . to formState - topTypeCtx = s ^. gameState . robotMap . ix 0 . robotContext . defTypes - topReqCtx = s ^. gameState . robotMap . ix 0 . robotContext . defReqs - validate result = setFieldValid (isRight result) REPLInput + uinput = s ^. uiState . uiREPL . replPromptText + replPrompt = s ^. uiState . uiREPL . replPromptType + topCtx = topContext s -- | Update our current position in the REPL history. adjReplHistIndex :: TimeDir -> AppState -> AppState adjReplHistIndex d s = - ns - & (if replIndexIsAtInput (s ^. repl) then saveLastEntry else id) - & (if oldEntry /= newEntry then showNewEntry else id) + s + & uiState . uiREPL %~ moveREPL & validateREPLForm where - -- new AppState after moving the repl index - ns = s & repl %~ moveReplHistIndex d oldEntry - - repl :: Lens' AppState REPLHistory - repl = uiState . uiReplHistory + moveREPL :: REPLState -> REPLState + moveREPL repl = + newREPL + & (if replIndexIsAtInput (repl ^. replHistory) then saveLastEntry else id) + & (if oldEntry /= newEntry then showNewEntry else id) + where + -- new AppState after moving the repl index + newREPL :: REPLState + newREPL = repl & replHistory %~ moveReplHistIndex d oldEntry - replLast = s ^. uiState . uiReplLast - saveLastEntry = uiState . uiReplLast .~ (s ^. uiState . uiReplForm . to formState . promptTextL) - showNewEntry = uiState . uiReplForm %~ updateFormState (mkCmdPrompt newEntry) - -- get REPL data - getCurrEntry = fromMaybe replLast . getCurrentItemText . view repl - oldEntry = getCurrEntry s - newEntry = getCurrEntry ns + saveLastEntry = replLast .~ (repl ^. replPromptText) + showNewEntry = (replPromptEditor .~ newREPLEditor newEntry) . (replPromptType .~ CmdPrompt []) + -- get REPL data + getCurrEntry = fromMaybe (repl ^. replLast) . getCurrentItemText . view replHistory + oldEntry = getCurrEntry repl + newEntry = getCurrEntry newREPL ------------------------------------------------------------ -- World events @@ -901,6 +972,12 @@ (CharKey '0') -> do uiState . uiInventoryShouldUpdate .= True uiState . uiShowZero %= not + (CharKey ';') -> do + uiState . uiInventoryShouldUpdate .= True + uiState . uiInventorySort %= cycleSortOrder + (CharKey ':') -> do + uiState . uiInventoryShouldUpdate .= True + uiState . uiInventorySort %= cycleSortDirection (VtyEvent ev) -> do -- This does not work we want to skip redrawing in the no-list case -- Brick.zoom (uiState . uiInventory . _Just . _2) (handleListEventWithSeparators ev (is _Separator)) @@ -918,16 +995,17 @@ makeEntity e = do s <- get let mkTy = PolyUnit + mkReq = R.singletonCap CMake mkProg = TApp (TConst Make) (TText (e ^. entityName)) - mkPT = ProcessedTerm mkProg (Module mkTy empty) (R.singletonCap CMake) empty + mkPT = ProcessedTerm mkProg (Module mkTy empty) mkReq empty topStore = fromMaybe emptyStore $ - s ^? gameState . robotMap . at 0 . _Just . robotContext . defStore + s ^? gameState . baseRobot . robotContext . defStore - case isActive <$> (s ^. gameState . robotMap . at 0) of + case isActive <$> (s ^? gameState . baseRobot) of Just False -> do - gameState . replStatus .= REPLWorking mkTy Nothing - gameState . robotMap . ix 0 . machine .= initMachine mkPT empty topStore + gameState . replStatus .= REPLWorking (Typed Nothing mkTy mkReq) + gameState . baseRobot . machine .= initMachine mkPT empty topStore gameState %= execState (activateRobot 0) _ -> continueWithoutRedraw diff --git a/src/Swarm/TUI/Inventory/Sorting.hs b/src/Swarm/TUI/Inventory/Sorting.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/TUI/Inventory/Sorting.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.TUI.Inventory.Sorting ( + InventorySortOptions (..), + InventorySortDirection (..), + InventorySortOrder (..), + cycleSortOrder, + cycleSortDirection, + defaultSortOptions, + sortInventory, + renderSortMethod, +) where + +import Algorithms.NaturalSort (sortKey) +import Control.Lens (view) +import Data.List (sortBy) +import Data.Ord (Down (Down), comparing) +import Data.Text qualified as T +import Swarm.Game.Entity as E +import Swarm.Util (cycleEnum) + +data InventorySortDirection + = Ascending + | Descending + deriving (Enum, Bounded, Eq) + +data InventorySortOrder + = ByNaturalAlphabetic + | ByQuantity + | ByType + deriving (Enum, Bounded, Eq) + +data InventorySortOptions = InventorySortOptions InventorySortDirection InventorySortOrder + +defaultSortOptions :: InventorySortOptions +defaultSortOptions = InventorySortOptions Ascending ByNaturalAlphabetic + +renderSortMethod :: InventorySortOptions -> T.Text +renderSortMethod (InventorySortOptions direction order) = + T.unwords [prefix, label] + where + prefix = case direction of + Ascending -> "↑" + Descending -> "↓" + label = case order of + ByNaturalAlphabetic -> "name" + ByQuantity -> "count" + ByType -> "type" + +cycleSortOrder :: InventorySortOptions -> InventorySortOptions +cycleSortOrder (InventorySortOptions direction order) = + InventorySortOptions direction (cycleEnum order) + +cycleSortDirection :: InventorySortOptions -> InventorySortOptions +cycleSortDirection (InventorySortOptions direction order) = + InventorySortOptions (cycleEnum direction) order + +-- | All non-alphabetic sort criteria perform alphabetic tie-breaking. +-- "Reverse ordering" only applies to the *primary* sort criteria; the secondary +-- alphabetic sort is always in ascending order. +getSortCompartor :: Ord a => InventorySortOptions -> (a, Entity) -> (a, Entity) -> Ordering +getSortCompartor (InventorySortOptions direction order) = case order of + ByNaturalAlphabetic -> compReversible (alphabetic . snd) + ByQuantity -> compReversible fst <> secondary + ByType -> compReversible (view entityProperties . snd) <> secondary + where + alphabetic = sortKey . T.toLower . view entityName + secondary = comparing (alphabetic . snd) + + compReversible :: Ord a => (b -> a) -> b -> b -> Ordering + compReversible = case direction of + Ascending -> comparing + Descending -> \f -> comparing (Down . f) + +sortInventory :: Ord a => InventorySortOptions -> [(a, Entity)] -> [(a, Entity)] +sortInventory opts = + sortBy $ getSortCompartor opts diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs --- a/src/Swarm/TUI/Model.hs +++ b/src/Swarm/TUI/Model.hs @@ -53,13 +53,7 @@ -- ** Prompt utils REPLPrompt (..), - mkCmdPrompt, - replPromptAsWidget, - promptTextL, - promptUpdateL, - mkReplForm, removeEntry, - resetWithREPLForm, -- ** Inventory InventoryListEntry (..), @@ -74,11 +68,9 @@ uiCheatMode, uiFocusRing, uiWorldCursor, - uiReplForm, - uiReplType, - uiReplHistory, - uiReplLast, + uiREPL, uiInventory, + uiInventorySort, uiMoreInfoTop, uiMoreInfoBot, uiScrollToEnd, @@ -94,15 +86,29 @@ lastInfoTime, uiShowFPS, uiShowZero, + uiShowRobots, + uiHideRobotsUntil, uiInventoryShouldUpdate, uiTPF, uiFPS, + scenarioRef, appData, + -- *** REPL Panel Model + REPLState, + replPromptType, + replPromptEditor, + replPromptText, + replValid, + replLast, + replType, + replHistory, + newREPLEditor, + -- ** Initialization initFocusRing, defaultPrompt, - initReplForm, + initREPLState, initLgTicksPerSecond, initUIState, lastEntry, @@ -129,10 +135,12 @@ AppOpts (..), initAppState, startGame, + restartGame, scenarioToAppState, Seed, -- ** Utility + topContext, focusedItem, focusedEntity, nextScenario, @@ -141,16 +149,16 @@ import Brick import Brick.Focus -import Brick.Forms import Brick.Widgets.Dialog (Dialog) +import Brick.Widgets.Edit (Editor, applyEdit, editorText, getEditContents) import Brick.Widgets.List qualified as BL -import Control.Applicative (Applicative (liftA2)) +import Control.Applicative (Applicative (liftA2), (<|>)) import Control.Lens hiding (from, (<.>)) import Control.Monad.Except import Control.Monad.State import Data.Bits (FiniteBits (finiteBitSize)) import Data.Foldable (toList) -import Data.List (findIndex, sortOn) +import Data.List (findIndex) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map (Map) @@ -160,16 +168,19 @@ import Data.Sequence qualified as Seq import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Zipper qualified as TZ import Data.Time (getZonedTime) import Data.Vector qualified as V +import GitHash (GitInfo) import Linear (zero) import Network.Wai.Handler.Warp (Port) import Swarm.Game.Entity as E import Swarm.Game.Robot -import Swarm.Game.Scenario (Scenario, loadScenario) +import Swarm.Game.Scenario (loadScenario) import Swarm.Game.ScenarioInfo ( ScenarioCollection, ScenarioInfo (..), + ScenarioInfoPair, ScenarioItem (..), ScenarioStatus (..), normalizeScenarioPath, @@ -177,12 +188,14 @@ scenarioCollectionToList, scenarioItemByPath, scenarioPath, + scenarioSolution, scenarioStatus, _SISingle, ) import Swarm.Game.State import Swarm.Game.World qualified as W import Swarm.Language.Types +import Swarm.TUI.Inventory.Sorting import Swarm.Util import Swarm.Version (NewReleaseFailure (NoMainUpstreamRelease)) import System.Clock @@ -356,19 +369,12 @@ replIndexIsAtInput :: REPLHistory -> Bool replIndexIsAtInput repl = repl ^. replIndex == replLength repl ------------------------------------------------------------- --- Repl Prompt ------------------------------------------------------------- - --- | This data type represent what is prompted to the player --- and how the REPL show interpret the user input. -data REPLPrompt - = -- | Interpret the given text as a regular command. - -- The list is for potential completions, which we can - -- cycle through by hitting Tab repeatedly - CmdPrompt Text [Text] - | -- | Interpret the given text as "search this text in history" - SearchPrompt Text REPLHistory +-- | Given some text, removes the REPLEntry within REPLHistory which is equal to that. +-- This is used when the user enters in search mode and want to traverse the history. +-- If a command has been used many times, the history will be populated with it causing +-- the effect that search command always finds the same command. +removeEntry :: Text -> REPLHistory -> REPLHistory +removeEntry foundtext hist = hist & replSeq %~ Seq.filter (/= REPLEntry foundtext) -- | Get the last REPLEntry in REPLHistory matching the given text lastEntry :: Text -> REPLHistory -> Maybe Text @@ -380,49 +386,73 @@ matchesText histItem = t `T.isInfixOf` replItemText histItem matchEntry = liftA2 (&&) matchesText isREPLEntry --- | Given some text, removes the REPLEntry within REPLHistory which is equal to that. --- This is used when the user enters in search mode and want to traverse the history. --- If a command has been used many times, the history will be populated with it causing --- the effect that search command always finds the same command. -removeEntry :: Text -> REPLHistory -> REPLHistory -removeEntry foundtext hist = hist & replSeq %~ Seq.filter (/= REPLEntry foundtext) +------------------------------------------------------------ +-- REPL +------------------------------------------------------------ -mkCmdPrompt :: Text -> REPLPrompt -mkCmdPrompt t = CmdPrompt t [] +-- | This data type tells us how to interpret the text typed +-- by the player at the prompt (which is stored in Editor). +data REPLPrompt + = -- | Interpret the prompt text as a regular command. + -- The list is for potential completions, which we can + -- cycle through by hitting Tab repeatedly + CmdPrompt [Text] + | -- | Interpret the prompt text as "search this text in history" + SearchPrompt REPLHistory defaultPrompt :: REPLPrompt -defaultPrompt = mkCmdPrompt "" +defaultPrompt = CmdPrompt [] --- | Lens for accesing the text of the prompt. --- Notice that setting the text clears any pending completions. -promptTextL :: Lens' REPLPrompt Text -promptTextL = lens g s +data REPLState = REPLState + { _replPromptType :: REPLPrompt + , _replPromptEditor :: Editor Text Name + , _replValid :: Bool + , _replLast :: Text + , _replType :: Maybe Polytype + , _replHistory :: REPLHistory + } + +newREPLEditor :: Text -> Editor Text Name +newREPLEditor t = applyEdit gotoEnd $ editorText REPLInput (Just 1) t where - -- Notice that the prompt ADT must have a Text field in every constructor (representing what the user writes). - -- This should be force in the ADT itself... right know this here - -- The compiler will complain about "Non complete patterns" on this two function. - g :: REPLPrompt -> Text - g (CmdPrompt t _) = t - g (SearchPrompt t _) = t + ls = T.lines t + pos = (length ls - 1, T.length (last ls)) + gotoEnd = if null ls then id else TZ.moveCursor pos - s :: REPLPrompt -> Text -> REPLPrompt - s (CmdPrompt _ _) t = mkCmdPrompt t - s (SearchPrompt _ h) t = SearchPrompt t h +initREPLState :: REPLHistory -> REPLState +initREPLState = REPLState defaultPrompt (newREPLEditor "") True "" Nothing --- | Turn the repl prompt into a decorator for the form -replPromptAsWidget :: REPLPrompt -> Widget Name -replPromptAsWidget (CmdPrompt {}) = txt "> " -replPromptAsWidget (SearchPrompt t rh) = - case lastEntry t rh of - Nothing -> txt "[nothing found] " - Just lastentry - | T.null t -> txt "[find] " - | otherwise -> txt $ "[found: \"" <> lastentry <> "\"] " +makeLensesWith (lensRules & generateSignatures .~ False) ''REPLState --- | Creates the repl form as a decorated form. -mkReplForm :: REPLPrompt -> Form REPLPrompt AppEvent Name -mkReplForm r = newForm [(replPromptAsWidget r <+>) @@= editTextField promptTextL REPLInput (Just 1)] r +-- | The way we interpret text typed by the player in the REPL prompt. +replPromptType :: Lens' REPLState REPLPrompt +-- | The prompt where the user can type input at the REPL. +replPromptEditor :: Lens' REPLState (Editor Text Name) + +-- | Convinience lens to get text from editor and replace it with new +-- one that has the provided text. +replPromptText :: Lens' REPLState Text +replPromptText = lens g s + where + g r = r ^. replPromptEditor . to getEditContents . to T.concat + s r t = r & replPromptEditor .~ newREPLEditor t + +-- | Whether the prompt text is a valid 'Term'. +replValid :: Lens' REPLState Bool + +-- | The type of the current REPL input which should be displayed to +-- the user (if any). +replType :: Lens' REPLState (Maybe Polytype) + +-- | The last thing the user has typed which isn't part of the history. +-- This is used to restore the repl form after the user visited the history. +replLast :: Lens' REPLState Text + +-- | History of things the user has typed at the REPL, interleaved +-- with outputs the system has generated. +replHistory :: Lens' REPLState REPLHistory + ------------------------------------------------------------ -- Menus and dialogs ------------------------------------------------------------ @@ -435,11 +465,12 @@ | RobotsModal | WinModal | QuitModal + | KeepPlayingModal | DescriptionModal Entity | GoalModal [Text] deriving (Eq, Show) -data ButtonSelection = CancelButton | QuitButton | NextButton (Scenario, ScenarioInfo) +data ButtonSelection = CancelButton | KeepPlayingButton | StartOverButton Seed ScenarioInfoPair | QuitButton | NextButton ScenarioInfoPair data Modal = Modal { _modalType :: ModalType @@ -481,7 +512,7 @@ go (Just curSC) (thing : rest) stk = go nextSC rest (lst : stk) where hasName :: ScenarioItem -> Bool - hasName (SISingle _ (ScenarioInfo pth _ _ _)) = takeFileName pth == thing + hasName (SISingle (_, ScenarioInfo pth _ _ _)) = takeFileName pth == thing hasName (SICollection nm _) = nm == into @Text (dropTrailingPathSeparator thing) lst = BL.listFindBy hasName (mkScenarioList cheat curSC) @@ -519,11 +550,9 @@ , _uiCheatMode :: Bool , _uiFocusRing :: FocusRing Name , _uiWorldCursor :: Maybe W.Coords - , _uiReplForm :: Form REPLPrompt AppEvent Name - , _uiReplType :: Maybe Polytype - , _uiReplLast :: Text - , _uiReplHistory :: REPLHistory + , _uiREPL :: REPLState , _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry) + , _uiInventorySort :: InventorySortOptions , _uiMoreInfoTop :: Bool , _uiMoreInfoBot :: Bool , _uiScrollToEnd :: Bool @@ -532,6 +561,7 @@ , _uiGoal :: Maybe [Text] , _uiShowFPS :: Bool , _uiShowZero :: Bool + , _uiHideRobotsUntil :: TimeSpec , _uiInventoryShouldUpdate :: Bool , _uiTPF :: Double , _uiFPS :: Double @@ -543,6 +573,7 @@ , _accumulatedTime :: TimeSpec , _lastInfoTime :: TimeSpec , _appData :: Map Text Text + , _scenarioRef :: Maybe ScenarioInfoPair } -------------------------------------------------- @@ -575,20 +606,11 @@ -- | The last clicked position on the world view. uiWorldCursor :: Lens' UIState (Maybe W.Coords) --- | The form where the user can type input at the REPL. -uiReplForm :: Lens' UIState (Form REPLPrompt AppEvent Name) - --- | The type of the current REPL input which should be displayed to --- the user (if any). -uiReplType :: Lens' UIState (Maybe Polytype) - --- | The last thing the user has typed which isn't part of the history. --- This is used to restore the repl form after the user visited the history. -uiReplLast :: Lens' UIState Text +-- | The state of REPL panel. +uiREPL :: Lens' UIState REPLState --- | History of things the user has typed at the REPL, interleaved --- with outputs the system has generated. -uiReplHistory :: Lens' UIState REPLHistory +-- | The order and direction of sorting inventory list. +uiInventorySort :: Lens' UIState InventorySortOptions -- | The hash value of the focused robot entity (so we can tell if its -- inventory changed) along with a list of the items in the @@ -623,6 +645,13 @@ -- | A toggle to show or hide inventory items with count 0 by pressing `0` uiShowZero :: Lens' UIState Bool +-- | Hide robots on the world map. +uiHideRobotsUntil :: Lens' UIState TimeSpec + +-- | Whether to show or hide robots on the world map. +uiShowRobots :: Getter UIState Bool +uiShowRobots = to (\ui -> ui ^. lastFrameTime > ui ^. uiHideRobotsUntil) + -- | Whether the Inventory ui panel should update uiInventoryShouldUpdate :: Lens' UIState Bool @@ -632,6 +661,9 @@ -- | Computed frames per milli seconds uiFPS :: Lens' UIState Double +-- | The currently active Scenario description, useful for starting over. +scenarioRef :: Lens' UIState (Maybe ScenarioInfoPair) + -- | The base-2 logarithm of the current game speed in ticks/second. -- Note that we cap this value to the range of +/- log2 INTMAX. lgTicksPerSecond :: Lens' UIState Int @@ -676,24 +708,6 @@ -- the logo, about page, tutorial story, etc. appData :: Lens' UIState (Map Text Text) --- | Lens for accesing the text of the prompt. --- Notice that setting the text clears any pending completions. -promptUpdateL :: Lens UIState (Form REPLPrompt AppEvent Name) Text Text -promptUpdateL = lens g s - where - -- Notice that the prompt ADT must have a Text field in every constructor (representing what the user writes). - -- This should be force in the ADT itself... right know this here - -- The compiler will complain about "Non complete patterns" on this two function. - g :: UIState -> Text - g ui = case formState (ui ^. uiReplForm) of - CmdPrompt t _ -> t - SearchPrompt t _ -> t - - s :: UIState -> Text -> Form REPLPrompt AppEvent Name - s ui inputText = case formState (ui ^. uiReplForm) of - CmdPrompt _ _ -> mkReplForm $ mkCmdPrompt inputText - SearchPrompt _ _ -> mkReplForm $ SearchPrompt inputText (ui ^. uiReplHistory) - -- ---------------------------------------------------------------------------- -- Runtime state -- -- ---------------------------------------------------------------------------- @@ -793,13 +807,6 @@ initFocusRing :: FocusRing Name initFocusRing = focusRing [REPLPanel, InfoPanel, RobotPanel, WorldPanel] --- | The initial state of the REPL entry form. -initReplForm :: Form REPLPrompt AppEvent Name -initReplForm = - newForm - [(replPromptAsWidget defaultPrompt <+>) @@= editTextField promptTextL REPLInput (Just 1)] - (mkCmdPrompt "") - -- | The initial tick speed. initLgTicksPerSecond :: Int initLgTicksPerSecond = 4 -- 2^4 = 16 ticks / second @@ -822,11 +829,9 @@ , _uiCheatMode = cheatMode , _uiFocusRing = initFocusRing , _uiWorldCursor = Nothing - , _uiReplForm = initReplForm - , _uiReplType = Nothing - , _uiReplHistory = newREPLHistory history - , _uiReplLast = "" + , _uiREPL = initREPLState $ newREPLHistory history , _uiInventory = Nothing + , _uiInventorySort = defaultSortOptions , _uiMoreInfoTop = False , _uiMoreInfoBot = False , _uiScrollToEnd = False @@ -835,6 +840,7 @@ , _uiGoal = Nothing , _uiShowFPS = False , _uiShowZero = True + , _uiHideRobotsUntil = startTime - 1 , _uiInventoryShouldUpdate = False , _uiTPF = 0 , _uiFPS = 0 @@ -846,6 +852,7 @@ , _frameCount = 0 , _frameTickCount = 0 , _appData = appDataMap + , _scenarioRef = Nothing } ------------------------------------------------------------ @@ -859,12 +866,13 @@ populateInventoryList (Just r) = do mList <- preuse (uiInventory . _Just . _2) showZero <- use uiShowZero + sortOptions <- use uiInventorySort let mkInvEntry (n, e) = InventoryEntry n e mkInstEntry (_, e) = InstalledEntry e itemList mk label = (\case [] -> []; xs -> Separator label : xs) . map mk - . sortOn (view entityName . snd) + . sortInventory sortOptions . filter shouldDisplay . elems @@ -899,13 +907,6 @@ -- the hash of the current robot. uiInventory .= Just (r ^. inventoryHash, lst) --- | Set the REPLForm to the given value, resetting type error checks to Nothing --- and removing uiError. -resetWithREPLForm :: Form REPLPrompt AppEvent Name -> UIState -> UIState -resetWithREPLForm f = - (uiReplForm .~ f) - . (uiError .~ Nothing) - ------------------------------------------------------------ -- App state (= UI state + game state) initialization ------------------------------------------------------------ @@ -917,17 +918,22 @@ , -- | Scenario the user wants to play. userScenario :: Maybe FilePath , -- | Code to be run on base. - toRun :: Maybe FilePath + scriptToRun :: Maybe FilePath + , -- | Automatically run the solution defined in the scenario file + autoPlay :: Bool , -- | Should cheat mode be enabled? cheatMode :: Bool , -- | Explicit port on which to run the web API userWebPort :: Maybe Port + , -- | Information about the Git repository (not present in release). + repoGitInfo :: Maybe GitInfo } -- | Initialize the 'AppState'. initAppState :: AppOpts -> ExceptT Text IO AppState initAppState AppOpts {..} = do - let skipMenu = isJust userScenario || isJust toRun || isJust userSeed + let isRunningInitialProgram = isJust scriptToRun || autoPlay + skipMenu = isJust userScenario || isRunningInitialProgram || isJust userSeed gs <- initGameState ui <- initUIState (not skipMenu) cheatMode let rs = initRuntimeState @@ -935,30 +941,49 @@ False -> return $ AppState gs ui rs True -> do (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap) + + let maybeAutoplay = do + guard autoPlay + soln <- scenario ^. scenarioSolution + return $ SuggestedSolution soln + let realToRun = maybeAutoplay <|> (ScriptPath <$> scriptToRun) + execStateT - (startGameWithSeed userSeed scenario (ScenarioInfo path NotStarted NotStarted NotStarted) toRun) + (startGameWithSeed userSeed (scenario, ScenarioInfo path NotStarted NotStarted NotStarted) realToRun) (AppState gs ui rs) -- | Load a 'Scenario' and start playing the game. -startGame :: (MonadIO m, MonadState AppState m) => Scenario -> ScenarioInfo -> Maybe FilePath -> m () +startGame :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe CodeToRun -> m () startGame = startGameWithSeed Nothing +-- | Re-initialize the game from the stored reference to the current scenario. +-- +-- Note that "restarting" is intended only for "scenarios"; +-- with some scenarios, it may be possible to get stuck so that it is +-- either impossible or very annoying to win, so being offered an +-- option to restart is more user-friendly. +-- +-- Since scenarios are stored as a Maybe in the UI state, we handle the Nothing +-- case upstream so that the Scenario passed to this function definitely exists. +restartGame :: (MonadIO m, MonadState AppState m) => Seed -> ScenarioInfoPair -> m () +restartGame currentSeed siPair = startGameWithSeed (Just currentSeed) siPair Nothing + -- | Load a 'Scenario' and start playing the game, with the -- possibility for the user to override the seed. -startGameWithSeed :: (MonadIO m, MonadState AppState m) => Maybe Seed -> Scenario -> ScenarioInfo -> Maybe FilePath -> m () -startGameWithSeed userSeed scene si toRun = do +startGameWithSeed :: (MonadIO m, MonadState AppState m) => Maybe Seed -> ScenarioInfoPair -> Maybe CodeToRun -> m () +startGameWithSeed userSeed siPair@(_scene, si) toRun = do t <- liftIO getZonedTime ss <- use $ gameState . scenarios p <- liftIO $ normalizeScenarioPath ss (si ^. scenarioPath) gameState . currentScenarioPath .= Just p gameState . scenarios . scenarioItemByPath p . _SISingle . _2 . scenarioStatus .= InProgress t 0 0 - scenarioToAppState scene userSeed toRun + scenarioToAppState siPair userSeed toRun -- | Extract the scenario which would come next in the menu from the -- currently selected scenario (if any). Can return @Nothing@ if -- either we are not in the @NewGameMenu@, or the current scenario -- is the last among its siblings. -nextScenario :: Menu -> Maybe (Scenario, ScenarioInfo) +nextScenario :: Menu -> Maybe ScenarioInfoPair nextScenario = \case NewGameMenu (curMenu :| _) -> let nextMenuList = BL.listMoveDown curMenu @@ -968,13 +993,26 @@ else BL.listSelectedElement nextMenuList >>= preview _SISingle . snd _ -> Nothing +-- | Context for the REPL commands to execute in. Contains the base +-- robot context plus the `it` variable that refer to the previously +-- computed values. (Note that `it{n}` variables are set in the +-- base robot context; we only set `it` here because it's so transient) +topContext :: AppState -> RobotContext +topContext s = ctxPossiblyWithIt + where + ctx = fromMaybe emptyRobotContext $ s ^? gameState . baseRobot . robotContext + + ctxPossiblyWithIt = case s ^. gameState . replStatus of + REPLDone (Just p) -> ctx & at "it" ?~ p + _ -> ctx + -- XXX do we need to keep an old entity map around??? -- | Modify the 'AppState' appropriately when starting a new scenario. -scenarioToAppState :: (MonadIO m, MonadState AppState m) => Scenario -> Maybe Seed -> Maybe String -> m () -scenarioToAppState scene userSeed toRun = do +scenarioToAppState :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe Seed -> Maybe CodeToRun -> m () +scenarioToAppState siPair@(scene, _) userSeed toRun = do withLensIO gameState $ scenarioToGameState scene userSeed toRun - withLensIO uiState $ scenarioToUIState scene + withLensIO uiState $ scenarioToUIState siPair where withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m () withLensIO l a = do @@ -983,16 +1021,18 @@ l .= x' -- | Modify the UI state appropriately when starting a new scenario. -scenarioToUIState :: Scenario -> UIState -> IO UIState -scenarioToUIState _scene u = +scenarioToUIState :: ScenarioInfoPair -> UIState -> IO UIState +scenarioToUIState siPair u = return $ u & uiPlaying .~ True & uiGoal .~ Nothing & uiFocusRing .~ initFocusRing & uiInventory .~ Nothing + & uiInventorySort .~ defaultSortOptions & uiShowFPS .~ False & uiShowZero .~ True & lgTicksPerSecond .~ initLgTicksPerSecond - & resetWithREPLForm (mkReplForm $ mkCmdPrompt "") - & uiReplHistory %~ restartREPLHistory + & uiREPL .~ initREPLState (u ^. uiREPL . replHistory) + & uiREPL . replHistory %~ restartREPLHistory + & scenarioRef ?~ siPair diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -44,6 +44,7 @@ import Brick.Widgets.Border (hBorder, hBorderWithLabel, joinableBorder, vBorder) import Brick.Widgets.Center (center, centerLayer, hCenter) import Brick.Widgets.Dialog +import Brick.Widgets.Edit (getEditContents, renderEditor) import Brick.Widgets.List qualified as BL import Brick.Widgets.Table qualified as BT import Control.Lens hiding (Const, from) @@ -63,7 +64,7 @@ import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) import Data.Semigroup (sconcat) import Data.Sequence qualified as Seq -import Data.String (fromString) +import Data.Set qualified as Set (toList) import Data.Text (Text) import Data.Text qualified as T import Data.Time (NominalDiffTime, defaultTimeLocale, formatTime) @@ -93,6 +94,7 @@ import Swarm.Language.Types (Polytype) import Swarm.TUI.Attr import Swarm.TUI.Border +import Swarm.TUI.Inventory.Sorting (renderSortMethod) import Swarm.TUI.Model import Swarm.TUI.Panel import Swarm.Util @@ -174,7 +176,7 @@ , padLeft (Pad 5) (maybe (txt "") (drawDescription . snd) (BL.listSelectedElement l)) ] where - drawScenarioItem (SISingle s si) = padRight (Pad 1) (drawStatusInfo s si) <+> txt (s ^. scenarioName) + drawScenarioItem (SISingle (s, si)) = padRight (Pad 1) (drawStatusInfo s si) <+> txt (s ^. scenarioName) drawScenarioItem (SICollection nm _) = padRight (Pad 1) (withAttr boldAttr $ txt " > ") <+> txt nm drawStatusInfo s si = case si ^. scenarioBestTime of NotStarted -> txt " ○ " @@ -212,7 +214,7 @@ drawDescription :: ScenarioItem -> Widget Name drawDescription (SICollection _ _) = txtWrap " " - drawDescription (SISingle s si) = do + drawDescription (SISingle (s, si)) = do let oneBest = si ^. scenarioBestTime == si ^. scenarioBestTicks let bestRealTime = if oneBest then "best:" else "best real time:" let noSame = if oneBest then const Nothing else Just @@ -264,7 +266,7 @@ -- main layer and a layer for a floating dialog that can be on top. drawGameUI :: AppState -> [Widget Name] drawGameUI s = - [ drawDialog s + [ joinBorders $ drawDialog s , joinBorders $ hBox [ hLimitPercent 25 $ @@ -293,7 +295,7 @@ & addCursorPos & addClock ) - (drawWorld $ s ^. gameState) + (drawWorld (s ^. uiState . uiShowRobots) (s ^. gameState)) , drawKeyMenu s , clickable REPLPanel $ panel @@ -301,7 +303,7 @@ fr REPLPanel ( plainBorder - & topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiReplType)) + & topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiREPL . replType)) ) ( vLimit replHeight . padBottom Max @@ -313,8 +315,10 @@ ] where addCursorPos = case s ^. uiState . uiWorldCursor of - Just coord -> bottomLabels . leftLabel ?~ padLeftRight 1 (drawWorldCursorInfo (s ^. gameState) coord) Nothing -> id + Just coord -> + let worlCursorInfo = drawWorldCursorInfo (s ^. uiState . uiShowRobots) (s ^. gameState) coord + in bottomLabels . leftLabel ?~ padLeftRight 1 worlCursorInfo -- Add clock display in top right of the world view if focused robot -- has a clock installed addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay $ s ^. gameState) @@ -322,9 +326,9 @@ moreTop = s ^. uiState . uiMoreInfoTop moreBot = s ^. uiState . uiMoreInfoBot -drawWorldCursorInfo :: GameState -> W.Coords -> Widget Name -drawWorldCursorInfo g i@(W.Coords (y, x)) = - hBox [drawLoc g i, txt $ " at " <> from (show x) <> " " <> from (show (y * (-1)))] +drawWorldCursorInfo :: Bool -> GameState -> W.Coords -> Widget Name +drawWorldCursorInfo showRobots g i@(W.Coords (y, x)) = + hBox [drawLoc showRobots g i, txt $ " at " <> from (show x) <> " " <> from (show (y * (-1)))] -- | Format the clock display to be shown in the upper right of the -- world panel. @@ -444,18 +448,21 @@ DescriptionModal e -> descriptionWidget s e QuitModal -> padBottom (Pad 1) $ hCenter $ txt (quitMsg (s ^. uiState . uiMenu)) GoalModal g -> padLeftRight 1 (displayParagraphs g) + KeepPlayingModal -> padLeftRight 1 (displayParagraphs ["Have fun! Hit Ctrl-Q whenever you're ready to proceed to the next challenge or return to the menu."]) quitMsg :: Menu -> Text -quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress will be lost!" +quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this scenario will be lost!" where quitAction = case m of NoMenu -> "quit" - _ -> "quit and return to the menu" + _ -> "return to the menu" -- | Generate a fresh modal window of the requested type. generateModal :: AppState -> ModalType -> Modal generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth `min` requiredWidth)) where + currentScenario = s ^. uiState . scenarioRef + currentSeed = s ^. gameState . seed haltingMessage = case s ^. uiState . uiMenu of NoMenu -> Just "Quit" _ -> Nothing @@ -479,20 +486,41 @@ | Just scene <- [nextScenario (s ^. uiState . uiMenu)] ] ++ [ (stopMsg, QuitButton) - , (continueMsg, CancelButton) + , (continueMsg, KeepPlayingButton) ] ) , sum (map length [nextMsg, stopMsg, continueMsg]) + 32 ) DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth) QuitModal -> - let stopMsg = fromMaybe "Quit to menu" haltingMessage + let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage + maybeStartOver = sequenceA ("Start over", StartOverButton currentSeed <$> currentScenario) in ( "" - , Just (0, [("Keep playing", CancelButton), (stopMsg, QuitButton)]) + , Just + ( 0 + , catMaybes + [ Just ("Keep playing", CancelButton) + , maybeStartOver + , Just (stopMsg, QuitButton) + ] + ) , T.length (quitMsg (s ^. uiState . uiMenu)) + 4 ) - GoalModal _ -> (" Goal ", Nothing, 80) + GoalModal _ -> + let goalModalTitle = case currentScenario of + Nothing -> "Goal" + Just (scenario, _) -> scenario ^. scenarioName + in (" " <> T.unpack goalModalTitle <> " ", Nothing, 80) + KeepPlayingModal -> ("", Just (0, [("OK", CancelButton)]), 80) +-- | Get the name of the current New Game menu. +curMenuName :: AppState -> Maybe Text +curMenuName s = case s ^. uiState . uiMenu of + NewGameMenu (_ :| (parentMenu : _)) -> + Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName) + NewGameMenu _ -> Just "Scenarios" + _ -> Nothing + robotsListWidget :: AppState -> Widget Name robotsListWidget s = hCenter table where @@ -544,7 +572,7 @@ locWidget = hBox [worldCell, txt $ " " <> locStr] where rloc@(V2 x y) = robot ^. robotLocation - worldCell = drawLoc g (W.locToCoords rloc) + worldCell = drawLoc (s ^. uiState . uiShowRobots) g (W.locToCoords rloc) locStr = from (show x) <> " " <> from (show y) statusWidget = case robot ^. machine of @@ -554,7 +582,7 @@ | otherwise -> withAttr greenAttr $ txt "idle" basePos :: V2 Double - basePos = realToFrac <$> fromMaybe (V2 0 0) (g ^? robotMap . ix 0 . robotLocation) + basePos = realToFrac <$> fromMaybe (V2 0 0) (g ^? baseRobot . robotLocation) -- Keep the base and non sytem robot (e.g. no seed) isRelevant robot = robot ^. robotID == 0 || not (robot ^. systemRobot) -- Keep the robot that are less than 32 unit away from the base @@ -613,7 +641,8 @@ , ("Ctrl-o", "single step") , ("Ctrl-z", "decrease speed") , ("Ctrl-w", "increase speed") - , ("Ctrl-q", "quit the game") + , ("Ctrl-q", "quit the current scenario") + , ("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") @@ -703,7 +732,7 @@ | null (s ^. gameState . notifLens . notificationsContent) = Nothing | otherwise = let highlight - | s ^. gameState . notifLens . notificationsCount > 0 = Highlighted + | s ^. gameState . notifLens . notificationsCount > 0 = Alert | otherwise = NoHighlight in Just (highlight, key, name) @@ -728,7 +757,7 @@ . (++ [gameModeWidget]) . map (padLeftRight 1 . drawKeyCmd) . (globalKeyCmds ++) - . map (\(k, n) -> (NoHighlight, k, n)) + . map highlightKeyCmds . keyCmdsFor . focusGetCurrent . view (uiState . uiFocusRing) @@ -743,6 +772,7 @@ Just g | g /= [] -> True _ -> False showZero = s ^. uiState . uiShowZero + inventorySort = s ^. uiState . uiInventorySort gameModeWidget = padLeft Max . padLeftRight 1 @@ -758,40 +788,55 @@ , Just (NoHighlight, "^p", if isPaused then "unpause" else "pause") , Just (NoHighlight, "^o", "step") , Just (NoHighlight, "^zx", "speed") + , Just (if s ^. uiState . uiShowRobots then NoHighlight else Alert, "M-h", "hide robots") ] may b = if b then Just else const Nothing + highlightKeyCmds (k, n) = (,k,n) $ case n of + "pop out" | (s ^. uiState . uiMoreInfoBot) || (s ^. uiState . uiMoreInfoTop) -> Alert + _ -> PanelSpecific + keyCmdsFor (Just REPLPanel) = [ ("↓↑", "history") ] - ++ [("Ret", "execute") | not isReplWorking] + ++ [("Enter", "execute") | not isReplWorking] ++ [("^c", "cancel") | isReplWorking] keyCmdsFor (Just WorldPanel) = [ ("←↓↑→ / hjkl", "scroll") | creative ] ++ [("c", "recenter") | not viewingBase] + ++ [("f", "FPS")] keyCmdsFor (Just RobotPanel) = - [ ("Ret", "focus") + [ ("Enter", "pop out") , ("m", "make") , ("0", (if showZero then "hide" else "show") <> " 0") + , (":/;", T.unwords ["Sort:", renderSortMethod inventorySort]) ] keyCmdsFor (Just InfoPanel) = [] keyCmdsFor _ = [] -data KeyHighlight = NoHighlight | Highlighted +data KeyHighlight = NoHighlight | Alert | PanelSpecific -- | Draw a single key command in the menu. drawKeyCmd :: (KeyHighlight, Text, Text) -> Widget Name -drawKeyCmd (Highlighted, key, cmd) = hBox [withAttr notifAttr (txt $ T.concat ["[", key, "] "]), txt cmd] -drawKeyCmd (NoHighlight, key, cmd) = txt $ T.concat ["[", key, "] ", cmd] +drawKeyCmd (h, key, cmd) = + hBox + [ withAttr attr (txt $ T.concat ["[", key, "] "]) + , txt cmd + ] + where + attr = case h of + NoHighlight -> defAttr + Alert -> notifAttr + PanelSpecific -> highlightAttr ------------------------------------------------------------ -- World panel ------------------------------------------------------------ -- | Draw the current world view. -drawWorld :: GameState -> Widget Name -drawWorld g = +drawWorld :: Bool -> GameState -> Widget Name +drawWorld showRobots g = center . cached WorldCache . reportExtent WorldExtent @@ -803,21 +848,25 @@ let w = ctx ^. availWidthL h = ctx ^. availHeightL ixs = range (viewingRegion g (fromIntegral w, fromIntegral h)) - render . vBox . map hBox . chunksOf w . map (drawLoc g) $ ixs + render . vBox . map hBox . chunksOf w . map (drawLoc showRobots g) $ ixs -- | Render the 'Display' for a specific location. -drawLoc :: GameState -> W.Coords -> Widget Name -drawLoc g = renderDisplay . displayLoc g +drawLoc :: Bool -> GameState -> W.Coords -> Widget Name +drawLoc showRobots g = renderDisplay . displayLoc showRobots g -- | Get the 'Display' for a specific location, by combining the -- 'Display's for the terrain, entity, and robots at the location. -displayLoc :: GameState -> W.Coords -> Display -displayLoc g coords = - sconcat . NE.fromList $ - [terrainMap M.! toEnum (W.lookupTerrain coords (g ^. world))] - ++ maybeToList (displayForEntity <$> W.lookupEntity coords (g ^. world)) - ++ map (view robotDisplay) (robotsAtLocation (W.coordsToLoc coords) g) +displayLoc :: Bool -> GameState -> W.Coords -> Display +displayLoc showRobots g coords = + sconcat $ terrain NE.:| entity <> robots where + terrain = terrainMap M.! toEnum (W.lookupTerrain coords (g ^. world)) + entity = maybeToList (displayForEntity <$> W.lookupEntity coords (g ^. world)) + robots = + if showRobots + then map (view robotDisplay) (robotsAtLocation (W.coordsToLoc coords) g) + else [] + displayForEntity :: Entity -> Display displayForEntity e = (if known e then id else hidden) (e ^. entityDisplay) @@ -919,7 +968,7 @@ explainEntry :: AppState -> Entity -> Widget Name explainEntry s e = vBox - [ displayProperties (e ^. entityProperties) + [ displayProperties $ Set.toList (e ^. entityProperties) , displayParagraphs (e ^. entityDescription) , explainRecipes s e ] @@ -1108,21 +1157,43 @@ -- REPL panel ------------------------------------------------------------ +-- | Turn the repl prompt into a decorator for the form +replPromptAsWidget :: Text -> REPLPrompt -> Widget Name +replPromptAsWidget _ (CmdPrompt _) = txt "> " +replPromptAsWidget t (SearchPrompt rh) = + case lastEntry t rh of + Nothing -> txt "[nothing found] " + Just lastentry + | T.null t -> txt "[find] " + | otherwise -> txt $ "[found: \"" <> lastentry <> "\"] " + +renderREPLPrompt :: FocusRing Name -> REPLState -> Widget Name +renderREPLPrompt focus repl = ps1 <+> replE + where + prompt = repl ^. replPromptType + replEditor = repl ^. replPromptEditor + color = if repl ^. replValid then id else withAttr redAttr + ps1 = replPromptAsWidget (T.concat $ getEditContents replEditor) prompt + replE = + renderEditor + (color . vBox . map txt) + (focusGetCurrent focus `elem` [Nothing, Just REPLPanel, Just REPLInput]) + replEditor + -- | Draw the REPL. drawREPL :: AppState -> Widget Name -drawREPL s = - vBox $ - map fmt (getLatestREPLHistoryItems (replHeight - inputLines) history) - ++ case isActive <$> base of - Just False -> [renderForm (s ^. uiState . uiReplForm)] - _ -> [padRight Max $ txt "..."] - ++ [padRight Max $ txt histIdx | debugging] +drawREPL s = vBox $ latestHistory <> [currentPrompt] where - debugging = False -- Turn ON to get extra line with history index - inputLines = 1 + fromEnum debugging - history = s ^. uiState . uiReplHistory + -- rendered history lines fitting above REPL prompt + latestHistory :: [Widget n] + latestHistory = map fmt (getLatestREPLHistoryItems (replHeight - inputLines) (repl ^. replHistory)) + currentPrompt :: Widget Name + currentPrompt = case isActive <$> base of + Just False -> renderREPLPrompt (s ^. uiState . uiFocusRing) repl + _running -> padRight Max $ txt "..." + inputLines = 1 + repl = s ^. uiState . uiREPL base = s ^. gameState . robotMap . at 0 - histIdx = fromString $ show (history ^. replIndex) fmt (REPLEntry e) = txt $ "> " <> e fmt (REPLOutput t) = txt t diff --git a/src/Swarm/Version.hs b/src/Swarm/Version.hs --- a/src/Swarm/Version.hs +++ b/src/Swarm/Version.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Swarm.Version @@ -10,12 +9,6 @@ -- -- Query current and upstream Swarm version. module Swarm.Version ( - -- * Git info - gitInfo, - commitInfo, - CommitHash, - tagVersion, - -- * PVP version isSwarmReleaseTag, version, @@ -29,17 +22,15 @@ import Control.Exception (catch, displayException) import Data.Aeson (Array, Value (..), (.:)) -import Data.Bifunctor (first) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL import Data.Char (isDigit) import Data.Either (lefts, rights) import Data.Foldable (toList) -import Data.List.Extra (breakOnEnd) import Data.Maybe (listToMaybe) import Data.Version (Version (..), parseVersion, showVersion) import Data.Yaml (ParseException, Parser, decodeEither', parseEither) -import GitHash (GitInfo, giBranch, giHash, giTag, tGitInfoCwdTry) +import GitHash (GitInfo, giBranch) import Network.HTTP.Client ( HttpException, Request (requestHeaders), @@ -58,32 +49,12 @@ -- >>> import Data.Version (Version (..), parseVersion) -- >>> import Text.ParserCombinators.ReadP (readP_to_S) -gitInfo :: Either String GitInfo -gitInfo = $$tGitInfoCwdTry - -commitInfo :: String -commitInfo = case gitInfo of - Left _ -> "" - Right git -> " (" <> giBranch git <> "@" <> take 10 (giHash git) <> ")" - -type CommitHash = String - -- | Check that the tag follows the PVP versioning policy. -- -- Note that this filters out VS Code plugin releases. isSwarmReleaseTag :: String -> Bool isSwarmReleaseTag = all (\c -> isDigit c || c == '.') -tagVersion :: Maybe (CommitHash, String) -tagVersion = case gitInfo of - Left _ -> Nothing - Right gi -> - let t = giTag gi - ((ta, _num), ghash) = first (first init . breakOnEnd "-" . init) $ breakOnEnd "-" t - in if isSwarmReleaseTag ta - then Just (ghash, ta) - else Nothing - version :: String version = let v = showVersion Paths_swarm.version @@ -177,12 +148,12 @@ -- -- This function can fail if the current branch is not main, -- if there is no Internet connection or no newer release. -getNewerReleaseVersion :: IO (Either NewReleaseFailure String) -getNewerReleaseVersion = - case gitInfo of +getNewerReleaseVersion :: Maybe GitInfo -> IO (Either NewReleaseFailure String) +getNewerReleaseVersion mgi = + case mgi of -- when using cabal install, the git info is unavailable, which is of no interest to players - Left _e -> (>>= getUpVer) <$> upstreamReleaseVersion - Right gi -> + Nothing -> (>>= getUpVer) <$> upstreamReleaseVersion + Just gi -> if giBranch gi /= "main" then return . Left . OnDevelopmentBranch $ giBranch gi else (>>= getUpVer) <$> upstreamReleaseVersion diff --git a/swarm.cabal b/swarm.cabal --- a/swarm.cabal +++ b/swarm.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: swarm -version: 0.1.1.0 +version: 0.2.0.0 synopsis: 2D resource gathering game with programmable robots description: Swarm is a 2D programming and resource gathering @@ -18,7 +18,7 @@ bug-reports: https://github.com/swarm-game/swarm/issues copyright: Brent Yorgey 2021 category: Game -tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.4 +tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 extra-source-files: CHANGELOG.md example/*.sw editors/emacs/*.el @@ -90,6 +90,7 @@ Swarm.Language.Parse.QQ Swarm.Language.Pretty Swarm.Language.Typecheck + Swarm.Language.Typed Swarm.Language.Elaborate Swarm.Language.LSP Swarm.Language.Pipeline @@ -115,6 +116,7 @@ Swarm.TUI.Model Swarm.TUI.View Swarm.TUI.Controller + Swarm.TUI.Inventory.Sorting Swarm.App Swarm.Version Swarm.Web @@ -124,10 +126,10 @@ other-modules: Paths_swarm autogen-modules: Paths_swarm - build-depends: base >= 4.14 && < 4.17, - aeson >= 2 && < 2.1, + build-depends: base >= 4.14 && < 4.18, + aeson >= 2 && < 2.2, array >= 0.5.4 && < 0.6, - brick >= 1.0 && < 1.1, + brick >= 1.0 && < 1.4, bytestring >= 0.10 && < 0.12, clock >= 0.8.2 && < 0.9, containers >= 0.6.2 && < 0.7, @@ -144,13 +146,14 @@ http-client >= 0.7 && < 0.8, http-client-tls >= 0.3 && < 0.4, http-types >= 0.12 && < 0.13, - lens >= 4.19 && < 5.2, + lens >= 4.19 && < 5.3, linear >= 1.21.6 && < 1.22, - lsp >= 1.2 && < 1.5, + lsp >= 1.2 && < 1.7, megaparsec >= 9.0 && < 9.3, minimorph >= 0.3 && < 0.4, mtl >= 2.2.2 && < 2.3, murmur3 >= 1.0.4 && < 1.1, + natural-sort >= 0.1.2 && < 0.2, parser-combinators >= 1.2 && < 1.4, prettyprinter >= 1.7.0 && < 1.8, random >= 1.2.0 && < 1.3, @@ -160,23 +163,20 @@ split >= 0.2.3 && < 0.3, stm >= 2.5.0 && < 2.6, syb >= 0.7 && < 0.8, - template-haskell >= 2.16 && < 2.19, + tagged >= 0.8 && < 0.9, + template-haskell >= 2.16 && < 2.20, text >= 1.2.4 && < 2.1, + text-zipper >= 0.10 && < 0.13, time >= 1.9 && < 1.14, unification-fd >= 0.11 && < 0.12, unordered-containers >= 0.2.14 && < 0.3, - vector >= 0.12 && < 0.13, - vty >= 5.33 && < 5.37, + vector >= 0.12 && < 0.14, + vty >= 5.33 && < 5.38, wai >= 3.2 && < 3.3, warp >= 3.2 && < 3.4, - witch >= 0.3.4 && < 1.1, + witch >= 1.1.1.0 && < 1.2, word-wrap >= 0.5 && < 0.6, yaml >= 0.11 && < 0.12, - - -- Temporary workaround for TomMD/entropy#75. - -- We should be able to remove this bound once - -- it is fixed. - entropy <= 0.4.1.7, hs-source-dirs: src default-language: Haskell2010 default-extensions: diff --git a/test/integration/Main.hs b/test/integration/Main.hs --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -29,6 +29,7 @@ GameState, WinCondition (Won), activeRobots, + baseRobot, initGameStateForScenario, messageQueue, robotMap, @@ -198,8 +199,7 @@ , testSolution Default "Testing/479-atomic-race" , testSolution (Sec 5) "Testing/479-atomic" , testSolution Default "Testing/555-teleport-location" - , expectFailBecause "Awaiting fix (#540)" $ - testSolution (Sec 10) "Testing/562-lodestone" + , testSolution Default "Testing/562-lodestone" , testSolution Default "Testing/378-objectives" , testSolution Default "Testing/684-swap" , testSolution Default "Testing/699-movement-fail/699-move-blocked" @@ -221,7 +221,7 @@ case gs ^. winSolution of Nothing -> assertFailure "No solution to test!" Just sol -> do - let gs' = gs & robotMap . ix 0 . machine .~ initMachine sol Ctx.empty emptyStore + let gs' = gs & baseRobot . machine .~ initMachine sol Ctx.empty emptyStore m <- timeout (time s) (snd <$> runStateT playUntilWin gs') case m of Nothing -> assertFailure "Timed out - this likely means that the solution did not work." diff --git a/test/unit/TestLanguagePipeline.hs b/test/unit/TestLanguagePipeline.hs --- a/test/unit/TestLanguagePipeline.hs +++ b/test/unit/TestLanguagePipeline.hs @@ -10,6 +10,8 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Swarm.Language.Pipeline (processTerm) +import Swarm.Language.Typecheck (isSimpleUType) +import Swarm.Language.Types import Test.Tasty import Test.Tasty.HUnit import Witch (from) @@ -232,6 +234,16 @@ , testCase "invalid hex literal" (process "0xabcD6G2" "1:8:\n |\n1 | 0xabcD6G2\n | ^\nunexpected 'G'\n") + ] + , testGroup + "void type" + [ testCase + "void - isSimpleUType" + ( assertBool "" $ isSimpleUType UTyVoid + ) + , testCase + "void - valid type signature" + (valid "def f : void -> a = \\x. undefined end") ] ] where diff --git a/test/unit/TestPretty.hs b/test/unit/TestPretty.hs --- a/test/unit/TestPretty.hs +++ b/test/unit/TestPretty.hs @@ -5,6 +5,7 @@ import Swarm.Language.Pretty import Swarm.Language.Syntax hiding (mkOp) +import Swarm.Language.Types import Test.Tasty import Test.Tasty.HUnit @@ -76,6 +77,10 @@ "pairs #225 - nested pairs are printed right-associative" ( equalPretty "(1, 2, 3)" $ TPair (TInt 1) (TPair (TInt 2) (TInt 3)) + ) + , testCase + "void type" + ( assertEqual "" "void" . show $ ppr TyVoid ) ] where