diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,124 @@ # Revision history for swarm +## **0.7.0.0** - 2025-06-03 + +### Breaking changes + +* `return` has been renamed to `pure` ([#2285](https://github.com/swarm-game/swarm/pull/2285)) +* `fst`/`snd` have been removed in favor of a pair eliminator called `match` ([#2407](https://github.com/swarm-game/swarm/pull/2407)) +* `require ` has been renamed to `stock ` to reduce ambiguity with `require ` ([#2455](https://github.com/swarm-game/swarm/pull/2455)). + +You can use `swarm format --v0.6` to automatically convert old code. + +### Bugfixes + +* Report cycles correctly in error messages ([#2199](https://github.com/swarm-game/swarm/pull/2199)) +* Validate hex colors in `FromJSON` instance ([#2237](https://github.com/swarm-game/swarm/pull/2237)) +* Make custom entities override built-in entities ([#2241](https://github.com/swarm-game/swarm/pull/2241)) +* Make `halt`ed robots immediately wake up ([#2254](https://github.com/swarm-game/swarm/pull/2254)) +* Don't update scenario completion stats after scenario completion ([#2256](https://github.com/swarm-game/swarm/pull/2256)) +* Only `meet` interactive robots ([#2262](https://github.com/swarm-game/swarm/pull/2262)) +* Evaluate argument to `instant`/`atomic` atomically ([#2271](https://github.com/swarm-game/swarm/pull/2271)) +* Fix type inference for recursive let bindings ([#2187](https://github.com/swarm-game/swarm/pull/2187)) +* Fix two space leaks ([#2448](https://github.com/swarm-game/swarm/pull/2448)) +* Fix robot modal memory leak by only rendering modal when it is displayed ([#2379](https://github.com/swarm-game/swarm/pull/2379)) +* Fix completed scenarios so they always show green status ([#2312](https://github.com/swarm-game/swarm/pull/2312)) +* Fix shadowing for user-defined types ([#2450](https://github.com/swarm-game/swarm/pull/2450)) + +### Features + Enhancements + +#### New commands + +* `print` + `erase` commands for printing on paper ([#2245](https://github.com/swarm-game/swarm/pull/2245)) +* New `read` command to act as partial inverse to `format` ([#2224](https://github.com/swarm-game/swarm/pull/2224), [#2461](https://github.com/swarm-game/swarm/pull/2461)) +* New subworld-aware teleportation and location query commands, `warp` and `locateme` ([#2195](https://github.com/swarm-game/swarm/pull/2195)) + +#### Language + +* Improve type inference for record projection ([#2172](https://github.com/swarm-game/swarm/pull/2172)) +* Scoped type variables ([#2178](https://github.com/swarm-game/swarm/pull/2178)) +* Do requirements analysis for literal text argument to `use` ([#2211](https://github.com/swarm-game/swarm/pull/2211)) +* Rename `return` to `pure` ([#2285](https://github.com/swarm-game/swarm/pull/2285)) +* Replace `fst` and `snd` with pair eliminator `match` ([#2407](https://github.com/swarm-game/swarm/pull/2407)) +* Rename `require n` to `stock` ([#2455](https://github.com/swarm-game/swarm/pull/2455)) +* Custom error message for missing `end` (#1141) ([#2373](https://github.com/swarm-game/swarm/pull/2373)) +* Use original variable names in error messages about Skolem variables ([#2340](https://github.com/swarm-game/swarm/pull/2340)) + +#### Entities + Recipes + +* Make `rolex` show time ([#2147](https://github.com/swarm-game/swarm/pull/2147)) +* `atlas` entity ([#2257](https://github.com/swarm-game/swarm/pull/2257)) +* Recipes for `binoculars` ([#2391](https://github.com/swarm-game/swarm/pull/2391)) +* `water` disappears when placed ([#2358](https://github.com/swarm-game/swarm/pull/2358)) + +#### Tutorials + Scenarios + +* Make `Tutorial` menu choice auto-start first *unsolved* tutorial scenario ([#2314](https://github.com/swarm-game/swarm/pull/2314)) +* Add some optional goals to the classic scenario ([#2436](https://github.com/swarm-game/swarm/pull/2436)) +* A number of small tutorial improvements + ([#2406](https://github.com/swarm-game/swarm/pull/2406), + [#2405](https://github.com/swarm-game/swarm/pull/2405), + [#2404](https://github.com/swarm-game/swarm/pull/2404), + [#2409](https://github.com/swarm-game/swarm/pull/2409), + [#2421](https://github.com/swarm-game/swarm/pull/2421), + [#2361](https://github.com/swarm-game/swarm/pull/2361), + [#2359](https://github.com/swarm-game/swarm/pull/2359), + [#2444](https://github.com/swarm-game/swarm/pull/2444)) +* Progress bar vignette ([#2190](https://github.com/swarm-game/swarm/pull/2190)) +* Counting flowers ([#2249](https://github.com/swarm-game/swarm/pull/2249)) +* Spiders demo ([#2275](https://github.com/swarm-game/swarm/pull/2275)) +* Dictionary implementation + benchmark ([#2191](https://github.com/swarm-game/swarm/pull/2191)) +* Get rid of "world offset" + add burned patch around base in classic scenario ([#2344](https://github.com/swarm-game/swarm/pull/2344)) +* DNA copying challenge ([#1031](https://github.com/swarm-game/swarm/pull/1031)) +* Exterminator scenario ([#2126](https://github.com/swarm-game/swarm/pull/2126)) + +#### Achievements + +* Achievement for completing all tutorials ([#2354](https://github.com/swarm-game/swarm/pull/2354)) +* Grant `AttemptSelfDestructBase` achievement for movement as well as `selfdestruct` ([#2356](https://github.com/swarm-game/swarm/pull/2356)) +* Swiss Army Robot achievement for equipping all craftable devices in classic game ([#2424](https://github.com/swarm-game/swarm/pull/2424)) + +#### Scenario mechanics and authoring improvements + +* Refactor + comment `World Examples/clearing` to make it easier to understand ([#2305](https://github.com/swarm-game/swarm/pull/2305)) +* New combustion delay parameter ([#2248](https://github.com/swarm-game/swarm/pull/2248)) +* Structure enhancements + * Demo standalone colored structures ([#2099](https://github.com/swarm-game/swarm/pull/2099)) + * ensure no overlaps in initial placement of recognized structures ([#2212](https://github.com/swarm-game/swarm/pull/2212)) + * shape recognition with piecewise rows ([#2201](https://github.com/swarm-game/swarm/pull/2201)) + * Fix shape recognition orientation edge case ([#2229](https://github.com/swarm-game/swarm/pull/2229)) +* Render contiguous boundaries ([#1285](https://github.com/swarm-game/swarm/pull/1285)) and remove old individual wall entities ([#2328](https://github.com/swarm-game/swarm/pull/2328)) + +#### UI enhancements + +* Pause on objective completion ([#2096](https://github.com/swarm-game/swarm/pull/2096)) +* Navigable robots table ([#2140](https://github.com/swarm-game/swarm/pull/2140)) +* Expose waypoint and portal info to web API ([#2185](https://github.com/swarm-game/swarm/pull/2185)) +* Warn the user when debugging options are on ([#2278](https://github.com/swarm-game/swarm/pull/2278)) +* Scenarios started from command line now quit directly back to command line ([#2280](https://github.com/swarm-game/swarm/pull/2280)) +* Make FPS toggle and "recenter view" into global events ([#2293](https://github.com/swarm-game/swarm/pull/2293)) +* Minimize list of required device sets in error messages ([#2299](https://github.com/swarm-game/swarm/pull/2299)) +* Clickable shortcuts in TUI ([#2324](https://github.com/swarm-game/swarm/pull/2324)) +* Don't re-validate REPL input when moving the cursor left or right ([#2365](https://github.com/swarm-game/swarm/pull/2365)) +* Legend for colorization in F1 dialog ([#2175](https://github.com/swarm-game/swarm/pull/2175)) +* Render map preview as dynamic PNG ([#2184](https://github.com/swarm-game/swarm/pull/2184)) +* Don't insert extra close bracket when the cursor is already on top of one ([#2215](https://github.com/swarm-game/swarm/pull/2215)) +* Add Replay game script ([#2446](https://github.com/swarm-game/swarm/pull/2446)) + +#### Pretty printing + Formatting + +* Put end on separate line when pretty printing definitions ([#2100](https://github.com/swarm-game/swarm/pull/2100)) +* Improvements to comment preservation in `swarm format` ([#2329](https://github.com/swarm-game/swarm/pull/2329)) + +#### Command line options + +* Add CLI option to start the game paused ([#2080](https://github.com/swarm-game/swarm/pull/2080)) +* Split out debug options ([#2094](https://github.com/swarm-game/swarm/pull/2094)) + +### Building/packaging + +* Add support for GHC 9.10 and 9.12, and drop 9.2 and 9.4 + ## **0.6.0.0** - 2024-07-15 Some of the highlights of this release include native Windows support, @@ -396,7 +515,7 @@ - scenarios which can be loaded from YAML files - the release comes with official challenges and an in-game tutorial - the default Classic and Creative modes use the same YAML syntax - - we include JSON schemas for editor support when writing scenarios + - we include JSON schemas for editor support when writing scenarios - procedural 2D world generation - LSP server built into the Swarm executable - Terminal UI interface diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Main where - -import Control.Monad (when) -import Data.Foldable qualified -import Data.Text.IO qualified as T -import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) -import Options.Applicative -import Swarm.App (appMain) -import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) -import Swarm.Language.Format -import Swarm.Language.LSP (lspMain) -import Swarm.Language.Parser.Core (LanguageVersion (..)) -import Swarm.TUI.Model (AppOpts (..), ColorMode (..)) -import Swarm.TUI.Model.KeyBindings (KeybindingPrint (..), showKeybindings) -import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond) -import Swarm.Version -import Swarm.Web (defaultPort) -import System.IO (hPrint, stderr) -import Text.Read (readMaybe) - -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 - | -- | Print list of bindings, optionally initializing the INI configuration file. - ListKeybinding Bool KeybindingPrint - | Format FormatConfig - | LSP - | Version - -cliParser :: Parser CLI -cliParser = - subparser - ( mconcat - [ command "format" (info (Format <$> parseFormat) (progDesc "Format a file")) - , command "lsp" (info (pure LSP) (progDesc "Start the LSP")) - , command "version" (info (pure Version) (progDesc "Get current and upstream version.")) - , command "keybindings" (info (ListKeybinding <$> initKeybindingConfig <*> printKeyMode <**> helper) (progDesc "List the keybindings")) - ] - ) - <|> Run - <$> ( AppOpts - <$> seed - <*> scenario - <*> run - <*> autoplay - <*> speedFactor - <*> cheat - <*> color - <*> webPort - <*> pure gitInfo - ) - where - input :: Parser FormatInput - input = - flag' Stdin (long "stdin" <> help "Read code from stdin") - <|> (InputFile <$> strArgument (metavar "FILE")) - - output :: Parser FormatOutput - output = - flag Stdout Stdout (long "stdout" <> help "Write formatted code to stdout (default)") - <|> (OutputFile <$> strOption (long "output" <> short 'o' <> metavar "FILE" <> help "Write formatted code to an output file")) - <|> flag' Inplace (long "inplace" <> short 'i' <> help "Format file in place") - - widthOpt :: Parser FormatWidth - widthOpt = option auto (long "width" <> metavar "COLUMNS" <> help "Use layout with maximum width") - - langVer :: Parser LanguageVersion - langVer = flag SwarmLangLatest SwarmLang0_5 (long "v0.5" <> help "Read (& convert) code from Swarm version 0.5") - - printKeyMode :: Parser KeybindingPrint - printKeyMode = - flag' IniPrint (long "ini" <> help "Print in INI format") - <|> flag' MarkdownPrint (long "markdown" <> help "Print in Markdown table format") - <|> pure TextPrint - - initKeybindingConfig :: Parser Bool - initKeybindingConfig = switch (short 'i' <> long "init" <> help "Initialise the keybindings configuration file") - - parseFormat :: Parser FormatConfig - parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper - - 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) - webPort = - optional $ - option - auto - ( long "web" - <> metavar "PORT" - <> help ("Set the web service port (or disable it with 0). Default to " <> show defaultPort <> ".") - ) - scenario :: Parser (Maybe String) - scenario = optional $ strOption (long "scenario" <> short 'i' <> metavar "FILE" <> help "Name of an input 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.") - speedFactor :: Parser Int - speedFactor = option auto (long "speed" <> short 'm' <> value defaultInitLgTicksPerSecond <> help "Initial game speed multiplier") - cheat :: Parser Bool - 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.") - color :: Parser (Maybe ColorMode) - color = optional $ option colorModeParser (long "color" <> short 'c' <> metavar "MODE" <> help "Use none/8/16/full color mode.") - colorModeParser = - Data.Foldable.asum - [ ColorMode8 <$ text "8" - , ColorMode16 <$ text "16" - , ColorMode240 <$> maybeReader (\case ('2' : '4' : '0' : '_' : w) -> readMaybe w; _ -> Nothing) - , FullColor <$ text "full" - , NoColor <$ text "none" - ] - text t = maybeReader (\x -> if x == t then Just x else Nothing) - -cliInfo :: ParserInfo CLI -cliInfo = - info - (cliParser <**> helper) - ( header ("Swarm game - " <> version <> commitInfo) - <> progDesc "To play the game simply run without any command." - <> fullDesc - ) - -showVersion :: IO () -showVersion = do - putStrLn $ "Swarm game - " <> version <> commitInfo - up <- getNewerReleaseVersion gitInfo - either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up - -printKeybindings :: Bool -> KeybindingPrint -> IO () -printKeybindings initialize p = do - kb <- showKeybindings p - T.putStrLn kb - (iniExists, ini) <- getSwarmConfigIniFile initialize - when initialize $ do - kbi <- showKeybindings IniPrint - T.writeFile ini kbi - let iniState - | iniExists && initialize = "has been updated" - | iniExists = "is" - | initialize = "has been created" - | otherwise = "can be created (--init)" - putStrLn $ replicate 80 '-' - putStrLn $ "The configuration file " <> iniState <> " at:" - putStrLn ini - -main :: IO () -main = do - cli <- execParser cliInfo - case cli of - Run opts -> appMain opts - ListKeybinding initialize p -> printKeybindings initialize p - Format cfg -> formatSwarmIO cfg - LSP -> lspMain - Version -> showVersion diff --git a/app/Swarm/App.hs b/app/Swarm/App.hs deleted file mode 100644 --- a/app/Swarm/App.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -{- HLINT ignore "Use underscore" -} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- Description: Application entry point --- --- Main entry point for the Swarm application. -module Swarm.App where - -import Brick -import Brick.BChan -import Control.Carrier.Lift (runM) -import Control.Carrier.Throw.Either (runThrow) -import Control.Concurrent (forkIO, threadDelay) -import Control.Lens (view, (%~), (&), (?~)) -import Control.Monad (forever, void, when) -import Control.Monad.IO.Class (liftIO) -import Data.IORef (newIORef, writeIORef) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import Graphics.Vty qualified as V -import Graphics.Vty.CrossPlatform qualified as V -import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.State.Runtime -import Swarm.Language.Pretty (prettyText) -import Swarm.Log (LogSource (SystemLog), Severity (..)) -import Swarm.TUI.Controller -import Swarm.TUI.Model -import Swarm.TUI.Model.StateUpdate -import Swarm.TUI.Model.UI (uiAttrMap) -import Swarm.TUI.View -import Swarm.Util.ReadableIORef (mkReadonly) -import Swarm.Version (getNewerReleaseVersion) -import Swarm.Web -import System.IO (stderr) - -type EventHandler = BrickEvent Name AppEvent -> EventM Name AppState () - --- | The configuration of the Swarm app which we pass to the @brick@ --- library. -app :: EventHandler -> App AppState AppEvent Name -app eventHandler = - App - { appDraw = drawUI - , appChooseCursor = chooseCursor - , appHandleEvent = eventHandler - , appStartEvent = enablePasteMode - , appAttrMap = view $ uiState . uiAttrMap - } - --- | The main @IO@ computation which initializes the state, sets up --- some communication channels, and runs the UI. -appMain :: AppOpts -> IO () -appMain opts = do - res <- runM . runThrow $ initAppState opts - case res of - Left err -> T.hPutStrLn stderr (prettyText @SystemFailure err) - Right s -> do - -- Send Frame events as at a reasonable rate for 30 fps. The - -- game is responsible for figuring out how many steps to take - -- each frame to achieve the desired speed, regardless of the - -- frame rate. Note that if the game cannot keep up with 30 - -- fps, it's not a problem: the channel will fill up and this - -- thread will block. So the force of the threadDelay is just - -- to set a *maximum* possible frame rate. - -- - -- 5 is the size of the bounded channel; when it gets that big, - -- any writes to it will block. Probably 1 would work fine, - -- though it seems like it could be good to have a bit of buffer - -- just so the app never has to wait for the thread to wake up - -- and do another write. - - chan <- newBChan 5 - _ <- forkIO $ - forever $ do - threadDelay 33_333 -- cap maximum framerate at 30 FPS - writeBChan chan Frame - - _ <- forkIO $ do - upRel <- getNewerReleaseVersion (repoGitInfo opts) - writeBChan chan (UpstreamVersion upRel) - - -- Start the web service with a reference to the game state. - -- NOTE: This reference should be considered read-only by - -- the web service; the game alone shall host the canonical state. - appStateRef <- newIORef s - eport <- - Swarm.Web.startWebThread - (userWebPort opts) - (mkReadonly appStateRef) - chan - - let logP p = logEvent SystemLog Info "Web API" ("started on :" <> T.pack (show p)) - let logE e = logEvent SystemLog Error "Web API" (T.pack e) - let s1 = - s - & runtimeState - %~ case eport of - Right p -> (webPort ?~ p) . (eventLog %~ logP p) - Left e -> eventLog %~ logE e - - -- Update the reference for every event - let eventHandler e = do - curSt <- get - liftIO $ writeIORef appStateRef curSt - handleEvent e - - -- Setup virtual terminal - let buildVty = V.mkVty V.defaultConfig {V.configPreferredColorMode = colorMode opts} - vty <- buildVty - - V.setMode (V.outputIface vty) V.Mouse True - - let cm = V.outputColorMode $ V.outputIface vty - let s2 = - s1 - & runtimeState . eventLog %~ logEvent SystemLog Info "Graphics" ("Color mode: " <> T.pack (show cm)) - - -- Run the app. - void $ customMain vty buildVty (Just chan) (app eventHandler) s2 - --- | A demo program to run the web service directly, without the terminal application. --- This is useful to live update the code using @ghcid -W --test "Swarm.App.demoWeb"@. -demoWeb :: IO () -demoWeb = do - let demoPort = 8080 - res <- - runM . runThrow $ initAppState (defaultAppOpts {userScenario = demoScenario}) - case res of - Left err -> T.putStrLn (prettyText @SystemFailure err) - Right s -> do - appStateRef <- newIORef s - chan <- newBChan 5 - webMain - Nothing - demoPort - (mkReadonly appStateRef) - chan - where - demoScenario = Just "./data/scenarios/Testing/475-wait-one.yaml" - --- | If available for the terminal emulator, enable bracketed paste mode. -enablePasteMode :: EventM n s () -enablePasteMode = do - vty <- getVtyHandle - let output = V.outputIface vty - when (V.supportsMode output V.BracketedPaste) $ - liftIO $ - V.setMode output V.BracketedPaste True diff --git a/app/doc/Main.hs b/app/doc/Main.hs --- a/app/doc/Main.hs +++ b/app/doc/Main.hs @@ -19,6 +19,7 @@ , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords") , command "keys" (info (pure SpecialKeyNames) $ progDesc "Output list of recognized special key names") , command "cheatsheet" (info (CheatSheet <$> address <*> cheatsheet <**> helper) $ progDesc "Output nice Wiki tables") + , command "commands" (info (pure CommandsData <**> helper) $ progDesc "Output JSON data for commands matrix") , command "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage") ] where diff --git a/app/game/Main.hs b/app/game/Main.hs new file mode 100644 --- /dev/null +++ b/app/game/Main.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Main (main) where + +import Control.Monad (when) +import Data.Foldable qualified +import Data.List.Extra (enumerate) +import Data.Set qualified as Set +import Data.Text.IO qualified as T +import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) +import Options.Applicative +import Options.Applicative.Help hiding (color, fullDesc) +import Swarm.App (appMain) +import Swarm.Language.Format +import Swarm.Language.LSP (lspMain) +import Swarm.Language.Parser.Core (LanguageVersion (..)) +import Swarm.ResourceLoading (getSwarmConfigIniFile) +import Swarm.TUI.Model (AppOpts (..), ColorMode (..)) +import Swarm.TUI.Model.DebugOption +import Swarm.TUI.Model.KeyBindings (KeybindingPrint (..), showKeybindings) +import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond) +import Swarm.Version +import Swarm.Web (defaultPort) +import System.IO (hPrint, stderr) +import Text.Read (readMaybe) + +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 + | -- | Print list of bindings, optionally initializing the INI configuration file. + ListKeybinding Bool KeybindingPrint + | Format FormatConfig + | LSP + | Version + +cliParser :: Parser CLI +cliParser = + subparser + ( mconcat + [ command "run" (info (Run <$> appOpts <**> helper) (progDesc "Run the Swarm game (default)")) + , command "format" (info (Format <$> parseFormat) (progDesc "Format a file")) + , command "lsp" (info (pure LSP) (progDesc "Start the LSP")) + , command "version" (info (pure Version) (progDesc "Get current and upstream version.")) + , command "keybindings" (info (ListKeybinding <$> initKeybindingConfig <*> printKeyMode <**> helper) (progDesc "List the keybindings")) + ] + ) + <|> Run <$> appOpts + where + appOpts :: Parser AppOpts + appOpts = do + let repoGitInfo = gitInfo + userSeed <- seed + userScenario <- scenario + scriptToRun <- run + pausedAtStart <- paused + autoPlay <- autoplay + autoShowObjectives <- not <$> hideGoal + speed <- speedFactor + debugOptions <- debug + cheatMode <- cheat + colorMode <- color + userWebPort <- webPort + -- ApplicativeDo does not give Monad powers, so cheat is added here + return $ addToDebug cheatMode $ AppOpts {..} + + addToDebug :: Set.Set DebugOption -> AppOpts -> AppOpts + addToDebug cheatMode ao = ao {debugOptions = cheatMode `Set.union` debugOptions ao} + + input :: Parser FormatInput + input = + flag' Stdin (long "stdin" <> help "Read code from stdin") + <|> (InputFile <$> strArgument (metavar "FILE")) + + output :: Parser FormatOutput + output = + flag Stdout Stdout (long "stdout" <> help "Write formatted code to stdout (default)") + <|> (OutputFile <$> strOption (long "output" <> short 'o' <> metavar "FILE" <> help "Write formatted code to an output file")) + <|> flag' Inplace (long "inplace" <> short 'i' <> help "Format file in place") + + widthOpt :: Parser FormatWidth + widthOpt = option auto (long "width" <> metavar "COLUMNS" <> help "Use layout with maximum width") + + langVer :: Parser LanguageVersion + langVer = flag SwarmLangLatest SwarmLang0_6 (long "v0.6" <> help "Read (& convert) code from Swarm version 0.6") + + printKeyMode :: Parser KeybindingPrint + printKeyMode = + flag' IniPrint (long "ini" <> help "Print in INI format") + <|> flag' MarkdownPrint (long "markdown" <> help "Print in Markdown table format") + <|> pure TextPrint + + initKeybindingConfig :: Parser Bool + initKeybindingConfig = switch (short 'i' <> long "init" <> help "Initialise the keybindings configuration file") + + parseFormat :: Parser FormatConfig + parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper + + 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) + webPort = + optional $ + option + auto + ( long "web" + <> metavar "PORT" + <> help ("Set the web service port (or disable it with 0). Default to " <> show defaultPort <> ".") + ) + scenario :: Parser (Maybe String) + scenario = optional $ strOption (long "scenario" <> short 'i' <> metavar "FILE" <> help "Name of an input 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") + paused :: Parser Bool + paused = switch (long "paused" <> short 'p' <> help "Pause the game at start.") + 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.") + hideGoal :: Parser Bool + hideGoal = switch (long "hide-goal" <> help "Do not show goal modal window that pauses the game.") + speedFactor :: Parser Int + speedFactor = option auto (long "speed" <> short 'm' <> metavar "N" <> value defaultInitLgTicksPerSecond <> help speedFactorHelp) + speedFactorHelp = + unwords + [ "Initial game speed." + , "Counted as 2^N ticks per second, default is" + , show defaultInitLgTicksPerSecond + , "meaning" + , show $ 2 ** fromIntegral @Int @Double defaultInitLgTicksPerSecond + , "t/s." + , "(Negative values are allowed, e.g. -3 means 1 tick per 8 sec.)" + ] + + debug :: Parser (Set.Set DebugOption) + debug = Set.unions <$> many debugOption + debugOption :: Parser (Set.Set DebugOption) + debugOption = + option + debugOptionList + ( long "debug" + <> short 'd' + <> metavar "OPTS" + <> hidden + <> helpDoc debugOptionHelp + <> completeWith debugCompletions + ) + debugCompletions = "all" : map debugOptionName enumerate + debugOptionList :: ReadM (Set.Set DebugOption) + debugOptionList = eitherReader $ \case + "all" -> pure $ Set.fromAscList enumerate + opts -> Set.fromList <$> readDebugOptionList opts + debugOptionHelp :: Maybe Doc + debugOptionHelp = + Just . nest 2 . vsep $ + "Use 'all' or a comma separated list of options:" + : [ fillBreak 20 ("*" <+> pretty name) <+> pretty desc + | o <- enumerate + , let name = debugOptionName o + , let desc = debugOptionDescription o + ] + cheat :: Parser (Set.Set DebugOption) + cheat = flag mempty (Set.singleton ToggleCreative) (long "cheat" <> short 'x' <> helpDoc (Just cheatHelp)) + cheatHelp = + "Enable cheat mode." + <+> pretty ("This is an alias for --debug=" <> debugOptionName ToggleCreative) + + color :: Parser (Maybe ColorMode) + color = optional $ option colorModeParser (long "color" <> short 'c' <> metavar "MODE" <> help "Use none/8/16/full color mode.") + colorModeParser = + Data.Foldable.asum + [ ColorMode8 <$ text "8" + , ColorMode16 <$ text "16" + , ColorMode240 <$> maybeReader (\case ('2' : '4' : '0' : '_' : w) -> readMaybe w; _ -> Nothing) + , FullColor <$ text "full" + , NoColor <$ text "none" + ] + text t = maybeReader (\x -> if x == t then Just x else Nothing) + +cliInfo :: ParserInfo CLI +cliInfo = + info + (cliParser <**> helper) + ( header ("Swarm game - " <> version <> commitInfo) + <> progDesc "To play the game simply run without any command." + <> fullDesc + ) + +showVersion :: IO () +showVersion = do + putStrLn $ "Swarm game - " <> version <> commitInfo + up <- getNewerReleaseVersion gitInfo + either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up + +printKeybindings :: Bool -> KeybindingPrint -> IO () +printKeybindings initialize p = do + kb <- showKeybindings p + T.putStrLn kb + (iniExists, ini) <- getSwarmConfigIniFile initialize + when initialize $ do + kbi <- showKeybindings IniPrint + T.writeFile ini kbi + let iniState + | iniExists && initialize = "has been updated" + | iniExists = "is" + | initialize = "has been created" + | otherwise = "can be created (--init)" + putStrLn $ replicate 80 '-' + putStrLn $ "The configuration file " <> iniState <> " at:" + putStrLn ini + +main :: IO () +main = do + cli <- execParser cliInfo + case cli of + Run opts -> appMain opts + ListKeybinding initialize p -> printKeybindings initialize p + Format cfg -> formatSwarmIO cfg + LSP -> lspMain + Version -> showVersion diff --git a/app/game/Swarm/App.hs b/app/game/Swarm/App.hs new file mode 100644 --- /dev/null +++ b/app/game/Swarm/App.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{- HLINT ignore "Use underscore" -} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Application entry point +-- +-- Main entry point for the Swarm application. +module Swarm.App ( + app, + appMain, + EventHandler, + + -- * Demo web + demoWeb, +) where + +import Brick +import Brick.BChan +import Control.Carrier.Lift (runM) +import Control.Carrier.Throw.Either (runThrow) +import Control.Concurrent (forkIO, threadDelay) +import Control.Lens (view, (%~), (?~)) +import Control.Monad (forever, void, when) +import Control.Monad.IO.Class (liftIO) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import GitHash (GitInfo) +import Graphics.Vty qualified as V +import Graphics.Vty.CrossPlatform qualified as V +import Swarm.Failure (SystemFailure) +import Swarm.Game.State.Runtime +import Swarm.Log (LogSource (SystemLog), Severity (..)) +import Swarm.Pretty (prettyText) +import Swarm.TUI.Controller +import Swarm.TUI.Model +import Swarm.TUI.Model.StateUpdate +import Swarm.TUI.Model.UI (uiAttrMap) +import Swarm.TUI.View +import Swarm.Version (getNewerReleaseVersion) +import Swarm.Web +import System.Exit +import System.IO (stderr) + +type EventHandler = BrickEvent Name AppEvent -> EventM Name AppState () + +-- | The configuration of the Swarm app which we pass to the @brick@ +-- library. +app :: EventHandler -> App AppState AppEvent Name +app eventHandler = + App + { appDraw = drawUI + , appChooseCursor = chooseCursor + , appHandleEvent = eventHandler + , appStartEvent = pure () + , appAttrMap = view $ uiState . uiAttrMap + } + +-- | The main @IO@ computation which initializes the state, sets up +-- some communication channels, and runs the UI. +appMain :: AppOpts -> IO () +appMain opts = do + chan <- createChannel + res <- runM . runThrow $ initAppState opts (Just chan) + case res of + Left err -> do + T.hPutStrLn stderr (prettyText @SystemFailure err) + exitFailure + Right s -> do + -- NOTE: The state reference is read-only by the web service; + -- the brick app has the real state and updates the reference. + appStateRef <- newIORef s + sendFrameEvents chan + sendUpstreamVersion chan (repoGitInfo opts) + -- Start web service + eport <- + Swarm.Web.startWebThread + (userWebPort opts) + (readIORef appStateRef) + (writeBChan chan) + + modifyIORef appStateRef $ logWebPort eport + + -- Setup virtual terminal + vty <- buildVty $ colorMode opts + modifyIORef appStateRef $ logColorMode vty + + -- Run the app. + void $ + readIORef appStateRef + >>= customMain + vty + (buildVty $ colorMode opts) + (Just chan) + (app $ handleEventAndUpdateWeb appStateRef) + +-- | A demo program to run the web service directly, without the terminal application. +-- This is useful to live update the code using @ghcid -W --test "Swarm.App.demoWeb"@. +demoWeb :: IO () +demoWeb = do + let demoPort = 8080 + chan <- createChannel + res <- + runM . runThrow $ initAppState (defaultAppOpts {userScenario = demoScenario}) (Just chan) + case res of + Left err -> T.putStrLn (prettyText @SystemFailure err) + Right s -> do + webMain + Nothing + demoPort + (pure s) + (writeBChan chan) + where + demoScenario = Just "./data/scenarios/Testing/475-wait-one.yaml" + +-- | Create a channel for app events. +-- +-- 5 is the size of the bounded channel; when it gets that big, +-- any writes to it will block. Probably 1 would work fine, +-- though it seems like it could be good to have a bit of buffer +-- just so the app never has to wait for the thread to wake up +-- and do another write. +-- +-- Note that there are occasionally other events (web, version) +-- so this buffer is big enough for them too. +createChannel :: IO (BChan AppEvent) +createChannel = newBChan 5 + +-- | Send Frame events as at a reasonable rate for 30 fps. +-- +-- The game is responsible for figuring out how many steps to take +-- each frame to achieve the desired speed, regardless of the +-- frame rate. Note that if the game cannot keep up with 30 +-- fps, it's not a problem: the channel will fill up and this +-- thread will block. So the force of the threadDelay is just +-- to set a *maximum* possible frame rate. +sendFrameEvents :: BChan AppEvent -> IO () +sendFrameEvents chan = void . forkIO . forever $ do + writeBChan chan Frame + threadDelay 33_333 -- cap maximum framerate at 30 FPS + +-- | Get newer upstream version and send event to channel. +sendUpstreamVersion :: BChan AppEvent -> Maybe GitInfo -> IO () +sendUpstreamVersion chan gitInfo = void . forkIO $ do + upRel <- getNewerReleaseVersion gitInfo + writeBChan chan (UpstreamVersion upRel) + +-- | Log and save the web port or log web startup failure. +logWebPort :: Either String Int -> AppState -> AppState +logWebPort eport = + runtimeState %~ case eport of + Right p -> (webPort ?~ p) . (eventLog %~ logP p) + Left e -> eventLog %~ logE e + where + logP p = logEvent SystemLog Info "Web API" ("started on :" <> T.pack (show p)) + logE e = logEvent SystemLog Error "Web API" (T.pack e) + +-- | Build VTY with preffered color mode and bracketed paste mode if available. +-- +-- Note that this will also run whenever the event loop needs to reinitialize +-- the terminal, e.g. on resume after suspension. See 'customMain'. +buildVty :: Maybe ColorMode -> IO V.Vty +buildVty cm = do + vty <- V.mkVty V.defaultConfig {V.configPreferredColorMode = cm} + let output = V.outputIface vty + V.setMode output V.Mouse True + when (V.supportsMode output V.BracketedPaste) $ + V.setMode output V.BracketedPaste True + return vty + +-- | Log the VTY color mode to system log. +logColorMode :: V.Vty -> AppState -> AppState +logColorMode vty = runtimeState . eventLog %~ logEvent SystemLog Info "Graphics" ("Color mode: " <> T.pack (show cm)) + where + cm = V.outputColorMode $ V.outputIface vty + +-- | Update the reference after every event. +handleEventAndUpdateWeb :: IORef AppState -> BrickEvent Name AppEvent -> EventM Name AppState () +handleEventAndUpdateWeb appStateRef e = do + handleEvent e + curSt <- get + liftIO $ writeIORef appStateRef curSt diff --git a/app/game/Swarm/Version.hs b/app/game/Swarm/Version.hs new file mode 100644 --- /dev/null +++ b/app/game/Swarm/Version.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Query current and upstream Swarm version. +module Swarm.Version ( + -- * PVP version + isSwarmReleaseTag, + version, + + -- ** Upstream release + tagToVersion, + upstreamReleaseVersion, + getNewerReleaseVersion, + NewReleaseFailure (..), +) where + +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.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Version (Version (..), parseVersion, showVersion) +import Data.Yaml (ParseException, Parser, decodeEither', parseEither) +import GitHash (GitInfo, giBranch) +import Network.HTTP.Client ( + HttpException, + Request (requestHeaders), + Response (responseBody), + httpLbs, + newManager, + parseRequest, + ) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types (hUserAgent) +import Paths_swarm qualified +import Swarm.Log +import Swarm.Util (failT, quote) +import Text.ParserCombinators.ReadP (readP_to_S) + +-- $setup +-- >>> import Data.Bifunctor (first) +-- >>> import Data.Version (Version (..), parseVersion) +-- >>> import Text.ParserCombinators.ReadP (readP_to_S) + +-- | 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 == '.') + +version :: String +version = + let v = showVersion Paths_swarm.version + in if v == "0.0.0.1" then "pre-alpha version" else v + +-- | Get the current upstream release version if any. +upstreamReleaseVersion :: IO (Either NewReleaseFailure String) +upstreamReleaseVersion = + catch + (either parseFailure getRelease . decodeResp <$> sendRequest) + (return . Left . queryFailure) + where + -- ------------------------------ + -- send request to GitHub API + sendRequest :: IO (Response BSL.ByteString) + sendRequest = do + manager <- newManager tlsManagerSettings + request <- parseRequest "https://api.github.com/repos/swarm-game/swarm/releases" + httpLbs + request {requestHeaders = [(hUserAgent, "swarm-game/swarm-swarmversion")]} + manager + -- ------------------------------ + -- get the latest actual release + getRelease :: Array -> Either NewReleaseFailure String + getRelease rs = + let ts = parseReleases rs + maybeRel = listToMaybe $ rights ts + in case maybeRel of + Nothing -> Left $ NoMainUpstreamRelease (lefts ts) + Just rel -> Right rel + -- ------------------------------ + -- pretty print failures + parseFailure :: ParseException -> Either NewReleaseFailure String + parseFailure e = Left . FailedReleaseQuery $ "Failure during response parsing: " <> displayException e + queryFailure :: HttpException -> NewReleaseFailure + queryFailure e = FailedReleaseQuery $ "Failure requesting GitHub releases: " <> displayException e + -- ------------------------------ + -- parsing helpers + decodeResp :: Response BSL.ByteString -> Either ParseException Array + decodeResp resp = decodeEither' (BS.pack . BSL.unpack $ responseBody resp) + parseReleases :: Array -> [Either String String] + parseReleases = map (parseEither parseRelease) . toList + +parseRelease :: Value -> Parser String +parseRelease = \case + Object o -> do + pre <- o .: "prerelease" + if pre + then fail "Not a real release!" + else do + t <- o .: "tag_name" + if isSwarmReleaseTag t + then return t + else failT ["The release", quote $ T.pack t, "is not main Swarm release!"] + _otherValue -> fail "The JSON release is not an Object!" + +data NewReleaseFailure where + FailedReleaseQuery :: String -> NewReleaseFailure + NoMainUpstreamRelease :: [String] -> NewReleaseFailure + OnDevelopmentBranch :: String -> NewReleaseFailure + OldUpstreamRelease :: Version -> Version -> NewReleaseFailure + +instance Show NewReleaseFailure where + show = \case + FailedReleaseQuery e -> "Failed to query upstream release: " <> e + NoMainUpstreamRelease fs -> + "No upstream releases found." + <> if null fs + then "" + else " Rejected:\n" <> unlines (zipWith ((<>) . show @Int) [1 ..] fs) + OnDevelopmentBranch br -> "Currently on development branch '" <> br <> "', skipping release query." + OldUpstreamRelease up my -> + "Upstream release '" + <> showVersion up + <> "' is not newer than mine ('" + <> showVersion my + <> "')." + +-- | Read Swarm tag as Version. +-- +-- Swarm tags follow the PVP versioning scheme, so comparing them makes sense. +-- +-- >>> map (first versionBranch) $ readP_to_S parseVersion "0.1.0.0" +-- [([0],".1.0.0"),([0,1],".0.0"),([0,1,0],".0"),([0,1,0,0],"")] +-- >>> Version [0,0,0,1] [] < tagToVersion "0.1.0.0" +-- True +tagToVersion :: String -> Version +tagToVersion = fst . last . readP_to_S parseVersion + +-- | Drop trailing zeros from versions so that we can compare them. +normalize :: Version -> Version +normalize (Version ns tags) = Version (dropTrailing0 ns) tags + where + dropTrailing0 = reverse . dropWhile (== 0) . reverse + +-- | Get a newer upstream release version. +-- +-- This function can fail if the current branch is not main, +-- if there is no Internet connection or no newer release. +getNewerReleaseVersion :: Maybe GitInfo -> IO (Either (Severity, Text) String) +getNewerReleaseVersion mgi = first errToPair <$> getVer + where + myVer :: Version + myVer = Paths_swarm.version + getVer :: IO (Either NewReleaseFailure String) + getVer = + case mgi of + -- when using cabal install, the git info is unavailable, which is of no interest to players + Nothing -> (>>= getUpVer) <$> upstreamReleaseVersion + Just gi -> + if giBranch gi /= "main" + then return . Left . OnDevelopmentBranch $ giBranch gi + else (>>= getUpVer) <$> upstreamReleaseVersion + getUpVer :: String -> Either NewReleaseFailure String + getUpVer upTag = + let upVer = tagToVersion upTag + in if normalize myVer >= normalize upVer + then Left $ OldUpstreamRelease upVer myVer + else Right upTag + errToPair :: NewReleaseFailure -> (Severity, Text) + errToPair e = (toSev e, T.pack $ show e) + toSev :: NewReleaseFailure -> Severity + toSev = \case + FailedReleaseQuery {} -> Error + NoMainUpstreamRelease {} -> Warning + OnDevelopmentBranch {} -> Info + OldUpstreamRelease {} -> Warning diff --git a/app/scene/Main.hs b/app/scene/Main.hs --- a/app/scene/Main.hs +++ b/app/scene/Main.hs @@ -6,7 +6,7 @@ import Options.Applicative import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..)) -import Swarm.Game.World.Render (FailureMode (..), OuputFormat (..), RenderOpts (..), doRenderCmd) +import Swarm.Game.World.Render (FailureMode (..), OuputFormat (..), RenderComputationContext (..), RenderOpts (..), doRenderCmd) data CLI = RenderMap FilePath RenderOpts @@ -20,12 +20,16 @@ <$> option auto (metavar "WIDTH" <> short 'w' <> long "width" <> help "width of source grid") <*> option auto (metavar "HEIGHT" <> short 'h' <> long "height" <> help "height of source grid") + renderComputationOpts = + RenderComputationContext + <$> seed + <*> optional sizeOpts + subOpts = RenderOpts - <$> seed + <$> renderComputationOpts <*> flag ConsoleText PngImage (long "png" <> help "Render to PNG") <*> option str (long "dest" <> short 'd' <> value "output.png" <> help "Output filepath") - <*> optional sizeOpts <*> flag Terminate RenderBlankImage (long "fail-blank" <> short 'b' <> help "Render blank image upon failure") seed :: Parser (Maybe Int) diff --git a/data/entities.yaml b/data/entities.yaml --- a/data/entities.yaml +++ b/data/entities.yaml @@ -69,7 +69,7 @@ char: '■' description: - A flat material made of pressed and dried wood fibers, used as a surface on which to inscribe symbols. - properties: [pickable, combustible] + properties: [pickable, combustible, printable] combustion: ignition: 0.5 duration: [10, 20] @@ -103,7 +103,7 @@ description: - A medium-sized rock... that looks a little different. It seems to react to iron and surprisingly also to naturally growing bits. properties: [pickable] - capabilities: [negation] + capabilities: [not] - name: beaglepuss display: attr: rubber @@ -330,6 +330,49 @@ ignition: 0.1 duration: [20, 40] product: ash +- name: wheat + display: + char: 'w' + attr: gold + description: + - Edible grain + properties: [pickable, growable] + growth: + duration: [20, 30] + spread: + radius: 2 + density: 0.3 + biomes: [dirt, clay] +- name: millstone + display: + char: 'm' + attr: rock + description: + - Grinds grain + properties: [pickable] +- name: flour + display: + char: 'f' + attr: snow + description: + - Edible, ground wheat + properties: [pickable] +- name: parsley + display: + attr: plant + char: 'p' + description: + - A fast-growing plant with a pungent aroma, often found growing near rocks. + - | + When equipped as a device, parsley enables the `read` command, which can be used to turn text into values: + ``` + read : Type -> Text -> a + ``` + If the given `Text`{=type} represents a value of the given `Type`{=type} (written using `@`{=snippet} syntax), the value will be returned; otherwise, an exception is thrown. For example, `(read @Int "3") == 3`, but `read @Int "hello"` crashes. + - Note that `read`, unlike `format`, is unable to deal with function, delay, or command types. + properties: [pickable, growable] + capabilities: [read] + growth: [10, 100] - name: linotype display: attr: silver @@ -361,7 +404,7 @@ in "Number of widgets: " ++ format numWidgets ``` properties: [pickable] - capabilities: [concat] + capabilities: ["++"] - name: caliper display: attr: silver @@ -374,7 +417,7 @@ ``` computes the number of characters in a `Text`{=type} value. properties: [pickable] - capabilities: [charcount] + capabilities: [chars] - name: wedge display: attr: silver @@ -416,7 +459,7 @@ `split : Int -> Text -> Text * Text` splits a `Text`{=type} value into two pieces, one before the given index and one after. properties: [pickable] - capabilities: [format, concat, charcount, split] + capabilities: [format, '++', chars, split] - name: decoder ring display: attr: silver @@ -433,7 +476,7 @@ `toChar : Int -> Text` creates a singleton (length-1) `Text`{=type} value containing a character with the given numeric code. properties: [pickable] - capabilities: [code] + capabilities: [charat, tochar] - name: lambda display: attr: flower @@ -462,14 +505,14 @@ char: ' ' description: - Liquid dihydrogen monoxide, which seems to be plentiful on this planet. - properties: [pickable, infinite, liquid] + properties: [pickable, infinite, liquid, evanescent] - name: wavy water display: attr: water char: '~' description: - A wavy section of water. The same as normal water, but with more waves. - properties: [pickable, infinite, liquid] + properties: [pickable, infinite, liquid, evanescent] yields: water - name: boat display: @@ -580,15 +623,15 @@ attr: blue char: 'B' description: - - This enables the `structure` and `floorplan` commands to locate and analyze structures placed in the world. + - This enables the `structures` and `floorplan` commands to locate and analyze structures placed in the world. - | - `structure : Text -> Int -> Cmd (Unit + (Int * (Int * Int)))` - - Gets the x, y coordinates of the southwest corner of a constructed structure, by name and index. + `structures : Text -> Cmd (rec l. Unit + (Int * Int) * l)` + - Gets the x, y coordinates of the southwest corner of every constructed structure with a given name. - | `floorplan : Text -> Cmd (Int * Int)` - Gets the dimensions of a structure template. properties: [pickable] - capabilities: [structure] + capabilities: [structures, floorplan] - name: drill bit display: attr: entity @@ -635,76 +678,13 @@ ############################################################ ### Utility ################################################ ############################################################ -- name: upper left corner +- name: wall display: + char: '+' attr: entity - char: '┌' description: - - Upper left corner. - properties: [unwalkable, known] -- name: upper right corner - display: - attr: entity - char: '┐' - description: - - An upper right corner wall. - properties: [unwalkable, known] -- name: lower left corner - display: - attr: entity - char: '└' - description: - - A lower left corner wall. - properties: [unwalkable, known] -- name: lower right corner - display: - attr: entity - char: '┘' - description: - - A lower right corner wall. - properties: [unwalkable, known] -- name: down and horizontal wall - display: - attr: entity - char: '┬' - description: - - A down and horizontal wall. - properties: [unwalkable, known] -- name: up and horizontal wall - display: - attr: entity - char: '┴' - description: - - A up and horizontal wall. - properties: [unwalkable, known] -- name: left and vertical wall - display: - attr: entity - char: '┤' - description: - - A left and vertical wall. - properties: [unwalkable, known] -- name: right and vertical wall - display: - attr: entity - char: '├' - description: - - A right and vertical wall. - properties: [unwalkable, known] -- name: horizontal wall - display: - attr: entity - char: '─' - description: - - A horizontal wall. - properties: [unwalkable, known] -- name: vertical wall - display: - attr: entity - char: '│' - description: - - A vertical wall. - properties: [unwalkable, known] + - A wall + properties: [unwalkable, known, boundary] ############################################################ ### Devices ################################################ ############################################################ @@ -743,7 +723,7 @@ char: '%' description: - Tank treads work like treads, but are large enough to move even heavy robots around. - capabilities: [move, turn, moveheavy] + capabilities: [move, turn, move heavy robot] properties: [pickable] - name: tape drive display: @@ -791,7 +771,7 @@ char: 'B' description: - Allows one to `scout` for other robots - capabilities: [recondir] + capabilities: [scout] properties: [pickable] - name: welder display: @@ -857,8 +837,9 @@ attr: device char: 'Д' description: - - A typewriter is used to inscribe symbols on paper, thus reifying pure, platonic information into a physical form. + - A typewriter is used to inscribe symbols on `paper`{=entity}, thus reifying pure, platonic information into a physical form. properties: [pickable] + capabilities: [print, erase] - name: 3D printer display: attr: device @@ -921,7 +902,7 @@ if (x > 3) {move} {turn right; move} ``` properties: [pickable] - capabilities: [cond] + capabilities: [if, '&&', '||'] - name: detonator display: attr: fire @@ -942,11 +923,20 @@ attr: device char: '$' description: - - "With a scanner device, robots can use the `scan` command to learn about their surroundings. Simply give `scan` a direction in which to scan, and information about the scanned item (if any) will be added to the robot's inventory." - - "A scanner also enables `blocked : Cmd Bool`, which returns a boolean value indicating whether the robot's path is blocked (i.e. whether executing a `move` command would fail); `ishere : Text -> Cmd Bool` for checking whether the current cell contains a particular entity; and `isempty : Cmd Bool` for checking whether the current cell is empty of entities. Note that `ishere` and `isempty` do not detect robots, only entities." - - "Finally, robots can use the `upload` command to copy their accumulated knowledge to another nearby robot; for example, `upload base`." + - | + With a scanner device, robots can use the `scan` command to learn about their surroundings. + Simply give `scan` a direction in which to scan, and information about the scanned item (if any) + will be added to the robot's inventory. + - | + A scanner also enables `blocked : Cmd Bool`, which returns a boolean value indicating whether the robot's path is blocked + (i.e. whether executing a `move` command would fail); `ishere : Text -> Cmd Bool` for checking whether the current cell + contains a particular entity; and `isempty : Cmd Bool` for checking whether the current cell is empty of entities. + Note that `ishere` and `isempty` do not detect robots, only entities." + - | + Finally, robots can use the `upload` command to copy their accumulated knowledge to another nearby robot; + for example, `upload base`." properties: [pickable] - capabilities: [scan, sensefront, sensehere] + capabilities: [scan, blocked, ishere, isempty, upload] - name: olfactometer display: char: 'N' @@ -955,7 +945,7 @@ - | `sniff : Text -> Cmd Int` returns the distance to the nearest specified entity. properties: [pickable] - capabilities: [detectdistance] + capabilities: [sniff] - name: flash memory display: attr: device @@ -975,7 +965,7 @@ - "A mirror enables the `whoami` command, which returns the robot's name as a string." - "It also enables the special `self` variable, which gives a robot a reference to itself." properties: [pickable] - capabilities: [whoami] + capabilities: [whoami, self] - name: logger display: attr: device @@ -1019,7 +1009,7 @@ description: - "A calculator allows a robot to do basic arithmetic calculations: addition, subtraction, multiplication, division, and exponentiation." properties: [pickable] - capabilities: [arith] + capabilities: ['+', '-', neg, '*', '/', '^'] - name: ADT calculator display: attr: device @@ -1040,8 +1030,8 @@ if `t`{=type} is a type with three elements, then there are 2 * 3 = 6 different pairs containing a `Bool`{=type} and a `t`{=type}, that is, 6 elements of type `Bool * t`{=type}. For working with products of types, the ADT - calculator enables pair syntax `(1, "Hi!")` as well as the projection - functions `fst : a * b -> a` and `snd : a * b -> b`. + calculator enables pair syntax `(1, "Hi!")` as well as the pair elimination + function `match : a * b -> (a -> b -> c) -> c`. - | The sum of two types is a type with two options; for example, a value of type `Bool + t`{=type} is either a `Bool`{=type} value or a `t`{=type} value, @@ -1052,7 +1042,7 @@ example, `case (inl 3) (\x. 2*x) (\y. 3*y) == 6`, and `case (inr 3) (\x. 2*x) (\y. 3*y) == 9`. properties: [pickable] - capabilities: [arith, sum, prod] + capabilities: ['+', '-', neg, '*', '/', '^', sum, prod] - name: hyperloop display: attr: device @@ -1067,7 +1057,7 @@ `t = T(t)`{=snippet}. For exmple, `rec l. Unit + Int * l`{=type} is the type of lists of integers. properties: [pickable] - capabilities: [arith, sum, prod, rectype] + capabilities: ['+', '-', neg, '*', '/', '^', sum, prod, rectype] - name: compass display: attr: device @@ -1085,7 +1075,7 @@ - | `d <- heading; turn east; move; turn d` properties: [pickable] - capabilities: [orient] + capabilities: [orient, heading] - name: clock display: attr: device @@ -1097,7 +1087,7 @@ - | `wait : Int -> Cmd Unit` causes a robot to sleep for a specified amount of time (measured in game ticks). properties: [pickable] - capabilities: [timeabs, timerel] + capabilities: [time, wait] - name: hourglass display: attr: device @@ -1107,7 +1097,7 @@ - | `wait : Int -> Cmd Unit` causes a robot to sleep for a specified amount of time (measured in game ticks). properties: [pickable] - capabilities: [timerel] + capabilities: [wait] - name: rolex display: char: R @@ -1118,7 +1108,7 @@ `watch : Dir -> Cmd Unit` will mark an adjacent (in the specified direction) location of interest to monitor for placement or removal of items. A subsequent call to `wait` will be interrupted upon a change to the location. properties: [pickable] - capabilities: [timerel, wakeself] + capabilities: [time, wait, watch] - name: comparator display: attr: device @@ -1127,7 +1117,7 @@ - "A comparator allows comparing two values to see whether the first is less, equal, or greater than the second." - "Valid comparison operators are <, <=, >, >=, ==, and !=." properties: [pickable] - capabilities: [compare] + capabilities: ['<', '<=', '>', '>=', '==', '!='] - name: I/O cable display: attr: device @@ -1143,14 +1133,14 @@ - "A rubber band can tie multiple commands together so that other robots can't execute commands in between them. It can be used via the `atomic` command. For example, suppose robot A executes the following code:" - | ``` - b <- ishere "rock"; if b {grab; return ()} {} + b <- ishere "rock"; if b {grab; pure ()} {} ``` - "This seems like a safe way to execute `grab` only when there is a rock to grab. However, it is actually possible for the `grab` to fail, if some other robot B snatches the rock right after robot A sensed it and before robot A got around to grabbing it on the next game tick." - "This will make robot A very sad and it will crash." - "To prevent this situation, robot A can wrap the commands in `atomic`, like so:" - | ``` - atomic (b <- ishere "rock"; if b {grab; return ()} {}) + atomic (b <- ishere "rock"; if b {grab; pure ()} {}) ``` properties: [pickable] capabilities: [atomic] @@ -1186,7 +1176,17 @@ `meetAll : Cmd (rec l. Unit + Actor * l)` returns a list of all the nearby actors other than oneself. properties: [pickable] - capabilities: [meet] + capabilities: [meet, meetAll] +- name: atlas + display: + attr: device + char: 'a' + description: + - | + An atlas enables the `waypoints` command: `waypoints : Text -> (rec l. Unit + (Int * Int) * l)`. + This gets the x, y coordinates of the every waypoint with a given name. + properties: [pickable] + capabilities: [waypoints] - name: GPS receiver display: attr: device @@ -1197,7 +1197,7 @@ some convenient satellite signals, enabling the command `whereami : Cmd (Int * Int)`. properties: [pickable] - capabilities: [senseloc] + capabilities: [whereami] - name: tweezers display: attr: device @@ -1259,7 +1259,7 @@ `key : Text -> Key` constructs values of type `Key`{=type}, for example `key "Down"` or `key "C-S-x"`. properties: [pickable] - capabilities: [handleinput] + capabilities: [key, installKeyHandler] - name: halting oracle display: attr: device diff --git a/data/recipes.yaml b/data/recipes.yaml --- a/data/recipes.yaml +++ b/data/recipes.yaml @@ -106,6 +106,24 @@ - [8, wooden gear] out: - [1, counter] +- in: + - [1, rock] + - [1, wooden gear] + out: + - [1, millstone] +- in: + - [4, wheat] + out: + - [1, flour] + required: + - [1, millstone] +- in: + - [1, flour] + - [1, water] + required: + - [1, furnace] + out: + - [1, Elmer's glue] ######################################### ## STONE ## ######################################### @@ -513,6 +531,15 @@ - [1, iron plate] out: - [1, tweezers] +- in: + - [1, iron plate] + out: + - [1, caliper] +- in: + - [1, paper] + - [1, compass] + out: + - [1, atlas] ## MAGIC - in: - [2, copper wire] @@ -658,6 +685,11 @@ - [1, lens] required: - [1, drill] +- in: + - [2, copper pipe] + - [2, lens] + out: + - [1, binoculars] - in: - [1, glass] - [8, copper wire] diff --git a/data/scenarios/Challenges/00-ORDER.txt b/data/scenarios/Challenges/00-ORDER.txt --- a/data/scenarios/Challenges/00-ORDER.txt +++ b/data/scenarios/Challenges/00-ORDER.txt @@ -16,9 +16,12 @@ gallery.yaml wolf-goat-cabbage.yaml blender.yaml +dna.yaml friend.yaml pack-tetrominoes.yaml dimsum.yaml +telephone.yaml +flower-count.yaml Mazes Ranching Sokoban diff --git a/data/scenarios/Challenges/2048.yaml b/data/scenarios/Challenges/2048.yaml --- a/data/scenarios/Challenges/2048.yaml +++ b/data/scenarios/Challenges/2048.yaml @@ -9,11 +9,11 @@ condition: | try { as base {has "2048"} - } { return false } + } { pure false } solution: | def makeN : Int -> Cmd Unit = \n. if (n == 1) - {harvest; return ()} + {harvest; pure ()} {makeN (n/2); makeN (n/2); make (format n)} end; place "1"; @@ -103,6 +103,12 @@ description: - A 2048. properties: [pickable] + - name: wall + display: + char: '#' + description: + - Unmovable barrier + properties: [known, unwalkable, boundary] recipes: - in: - [2, "1"] @@ -176,14 +182,9 @@ {stone} palette: "Ω": [grass, null, base] - "┌": [stone, upper left corner] - "┐": [stone, upper right corner] - "└": [stone, lower left corner] - "┘": [stone, lower right corner] - "─": [stone, horizontal wall] - "│": [stone, vertical wall] + 'w': [stone, wall] upperleft: [-1, 3] map: | - ┌─┐ - │Ω│ - └─┘ + www + wΩw + www 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 @@ -46,7 +46,7 @@ system: true program: | def until = \c. b <- c; if b {} {until c} end; - until (d <- scan down; return (d == inl ())); + until (d <- scan down; pure (d == inl ())); create "goal" known: [water] entities: 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,7 +46,7 @@ system: true program: | def until = \c. b <- c; if b {} {until c} end; - until (d <- scan down; return (d == inl ())); + until (d <- scan down; pure (d == inl ())); create "goal" entities: - name: wall diff --git a/data/scenarios/Challenges/Mazes/invisible_maze.yaml b/data/scenarios/Challenges/Mazes/invisible_maze.yaml --- a/data/scenarios/Challenges/Mazes/invisible_maze.yaml +++ b/data/scenarios/Challenges/Mazes/invisible_maze.yaml @@ -10,17 +10,17 @@ try { teleport self (27, -17); b <- ishere "goal"; - return (not b) - } { return false } + pure (not b) + } { pure false } solution: | def tL = turn left end; def tR = turn right end; def ifC = \test. \then. \else. b <- test; if b then else end; def forever = \c. c ; forever c end; - def rightBlocked = tR; b <- blocked; tL; return b end; + def rightBlocked = tR; b <- blocked; tL; pure b end; def mazeStep = ifC rightBlocked {ifC blocked {tL} {move}} {tR; move} end; build { - forever (mazeStep; ifC (ishere "goal") {grab; return ()} {}) + forever (mazeStep; ifC (ishere "goal") {grab; pure ()} {}) } robots: - name: base diff --git a/data/scenarios/Challenges/Mazes/loopy_maze.yaml b/data/scenarios/Challenges/Mazes/loopy_maze.yaml --- a/data/scenarios/Challenges/Mazes/loopy_maze.yaml +++ b/data/scenarios/Challenges/Mazes/loopy_maze.yaml @@ -10,8 +10,8 @@ try { teleport self (27, -17); b <- ishere "goal"; - return (not b) - } { return false } + pure (not b) + } { pure false } solution: | run "scenarios/Challenges/Mazes/loopy_maze_sol.sw" robots: diff --git a/data/scenarios/Challenges/Mazes/loopy_maze_sol.sw b/data/scenarios/Challenges/Mazes/loopy_maze_sol.sw --- a/data/scenarios/Challenges/Mazes/loopy_maze_sol.sw +++ b/data/scenarios/Challenges/Mazes/loopy_maze_sol.sw @@ -3,7 +3,7 @@ def tB = turn back end; def ifM = \p.\t.\e. b <- p; if b t e end; def DFS = - ifM (ishere "goal") {grab; return ()} {}; + ifM (ishere "goal") {grab; pure ()} {}; ifM (ishere "rock") {} { place "rock"; tL; b <- blocked; if b {} {move; DFS}; @@ -14,5 +14,5 @@ tB; move; tB end; build { - require 500 "rock"; DFS + stock 500 "rock"; DFS } diff --git a/data/scenarios/Challenges/Ranching/00-ORDER.txt b/data/scenarios/Challenges/Ranching/00-ORDER.txt --- a/data/scenarios/Challenges/Ranching/00-ORDER.txt +++ b/data/scenarios/Challenges/Ranching/00-ORDER.txt @@ -3,3 +3,4 @@ powerset.yaml fishing.yaml gated-paddock.yaml +pied-piper.yaml diff --git a/data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw b/data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw --- a/data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw +++ b/data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw @@ -8,12 +8,13 @@ def elif = \t. \then. \else. {if t then else} end def else = \t. t end -def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); - end; +def λcase = \f. \g. \s. case s f g end +def λmatch = \f. \p. match p f end -def mapTuple = \f. \t. - (f $ fst t, f $ snd t) +def mapTuple = \f. λmatch \a. \b. (f a, f b) end; + +def sumTuples = λmatch \t11. \t12. λmatch \t21. \t22. + (t11 + t21, t12 + t22); end; def negateTuple = \t. @@ -25,9 +26,7 @@ end; // Deprecated -def moveTuple = \tup. - let x = fst tup in - let y = snd tup in +def moveTuple = λmatch \x. \y. turn $ if (x > 0) {east} {west}; doN (abs x) move; @@ -37,7 +36,7 @@ def randomDir = r <- random 4; - return $ if (r == 1) {north} + pure $ if (r == 1) {north} $ elif (r == 2) {west} $ elif (r == 3) {south} $ else {east}; @@ -69,8 +68,7 @@ currLoc <- whereami; let delta = subtractTuple goal currLoc in - let x = fst delta in - let y = snd delta in + match delta \x. \y. moveHorizontal maxDirect x; moveVertical maxDirect y; @@ -117,8 +115,8 @@ }; end; -def goToHive = \hiveLoc. - let depositLoc = (fst hiveLoc - 1, snd hiveLoc) in +def goToHive = λmatch \hivex. \hivey. + let depositLoc = (hivex - 1, hivey) in moveToward 2 depositLoc; turn north; depositHoneycomb 0; @@ -136,7 +134,7 @@ // another bee gets here first try { harvest; - return (); + pure (); } {}; } { // Include some random motion @@ -152,65 +150,29 @@ } end; -/** -Searches through the existing instances of -a given structure template, starting at a supplied -index. -Either returns the (potentially new) index of the structure -(in the case that more had been built since the last check), -or unit. Re-using the newly found index amortizes the "search" -within the structure list over many ticks to constant time -rather than linear time. -*/ -def findStructureNewIndex = \remainingCount. \structureLoc. \lastIdx. - if (remainingCount > 0) { - foundStructure <- structure "beehive" lastIdx; - case foundStructure (\_. return $ inL ()) (\fs. - if (structureLoc == snd fs) { - return $ inR lastIdx; - } { - findStructureNewIndex (remainingCount - 1) structureLoc $ lastIdx + 1; - } - ); +def workerProgram = \structureLoc. + try {make "honeycomb";} {}; + hasHoneycomb <- has "honeycomb"; + if hasHoneycomb { + goToHive structureLoc; } { - return $ inL (); - } - end; - -def workerProgram = \hiveIdx. \structureLoc. - eitherFoundStructure <- structure "beehive" hiveIdx; - case eitherFoundStructure return (\fs. - let hasSameStructure = structureLoc == snd fs in - if hasSameStructure { - try {make "honeycomb";} {}; - hasHoneycomb <- has "honeycomb"; - if hasHoneycomb { - goToHive structureLoc; - } { - takeStepTowardItem "wildflower"; - return (); - }; - workerProgram hiveIdx structureLoc; - } { - eitherNewIdx <- findStructureNewIndex (fst fs) structureLoc hiveIdx; - case eitherNewIdx - (\_. selfdestruct) - (\newIdx. workerProgram newIdx structureLoc); - } - ); + takeStepTowardItem "wildflower"; + pure (); + }; + workerProgram structureLoc; end; def mkBeeName = \structureLoc. "bee" ++ format structureLoc; end; -def workerProgramInit = \beename. \hiveIdx. \structureLoc. +def workerProgramInit = \beename. \structureLoc. setname beename; appear "B" (inl ()); - workerProgram hiveIdx structureLoc; + workerProgram structureLoc; end; -def createWorkerForStructure = \structureIdx. \fs. +def createWorkerForStructure = \loc. // Build worker bee, assign ID, location create "wax gland"; create "proboscis"; @@ -236,38 +198,35 @@ create "treads"; create "workbench"; - teleport self $ snd fs; - let beename = mkBeeName (snd fs) in + teleport self $ loc; + let beename = mkBeeName loc in build { - require 1 "wax gland"; - workerProgramInit beename structureIdx $ snd fs; + stock 1 "wax gland"; + workerProgramInit beename loc; }; - return (); + pure (); end; -def associateAllHives = \remainingCount. \idx. - if (remainingCount > 0) { - - foundStructure <- structure "beehive" idx; - case foundStructure return (\fs. - let beename = mkBeeName (snd fs) in - try { - // Fails if the robot does not exist - robotnamed beename; - return (); - } { - createWorkerForStructure idx fs; +def associateHive = \loc. + let beename = mkBeeName loc in + try { + // Fails if the robot does not exist + robotnamed beename; + pure (); + } { + createWorkerForStructure loc; - // Give the child robot time to register its new - // name so that we don't end up spawning multiple - // bees for the same location - wait 1; - }; + // Give the child robot time to register its new + // name so that we don't end up spawning multiple + // bees for the same location + wait 1; + }; + end; - associateAllHives (remainingCount - 1) (idx + 1); - ); - } {} - end; +def mapM_ : (a -> Cmd b) -> (rec l. Unit + a * l) -> Cmd Unit = \f. λcase + (\_. pure ()) + (λmatch \hd. \tl. f hd; mapM_ f tl) + end; /** Each tick, iterates through all hives, @@ -278,12 +237,8 @@ */ def observeHives = - // This invocation is just to get the total structure count. - // We will invoke it again once per iteration of 'associateAllHives'. - foundStructure <- structure "beehive" 0; - case foundStructure return (\fs. - associateAllHives (fst fs) 0; - ); + beehives <- structures "beehive"; + mapM_ associateHive beehives; // Wait at least 1 tick so that we do not spin infinitely until // we saturate our computation quota for the tick. diff --git a/data/scenarios/Challenges/Ranching/_beekeeping/solution.sw b/data/scenarios/Challenges/Ranching/_beekeeping/solution.sw --- a/data/scenarios/Challenges/Ranching/_beekeeping/solution.sw +++ b/data/scenarios/Challenges/Ranching/_beekeeping/solution.sw @@ -11,12 +11,13 @@ def abs = \n. if (n < 0) {-n} {n} end; -def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); - end; +def λcase = \f. \g. \s. case s f g end +def λmatch = \f. \p. match p f end -def mapTuple = \f. \t. - (f $ fst t, f $ snd t) +def mapTuple = \f. λmatch \a. \b. (f a, f b) end; + +def sumTuples = λmatch \t11. \t12. λmatch \t21. \t22. + (t11 + t21, t12 + t22); end; def negateTuple = \t. @@ -27,9 +28,7 @@ sumTuples t1 $ negateTuple t2; end; -def moveTuple = \tup. - let x = fst tup in - let y = snd tup in +def moveTuple = λmatch \x. \y. turn $ if (x > 0) {east} {west}; doN (abs x) move; @@ -113,14 +112,14 @@ collectContiguous maxdist item true $ dist + 1; } { if hadFound { - return dist; + pure dist; } { move; collectContiguous maxdist item false $ dist + 1; } } } { - return dist; + pure dist; } end; @@ -148,7 +147,7 @@ collectAllHoneycombs targetCount; } { - return currentCount; + pure currentCount; }; end; @@ -176,7 +175,7 @@ isRock <- ishere "rock"; if isRock { grab; - return (); + pure (); } {}; end; @@ -274,7 +273,7 @@ make "solar panel"; build { - require 8 "tree"; + stock 8 "tree"; buildHive; // Move to northwest corner diff --git a/data/scenarios/Challenges/Ranching/_capture/opponent.sw b/data/scenarios/Challenges/Ranching/_capture/opponent.sw --- a/data/scenarios/Challenges/Ranching/_capture/opponent.sw +++ b/data/scenarios/Challenges/Ranching/_capture/opponent.sw @@ -41,9 +41,9 @@ isBlocked <- blocked; turn left; lastCount <- countBlocked $ n - 1; - return $ lastCount + boolToInt isBlocked; + pure $ lastCount + boolToInt isBlocked; } { - return 0; + pure 0; } end; @@ -54,13 +54,15 @@ def locationIsOpen = emptyHere <- isempty; blockedCount <- countBlocked 4; - return $ emptyHere && blockedCount == 0; + pure $ emptyHere && blockedCount == 0; end; def faceAwayFrom = \loc. + match loc \locx. \locy. myLoc <- whereami; - let x = fst loc - fst myLoc in - let y = snd loc - snd myLoc in + match myLoc \myx. \myy. + let x = locx - myx in + let y = locy - myy in let d = if (abs x > abs y) { if (x > 0) {west} {east} } { @@ -84,7 +86,7 @@ findOpenArea; try { swap marker; - return (); + pure (); } { place marker; }; diff --git a/data/scenarios/Challenges/Ranching/_fishing/hauler.sw b/data/scenarios/Challenges/Ranching/_fishing/hauler.sw --- a/data/scenarios/Challenges/Ranching/_fishing/hauler.sw +++ b/data/scenarios/Challenges/Ranching/_fishing/hauler.sw @@ -9,35 +9,38 @@ } {}; end; -def isEnclosureFull = \idx. - foundBox <- structure "rubbish enclosure" idx; - case foundBox (\_. return false) (\enclosure. - let boxPos = snd enclosure in - - prevLoc <- whereami; +def isEnclosureFull : Int * Int -> Cmd Bool = \encl. + prevLoc <- whereami; - dims <- floorplan "rubbish enclosure"; - teleport self boxPos; + dims <- floorplan "rubbish enclosure"; + teleport self encl; - c <- density ((0, 0), dims); - let area = fst dims * snd dims in - let notFull = c < area in + c <- density ((0, 0), dims); + match dims \w. \h. + let area = w * h in + let notFull = c < area in - teleport self prevLoc; - return $ not notFull; - ); + teleport self prevLoc; + pure $ not notFull; end; +def λcase = \f. \g. \s. case s f g end +def λmatch = \f. \p. match p f end + +def any : (a -> Cmd Bool) -> (rec l. Unit + a * l) -> Cmd Bool = \p. λcase + (\_. pure false) + (λmatch \hd. \tl. b <- p hd; if b {pure true} {any p tl}) +end; + def isEitherEnclosureFull = - full1 <- isEnclosureFull 0; - full2 <- isEnclosureFull 1; - return $ full1 || full2; + enclosures <- structures "rubbish enclosure"; + any isEnclosureFull enclosures end; def tryGrab = try { grab; - return () + pure () } {}; end; diff --git a/data/scenarios/Challenges/Ranching/_fishing/solution.sw b/data/scenarios/Challenges/Ranching/_fishing/solution.sw --- a/data/scenarios/Challenges/Ranching/_fishing/solution.sw +++ b/data/scenarios/Challenges/Ranching/_fishing/solution.sw @@ -17,7 +17,7 @@ def checkIngredients = hasTuna <- has "crab"; hasSeaweed <- has "seaweed"; - return $ hasTuna && hasSeaweed; + pure $ hasTuna && hasSeaweed; end; def catchFish = \rod. @@ -39,9 +39,9 @@ At the top-right corner */ def harvestRectangle = - intersperse 4 move $ harvest; return (); + intersperse 4 move $ harvest; pure (); turnAround left; - intersperse 4 move $ harvest; return (); + intersperse 4 move $ harvest; pure (); end; def harvestIngredients = @@ -62,23 +62,13 @@ move; end; -def getJunkItem = \idx. - result <- tagmembers "junk" idx; - let totalCount = fst result in - let member = snd result in - let nextIdx = idx + 1 in +def λcase = \f. \g. \s. case s f g end +def λmatch = \f. \p. match p f end - hasProhibited <- has member; - if hasProhibited { - return $ inr member; - } { - if (nextIdx < totalCount) { - getJunkItem nextIdx; - } { - return $ inl (); - } - } - end; +def find : (a -> Cmd Bool) -> (rec l. Unit + a * l) -> Cmd (Unit + a) = \p. λcase + (\_. pure (inl ())) + (λmatch \hd. \tl. h <- p hd; if h {pure $ inr hd} {find p tl}) +end def tryPlace = \item. try { @@ -120,7 +110,7 @@ end; -def returnToCorner = +def pureToCorner = turn back; move; move; turn right; @@ -131,7 +121,7 @@ def unloadTrash = try { placeSerpentine ( - item <- getJunkItem 0; + item <- find has (tagmembers "junk"); case item (\_. fail "done") (\item. place item); ); watch down; @@ -155,7 +145,7 @@ intersperse 2 move $ ( placeSerpentine $ tryPlace "car tire"; - returnToCorner; + pureToCorner; ignite forward; turn right; diff --git a/data/scenarios/Challenges/Ranching/_gated-paddock/enclosure-checking.sw b/data/scenarios/Challenges/Ranching/_gated-paddock/enclosure-checking.sw --- a/data/scenarios/Challenges/Ranching/_gated-paddock/enclosure-checking.sw +++ b/data/scenarios/Challenges/Ranching/_gated-paddock/enclosure-checking.sw @@ -1,14 +1,14 @@ def isBlockedOrFenced = b <- blocked; - return b; + pure b; end; def checkIsEnclosed = maybePath <- path (inL ()) (inR "water"); - case maybePath (\_. return True) (\_. return False); + case maybePath (\_. pure True) (\_. pure False); end; -def boolToInt = \b. if (b) {return 1} {return 0}; end; +def boolToInt = \b. if (b) {pure 1} {pure 0}; end; def countAdjacentBlockages = @@ -28,7 +28,7 @@ b4 <- isBlockedOrFenced; c4 <- boolToInt b4; - return $ c1 + c2 + c3 + c4; + pure $ c1 + c2 + c3 + c4; end; // Step forward, observing left and right. @@ -44,7 +44,7 @@ turn right; move; - return $ val1 + val2; + pure $ val1 + val2; end; @@ -65,7 +65,7 @@ // Second, step to both sides fwdCount <- observeLeftAndRight; backCount <- observeLeftAndRight; - return $ fwdCount + backCount; + pure $ fwdCount + backCount; end; def isStandingOnBridge = @@ -74,12 +74,12 @@ if (onFence || onGate) { adjCount <- countAdjacentBlockages; if (adjCount > 1) { - return true; + pure true; } { diagCount <- countDiagonalBlockages; - return $ (adjCount + diagCount) > 1; + pure $ (adjCount + diagCount) > 1; }; - } {return false}; + } {pure false}; end; def getValForSheepIndex = \predicateCmd. \i. @@ -91,7 +91,7 @@ boolToInt didSucceed; } { - return 0; + pure 0; } end; @@ -99,7 +99,7 @@ val1 <- getValForSheepIndex predicateCmd 1; val2 <- getValForSheepIndex predicateCmd 2; val3 <- getValForSheepIndex predicateCmd 3; - return $ val1 + val2 + val3; + pure $ val1 + val2 + val3; end; justFilledGap <- as base { @@ -108,7 +108,7 @@ if (justFilledGap) { enclosedCount <- countSheepWith checkIsEnclosed; - return $ enclosedCount >= 1; + pure $ enclosedCount >= 1; } { - return false; + pure false; } diff --git a/data/scenarios/Challenges/Ranching/_gated-paddock/fence-construction.sw b/data/scenarios/Challenges/Ranching/_gated-paddock/fence-construction.sw --- a/data/scenarios/Challenges/Ranching/_gated-paddock/fence-construction.sw +++ b/data/scenarios/Challenges/Ranching/_gated-paddock/fence-construction.sw @@ -54,10 +54,10 @@ def harvestIfClover = x <- scan down; - case x return (\y. + case x pure (\y. if (y == "clover") { harvest; - return (); + pure (); } {}; ); end; @@ -125,11 +125,11 @@ turn right; wait 200; - plantCloverColumn right $ return (); - plantCloverColumn left $ return (); - plantCloverColumn right $ return (); - plantCloverColumn left $ return (); - plantCloverColumn right $ return (); + plantCloverColumn right $ pure (); + plantCloverColumn left $ pure (); + plantCloverColumn right $ pure (); + plantCloverColumn left $ pure (); + plantCloverColumn right $ pure (); end; @@ -164,10 +164,10 @@ def pickupWool = x <- scan down; - case x return (\y. + case x pure (\y. if (y == "wool") { grab; - return (); + pure (); } {}; ); end; diff --git a/data/scenarios/Challenges/Ranching/_gated-paddock/meandering-sheep.sw b/data/scenarios/Challenges/Ranching/_gated-paddock/meandering-sheep.sw --- a/data/scenarios/Challenges/Ranching/_gated-paddock/meandering-sheep.sw +++ b/data/scenarios/Challenges/Ranching/_gated-paddock/meandering-sheep.sw @@ -5,12 +5,12 @@ def turnToClover = \direction. x <- scan direction; - case x (\_. return false;) (\y. + case x (\_. pure false;) (\y. if (y == "clover") { turn direction; - return true; + pure true; } { - return false; + pure false; }; ); end; @@ -23,11 +23,11 @@ def turnCloverDirection = foundN <- turnToClover north; - if (foundN) {return true} { + if (foundN) {pure true} { foundE <- turnToClover east; - if (foundE) {return true} { + if (foundE) {pure true} { foundS <- turnToClover south; - if (foundS) {return true} { + if (foundS) {pure true} { turnToClover west; } } @@ -38,7 +38,7 @@ let randdir : Cmd Dir = d <- random 4; - return $ if (d == 0) { + pure $ if (d == 0) { north } $ elif (d == 1) { east @@ -90,7 +90,7 @@ // Eat clover. x <- scan down; - case x return (\y. + case x pure (\y. if (y == "clover") { harvest; cloverCount <- count "clover"; @@ -113,9 +113,9 @@ // Make sure nothing's in the way before we place // our wool: x <- scan down; - case x return (\_. + case x pure (\_. grab; - return (); + pure (); ); place item; diff --git a/data/scenarios/Challenges/Ranching/_pied-piper/rat.sw b/data/scenarios/Challenges/Ranching/_pied-piper/rat.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/_pied-piper/rat.sw @@ -0,0 +1,107 @@ +def moveWithMorbidity = + moldHere <- ishere "mold"; + if moldHere { + try { + // handle race conditions in which + // another robot grabs it first + m <- harvest; + let spores = "mold spores" in + if (m == spores) { + say $ "Yuck, " ++ spores ++ "! I'm outta here."; + selfdestruct; + } {}; + } {}; + } {}; + move; + end; + +def λmatch = \f. \p. match p f end + +def goFoodDir = \f. λmatch \d. \_. + if (d == down) { + foodHere <- ishere "oats"; + if foodHere { + grab; pure () + } {}; + f; + pure () + } { + turn d; + + // An obstruction might arise after + // navigation direction is determined + // but before we move. + try { + moveWithMorbidity; + } {}; + f; + } + end; + +def goHomeDir = \f. λmatch \d. \_. + if (d == down) { + pure () + } { + turn d; + + // An obstruction might arise after + // navigation direction is determined + // but before we move. + try { + moveWithMorbidity; + } {}; + f; + } + end; + +def findGoodDirection = + isBlocked <- blocked; + if isBlocked { + turn left; + findGoodDirection; + } {}; + end; + +def moveUntilBlocked = + isBlocked <- blocked; + if isBlocked { + } { + moveWithMorbidity; + moveUntilBlocked; + }; + end; + +def pauseAtRandom = + r <- random 3; + if (r == 0) { + r2 <- random 12; + wait $ 6 + r2; + } {} + end; + +def returnHome = \homeLoc. + nextDir <- path (inL ()) (inL homeLoc); + case nextDir pure $ goHomeDir $ returnHome homeLoc; + end; + +def pursueFood = \hadSensedFood. \homeLoc. + nextDir <- path (inR 5) (inR "oats"); + case nextDir (\_. if hadSensedFood {returnHome homeLoc} {pure ()}) $ + goFoodDir $ pursueFood true homeLoc; + end; + +def doMovement = \startLoc. + findGoodDirection; + moveUntilBlocked; + pauseAtRandom; + pursueFood false startLoc; + end; + +/** Loop */ +def go = \startLoc. + doMovement startLoc; + go startLoc; + end; + +startLoc <- whereami; +go startLoc; diff --git a/data/scenarios/Challenges/Ranching/_pied-piper/solution.sw b/data/scenarios/Challenges/Ranching/_pied-piper/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/_pied-piper/solution.sw @@ -0,0 +1,191 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + +def intersperse = \n. \f2. \f1. if (n > 0) { + f1; + if (n > 1) { + f2; + } {}; + intersperse (n - 1) f2 f1; + } {}; + end; + +def uTurn = \d. + turn d; + move; + turn d; + end; + +/** +Starting at bottom right of field +*/ +def harvestField = \fieldWidth. + intersperse fieldWidth move harvest; + uTurn right; + intersperse fieldWidth move harvest; + uTurn left; + intersperse fieldWidth move harvest; + uTurn right; + intersperse fieldWidth move harvest; + end; + +def makeOatsCrumb = \spacing. + place "oats"; + doN spacing move; + end; + +def waitUntilRatDisappeared = + found <- scout east; + if found { + wait 1; + waitUntilRatDisappeared; + } {}; + end; + +/** +Place a trail of breadcrumbs, and return +one crumb short of the first crumb. +*/ +def makeOatsTrail = \spacing. \segments. + doN segments $ makeOatsCrumb spacing; + turn back; + doN (segments * spacing) move; + turn back; + end; + +def placeHorizontalTrail = \horizontalSpacing. + turn east; + doN (2*horizontalSpacing) move; + place "oats"; + turn back; + doN horizontalSpacing move; + place "oats"; + doN horizontalSpacing move; + turn left; + end; + +def waitForRatToPass = + + // Wait until the rat ate this crumb + watch down; + wait 2000; + waitUntilRatDisappeared; + end; + +def makeTrails = + let spacing = 4 in + let segments = 5 in + + wait 30; + placeHorizontalTrail 5; + makeOatsTrail spacing $ segments + 1; + end; + +def getKey = + turn east; + doN 15 move; + turn right; + move; + _k <- grab; + turn right; + doN 5 move; + turn right; + doN 6 move; + turn left; + doN 18 move; + turn left; + doN 20 move; + turn right; + doN 2 move; + use "unlocker" forward; + doN 6 move; + turn right; + doN 8 move; + turn left; + move; + turn right; + doN 6 move; + turn left; + move; + end; + +def placeMold = \moldItem. + turn east; + doN 11 move; + sow moldItem; + end; + +def go = + getKey; + harvestField 20; + + turn left; + doN 2 move; + turn left; + harvestField 20; + + + move; + turn right; + doN 14 move; + turn left; + + // Get the mold + doN 4 move; + turn left; + doN 3 move; + moldItem <- grab; + turn back; + doN 3 move; + + turn right; + doN 3 move; + turn left; + + // Head back to the house + doN 8 move; + turn left; + doN 8 move; + turn left; + + // Start laying trail + intersperse 5 (doN 4 move) $ place "oats"; + placeHorizontalTrail 5; + + waitForRatToPass; + + makeTrails; + waitForRatToPass; + + + makeOatsTrail 4 10; + placeHorizontalTrail 5; + waitForRatToPass; + + makeOatsTrail 4 12; + placeHorizontalTrail 5; + waitForRatToPass; + + turn east; + doN 2 move; + + placeHorizontalTrail 4; + makeOatsTrail 4 4; + waitForRatToPass; + + makeOatsTrail 4 6; + placeHorizontalTrail 4; + + waitForRatToPass; + makeOatsTrail 4 10; + placeHorizontalTrail 4; + + + waitForRatToPass; + makeOatsTrail 4 12; + placeHorizontalTrail 4; + + placeMold moldItem; + end; + +go; diff --git a/data/scenarios/Challenges/Ranching/_powerset/setup.sw b/data/scenarios/Challenges/Ranching/_powerset/setup.sw --- a/data/scenarios/Challenges/Ranching/_powerset/setup.sw +++ b/data/scenarios/Challenges/Ranching/_powerset/setup.sw @@ -9,7 +9,7 @@ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; def until = \p. \c. q <- p; if q {} {c; until p c} end; -def while = \p. until (x <- p; return $ not x) end; +def while = \p. until (x <- p; pure $ not x) end; def isDivisibleBy = \dividend. \divisor. (dividend / divisor) * divisor == dividend; @@ -67,7 +67,7 @@ teleport self newLoc; retval <- f; teleport self prevLoc; - return retval; + pure retval; end; def placeSand = @@ -86,7 +86,7 @@ if (isBitSet bitmask nextRandomVal) { getUnusedRandom maxval bitmask; } { - return nextRandomVal; + pure nextRandomVal; } end; @@ -140,7 +140,7 @@ nextRandomVal <- getUnusedRandom maxval bitmask; let newBitmask = bitmask + shiftLeft 1 nextRandomVal in naiveRandomStack valueFunc maxval newBitmask $ n - 1; - return nextRandomVal; + pure nextRandomVal; } { // We're at the peak of the stack. // Now we unwind it. @@ -148,7 +148,7 @@ // Saves some time in generating the last number by inferring the // only remaining possible choice. let missingBit = getMissingBit bitmask maxval in - return missingBit; + pure missingBit; }; valueFunc val; end; @@ -170,7 +170,8 @@ if (x != 0 && x != exclusionValue && not (exactlyOneBit false x)) { naiveRandomStack (placeEntsForBits x) inputCardinality 0 inputCardinality; myloc <- whereami; - teleport self (fst myloc + 1, 0); + match myloc \x. \_. + teleport self (x + 1, 0); } {}; end; @@ -193,7 +194,7 @@ if (exactlyOneBit false value) { chooseExclusionValue powersetCardinality; } { - return value; + pure value; } end; @@ -208,7 +209,7 @@ move; exclusionValue <- chooseExclusionValue powersetCardinality; naiveRandomStack (columnFunc exclusionValue inputCardinality) powersetCardinality 0 powersetCardinality; - return exclusionValue; + pure exclusionValue; end; /** @@ -220,7 +221,7 @@ def checkSolutionSum = \runningSum. maybeItem <- scan down; - case maybeItem (\_. return runningSum) (\item. + case maybeItem (\_. pure runningSum) (\item. // The bell is the only other item we can place in this // scenario besides the fruits. if (item != "bell") { @@ -228,7 +229,7 @@ let binaryValue = shiftLeft 1 $ theOrdinal - 1 in move; checkSolutionSum $ binaryValue + runningSum; - } {return runningSum}; + } {pure runningSum}; ); end; diff --git a/data/scenarios/Challenges/Ranching/_powerset/solution.sw b/data/scenarios/Challenges/Ranching/_powerset/solution.sw --- a/data/scenarios/Challenges/Ranching/_powerset/solution.sw +++ b/data/scenarios/Challenges/Ranching/_powerset/solution.sw @@ -1,6 +1,6 @@ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; def until = \p. \c. q <- p; if q {} {c; until p c} end; -def while = \p. until (x <- p; return $ not x) end; +def while = \p. until (x <- p; pure $ not x) end; def abs = \n. if (n < 0) {-n} {n} end; @@ -14,12 +14,13 @@ } {}; end; -def mapTuple = \f. \t. - (f $ fst t, f $ snd t) - end; +def λcase = \f. \g. \s. case s f g end +def λmatch = \f. \p. match p f end -def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); +def mapTuple = \f. λmatch \a. \b. (f a, f b) end; + +def sumTuples = λmatch \t11. \t12. λmatch \t21. \t22. + (t11 + t21, t12 + t22); end; def negateTuple = \t. @@ -28,7 +29,7 @@ def getRelativeLocation = \absCurrentLoc. \absDestLoc. let negatedLoc = negateTuple absCurrentLoc in - return $ sumTuples negatedLoc absDestLoc; + pure $ sumTuples negatedLoc absDestLoc; end; def splitStride = \n. @@ -41,9 +42,7 @@ } end; -def moveTuple = \tup. - let x = fst tup in - let y = snd tup in +def moveTuple = λmatch \x. \y. turn $ if (x > 0) {east} {west}; // doN (abs x) move; splitStride x; @@ -73,7 +72,7 @@ def tryHarvest = \stashLoc. maybeItem <- scan down; - case maybeItem return (\item. + case maybeItem pure (\item. hasSome <- has item; harvest; if hasSome {} { @@ -105,7 +104,7 @@ if emptyhere { turn back; splitStride tally; - return tally; + pure tally; } { move; countLine $ tally + 1; @@ -114,7 +113,8 @@ def placeFinalCopy = \item. originalLoc <- whereami; - goToLocation originalLoc (fst originalLoc, 0); + match originalLoc \x. \_. + goToLocation originalLoc (x, 0); until isempty move; place item; newLoc <- whereami; @@ -123,7 +123,7 @@ def copyIfNeeded = \targetCount. maybeItem <- scan down; - case maybeItem return (\item. + case maybeItem pure (\item. quantity <- count item; if (quantity < targetCount) { placeFinalCopy item; diff --git a/data/scenarios/Challenges/Ranching/beekeeping.yaml b/data/scenarios/Challenges/Ranching/beekeeping.yaml --- a/data/scenarios/Challenges/Ranching/beekeeping.yaml +++ b/data/scenarios/Challenges/Ranching/beekeeping.yaml @@ -32,8 +32,8 @@ judicious placement is essential for efficient `honeycomb`{=entity} production. condition: | - foundStructure <- structure "beehive" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "beehive"; + pure $ case foundStructure (\_. false) (\_. true); - teaser: Collect honeycomb goal: - | @@ -67,7 +67,7 @@ condition: | as base { meadCount <- count "mead"; - return $ meadCount >= 2; + pure $ meadCount >= 2; } - teaser: Tavern keeper optional: true @@ -75,8 +75,8 @@ - | Construct a `mead hall`{=structure}. condition: | - foundStructure <- structure "mead hall" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "mead hall"; + pure $ case foundStructure (\_. false) (\_. true); robots: - name: base display: @@ -193,7 +193,7 @@ description: - Senses direction to nectar-producing flowers properties: [known, pickable] - capabilities: [detectdirection, structure] + capabilities: [chirp, structures] - name: honey display: char: 'h' @@ -439,7 +439,6 @@ , mask lakes {lakewater} ] upperleft: [0, 0] - offset: false palette: 'B': [grass, erase, base] 'Q': [grass, erase, queenbee] diff --git a/data/scenarios/Challenges/Ranching/capture.yaml b/data/scenarios/Challenges/Ranching/capture.yaml --- a/data/scenarios/Challenges/Ranching/capture.yaml +++ b/data/scenarios/Challenges/Ranching/capture.yaml @@ -25,10 +25,10 @@ turn left; isSurrounded $ n - 1; } { - return false; + pure false; } } { - return true; + pure true; } end; @@ -59,16 +59,16 @@ let localBlockCount = boolToInt isBlocked in turn left; lastCount <- countBlocked $ n - 1; - return $ lastCount + localBlockCount; + pure $ lastCount + localBlockCount; } { - return 0; + pure 0; } end; opponent <- robotnamed "opponent"; as opponent { blockCount <- countBlocked 4; - return $ blockCount > 0 && blockCount < 4; + pure $ blockCount > 0 && blockCount < 4; }; robots: - name: base @@ -143,7 +143,6 @@ dsl: | {grass} upperleft: [0, 0] - offset: false palette: 'B': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Challenges/Ranching/fishing.yaml b/data/scenarios/Challenges/Ranching/fishing.yaml --- a/data/scenarios/Challenges/Ranching/fishing.yaml +++ b/data/scenarios/Challenges/Ranching/fishing.yaml @@ -29,7 +29,7 @@ condition: | as base { rollCount <- count "california roll"; - return $ rollCount >= 16; + pure $ rollCount >= 16; } prerequisite: made_sushi - teaser: Sushi chef @@ -59,26 +59,14 @@ Otherwise, when the enclosure becomes full, the trash hauler will come to empty it. condition: | - // Returns true if prohibited item is in inventory. - def checkProhibited = \idx. - result <- tagmembers "junk" idx; - let totalCount = fst result in - let member = snd result in - let nextIdx = idx + 1 in - - hasProhibited <- as base {has member}; - if hasProhibited { - return false; - } { - if (nextIdx < totalCount) { - checkProhibited nextIdx; - } { - return true; - } - } - end; + def hasAny : (rec l. Unit + Text * l) -> Cmd Bool = \items. + case items + (\_. pure false) + (\c. match c \hd. \tl. b <- has hd; if b {pure true} {hasAny tl}) + end; - checkProhibited 0; + let prohibited = tagmembers "junk" in + h <- hasAny prohibited; pure (not h) - teaser: No littering id: littered hidden: true @@ -89,35 +77,41 @@ - | Note that certain items can be burned with a `torch`{=entity} to make room. condition: | - def locIsInsideEnclosure = \loc. \dims. \idx. - foundBox <- structure "rubbish enclosure" idx; - case foundBox (\_. return false) (\enclosure. - let boxPos = snd enclosure in - return $ snd loc >= snd boxPos - && snd loc < snd dims + snd boxPos - && fst loc >= fst boxPos - && fst loc < fst dims + fst boxPos; - ); + def λmatch = \f. \p. match p f end + def λcase = \f. \g. \s. case s f g end + + def locIsInsideEnclosure = + λmatch \locx. \locy. + λmatch \dimx. \dimy. + λmatch \boxx. \boxy. + pure $ locy >= boxy + && locy < dimy + boxy + && locx >= boxx + && locx < dimx + boxx; end; def junkOutsideEnclosure = result <- scan down; - case result (\_. return false) (\item. - isJunk <- hastag item "junk"; + case result (\_. pure false) (\item. + let isJunk = hastag item "junk" in if isJunk { - foundBox <- structure "rubbish enclosure" 0; + enclosures <- structures "rubbish enclosure"; - case foundBox (\_. return false) (\enclosure. + case enclosures (\_. pure false) ( + λmatch \enclosure0. + λcase (\_. pure false) ( + λmatch \enclosure1. \_. - dims <- floorplan "rubbish enclosure"; - loc <- whereami; + dims <- floorplan "rubbish enclosure"; + loc <- whereami; - insideFirst <- locIsInsideEnclosure loc dims 0; - insideSecond <- locIsInsideEnclosure loc dims 1; - return $ not $ insideFirst || insideSecond; - ); + insideFirst <- locIsInsideEnclosure loc dims enclosure0; + insideSecond <- locIsInsideEnclosure loc dims enclosure1; + pure $ not $ insideFirst || insideSecond; + ) + ) } { - return false; + pure false; }; ); end; @@ -208,13 +202,11 @@ description: - | Can tell you if something is `junk`{=tag} - via the `hastag` command. E.g.: + via the `hastag` function. E.g.: - | `hastag "car tire" "junk"` - | - Also allows you to iterate over the list of junk, e.g.: - - | - `tagmembers "junk" 0` + Also allows you to get the list of all junk items with `tagmembers "junk"`. capabilities: [hastag, tagmembers] - name: torch display: @@ -507,16 +499,10 @@ dsl: | {grass} upperleft: [0, 0] - placements: - - src: rubbish enclosure - offset: [19, -10] - - src: rubbish enclosure - offset: [19, -14] - orient: - up: south palette: 'B': [grass, erase, base] '.': [grass] + 'x': [blank] 'w': [grass, lakewater] 's': [grass, lakewater, shark] 'A': [grass, avocado] @@ -524,6 +510,16 @@ 'c': [grass, cucumber] 'r': [dirt, erase] 'h': [dirt, erase, hauler] + 'e': + structure: + name: rubbish enclosure + cell: [grass] + 'f': + structure: + name: rubbish enclosure + orientation: + up: south + cell: [grass] map: | .........................h. .........................r. @@ -535,10 +531,10 @@ .........wwwwwwww........r. cccc.......wwww..........r. cccc.....................r. - .........................r. - .........................r. - .........................r. + ...................exxxx.r. + ...................xxxxx.r. + ...................xxxxx.r. ....................rrrrrr. - ........................... - ........................... - ........................... + ...................fxxxx... + ...................xxxxx... + ...................xxxxx... diff --git a/data/scenarios/Challenges/Ranching/gated-paddock.yaml b/data/scenarios/Challenges/Ranching/gated-paddock.yaml --- a/data/scenarios/Challenges/Ranching/gated-paddock.yaml +++ b/data/scenarios/Challenges/Ranching/gated-paddock.yaml @@ -23,15 +23,15 @@ condition: |- def isBlockedOrFenced = b <- blocked; - return b; + pure b; end; def checkIsEnclosed = maybePath <- path (inL ()) (inR "water"); - case maybePath (\_. return True) (\_. return False); + case maybePath (\_. pure True) (\_. pure False); end; - def boolToInt = \b. if (b) {return 1} {return 0}; end; + def boolToInt = \b. if (b) {pure 1} {pure 0}; end; def countAdjacentBlockages = @@ -51,7 +51,7 @@ b4 <- isBlockedOrFenced; c4 <- boolToInt b4; - return $ c1 + c2 + c3 + c4; + pure $ c1 + c2 + c3 + c4; end; // Step forward, observing left and right. @@ -67,7 +67,7 @@ turn right; move; - return $ val1 + val2; + pure $ val1 + val2; end; @@ -88,7 +88,7 @@ // Second, step to both sides fwdCount <- observeLeftAndRight; backCount <- observeLeftAndRight; - return $ fwdCount + backCount; + pure $ fwdCount + backCount; end; def isStandingOnBridge = @@ -97,12 +97,12 @@ if (onFence || onGate) { adjCount <- countAdjacentBlockages; if (adjCount > 1) { - return true; + pure true; } { diagCount <- countDiagonalBlockages; - return $ (adjCount + diagCount) > 1; + pure $ (adjCount + diagCount) > 1; }; - } {return false}; + } {pure false}; end; def getValForSheepIndex = \predicateCmd. \i. @@ -114,7 +114,7 @@ boolToInt didSucceed; } { - return 0; + pure 0; } end; @@ -122,7 +122,7 @@ val1 <- getValForSheepIndex predicateCmd 1; val2 <- getValForSheepIndex predicateCmd 2; val3 <- getValForSheepIndex predicateCmd 3; - return $ val1 + val2 + val3; + pure $ val1 + val2 + val3; end; justFilledGap <- as base { @@ -131,9 +131,9 @@ if (justFilledGap) { enclosedCount <- countSheepWith checkIsEnclosed; - return $ enclosedCount >= 1; + pure $ enclosedCount >= 1; } { - return false; + pure false; } - id: feed_sheep teaser: Feed sheep @@ -155,7 +155,7 @@ r <- robotnumbered i; as r {predicateCmd}; } { - return false; + pure false; }; end; @@ -164,12 +164,12 @@ if (i > 0) { didSucceed <- getTruthForSheepIndex predicateCmd i; if didSucceed { - return true; + pure true; } { anySheep predicateCmd $ i - 1; }; } { - return false; + pure false; }; end; diff --git a/data/scenarios/Challenges/Ranching/pied-piper.yaml b/data/scenarios/Challenges/Ranching/pied-piper.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/pied-piper.yaml @@ -0,0 +1,463 @@ +version: 1 +name: Infestation +author: Karl Ostmo +description: | + Rid the village of pests. +creative: false +seed: 0 +attrs: + - name: clay + bg: "#313020" + - name: oats + fg: "#444444" + bg: "#F5DEB3" + - name: bridge + bg: "#806040" + - name: brick + bg: "#880000" + - name: mold + fg: "#406020" + bg: "#403020" +terrains: + - name: bridge + attr: bridge + description: | + Wooden raised path + - name: clay + attr: clay + description: | + Damp, sandy soil +robots: + - name: base + loc: + subworld: overworld + loc: [-1, 8] + dir: south + devices: + - ADT calculator + - binoculars + - branch predictor + - comparator + - compass + - counter + - dictionary + - grabber + - harvester + - lambda + - logger + - net + - rolex + - scanner + - seed spreader + - strange loop + - string + - treads + - unlocker + - tweezers + inventory: [] + walkable: + never: + - locked door + - name: rat + system: true + dir: west + display: + invisible: false + char: 'r' + devices: + - logger + program: | + run "scenarios/Challenges/Ranching/_pied-piper/rat.sw" + walkable: + never: + - ladder +objectives: + - teaser: Bait + goal: + - The village dwellings have been infested by `rat`{=robot}s. You are charged with clearing the infestation. + - Scurrying feet can be heard through cracks under each `locked door`{=entity}. Unfortunately you've not been entrusted with `key`{=entity}s to the residences. + - Perhaps there is something that would entice them out? North of the river you spy fields of `oats`{=entity} and a `storage silo`{=structure}. + - Get some `oats`{=entity}. + condition: | + as base { + has "oats"; + } + - teaser: Silo + id: silo + goal: + - Inspect the `storage silo`{=structure}. + condition: | + as base { + loc <- locateme; + match loc \l. \_. + pure $ l == "silo"; + } + - teaser: Moldy + prerequisite: silo + id: moldy + goal: + - A `rat`{=robot} will `selfdestruct` if it comes in contact with `mold`{=entity}. + - Obtain some `mold spores`{=entity}. + condition: | + as base { + has "mold spores"; + } + - teaser: Corral + prerequisite: moldy + goal: + - Dispatch the `rat`{=robot}s with `mold`{=entity}. + - Note that `mold spores`{=entity} will only spread when `sow`n in a dark, damp environment. + condition: | + try { + r <- robotNamed "rat"; + pure false; + } {pure true} + - teaser: Spelunker + prerequisite: silo + goal: + - Find a secret passage. + - To unlock a door, you need to `use "unlocker"`, which will consume a `key`{=entity}. + condition: | + as base { + loc <- locateme; + match loc \l. \_. + pure $ l == "tunnel"; + } +solution: | + run "scenarios/Challenges/Ranching/_pied-piper/solution.sw" +entities: + - name: seed spreader + display: + char: 's' + description: + - A device to distribute seeds and spores + properties: [known] + capabilities: [sow] + - name: brick + display: + char: '#' + attr: brick + description: + - Sturdy building material + properties: [known, unwalkable] + - name: fence + display: + char: '#' + attr: wood + description: + - Keeps interlopers away from the fields. + properties: [known, unwalkable] + - name: locked door + display: + char: 'D' + attr: wood + description: + - door + properties: [known] + - name: unlocked door + display: + char: '/' + attr: wood + description: + - Unlocked door + properties: [known] + - name: key + display: + char: 'k' + description: + - Used by an `unlocker`{=entity} to open a a `locked door`{=entity} + properties: [known, pickable] + - name: unlocker + display: + char: 'u' + description: + - Facilitates use of a `key`{=entity} + properties: [known] + - name: ladder + display: + char: 'H' + attr: wood + description: + - Ladder. Rodents cannot climb this. + properties: [known] + - name: chute + display: + char: 'C' + description: + - A trapdoor to the netherworld + properties: [known] + - name: wall + display: + char: 'W' + attr: wood + description: + - wall + properties: [known, unwalkable, boundary] + - name: oats + display: + attr: oats + char: 't' + description: + - Grain + properties: [known, pickable, growable] + growth: + duration: [40, 80] + biomes: [dirt] + - name: mold + display: + attr: mold + char: 'm' + description: + - Spreads in dark, damp environments. + - Toxic to `rat`{=robot}s. + - Yields `mold spores`{=entity} when `harvest`ed or `grab`bed. + properties: [known, pickable, growable] + yields: mold spores + growth: + duration: [15, 30] + spread: + radius: 2 + density: 0.3 + biomes: [clay] + - name: mold spores + display: + attr: mold + char: '*' + description: + - Grows into `mold`{=entity} in dark, damp environments. + - In spore form, has no effect on `rat`{=robot}s. + properties: [known, pickable, growable] + growth: + duration: [15, 30] + mature: mold + spread: + radius: 2 + density: 0.3 + biomes: [clay] +known: [water, boulder] +structures: + - name: storage silo + recognize: + - north + structure: + mask: '.' + palette: + 'x': [stone, brick] + '=': [stone] + 'c': + cell: [stone, chute] + waypoint: + name: chute_entrance + 'a': [blank, oats] + 'H': + cell: [dirt, ladder] + waypoint: + name: well_top + map: | + ......xxxxxH. + .....x===aax. + ...xx===aaaax + ....c==aaaaax + ...xx=aaaaaax + .....xaaaaax. + ......xxxxx.. + - name: field + structure: + palette: + 'a': [dirt, oats] + map: | + aaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaa +subworlds: + - name: silo + mask: '+' + palette: + '.': [clay] + 's': [stone, boulder] + 'k': [clay, key] + 'w': + cell: [clay] + waypoint: + name: chute_exit + 'H': + cell: [stone, ladder] + waypoint: + name: well_bottom + portals: + - entrance: well_bottom + exitInfo: + exit: well_top + subworldName: overworld + upperleft: [-1, 1] + map: | + +++++sHsss+++++ + +++ss.....ss+++ + ++s.........s++ + +s...........s+ + +s.....w.....s+ + +s.........k.s+ + ++s.........s++ + +++ss.....ss+++ + +++++sssss+++++ + - name: tunnel + mask: '+' + palette: + '.': [dirt] + 'x': [stone, boulder] + 'm': [dirt, mold] + 'H': + cell: [dirt, ladder] + waypoint: + name: underground_field_ladder + 'I': + cell: [dirt, ladder] + waypoint: + name: underground_house_ladder + portals: + - entrance: underground_field_ladder + exitInfo: + exit: field_ladder + subworldName: overworld + consistent: true + - entrance: underground_house_ladder + exitInfo: + exit: house_ladder + subworldName: overworld + consistent: true + upperleft: [-1, 1] + map: | + ++xHx+xx+ + ++x.xx.mx + ++x.xxm.x + ++x.xxx.x + ++x.....x + +++x.xxxx + +++x.x+++ + +++x.x+++ + +++xIx+++ +recipes: + - in: + - [1, locked door] + - [1, key] + out: + - [1, unlocked door] + required: + - [1, unlocker] +world: + name: overworld + structures: + - name: house ladder + structure: + palette: + 'w': [stone, wall] + 'H': + cell: [dirt, ladder] + waypoint: + name: house_ladder + map: | + www + wHw + - name: field ladder + structure: + palette: + 'H': + cell: [dirt, ladder] + waypoint: + name: field_ladder + map: H + - name: house + structure: + palette: + 'd': [stone, locked door] + 'x': [stone, wall] + '.': [stone] + 'r': [stone, erase, rat] + map: | + xxxxxxxxx + x.......x + d.......x + x.......x + x....r..x + x.......x + xxxxxxxxx + - name: street pair + structure: + placements: + - src: house + offset: [0, 0] + orient: + up: south + - src: house + offset: [16, 0] + orient: + flip: true + map: "" + - name: block + structure: + placements: + - src: street pair + offset: [0, 0] + orient: + flip: true + - src: street pair + offset: [0, 8] + map: "" + placements: + - src: block + offset: [-10, -14] + - src: block + offset: [-10, -36] + - src: storage silo + offset: [8, 9] + - src: field + offset: [-28, 12] + - src: field + offset: [-28, 7] + - src: field + offset: [-52, 12] + - src: field + offset: [-52, 7] + - src: field ladder + offset: [-8, 2] + - src: house ladder + offset: [-8, -5] + upperleft: [-2, 2] + portals: + - entrance: well_top + exitInfo: + exit: well_bottom + subworldName: silo + - entrance: chute_entrance + exitInfo: + exit: chute_exit + subworldName: silo + - entrance: field_ladder + exitInfo: + exit: underground_field_ladder + subworldName: tunnel + - entrance: house_ladder + exitInfo: + exit: underground_house_ladder + subworldName: tunnel + dsl: | + overlay + [ {grass} + , mask (x == -7 && y >= 3 || y == 3 && x <= -7) {fence} + , mask (y > -2 && y < 2) {water} + , mask (x > -3 && x < 3) {stone} + , mask (y > -25 && y < -19) {stone} + ] + palette: + 'b': [bridge, erase] + 'M': + cell: [bridge, erase] + waypoint: + name: bridge_top + map: | + Mbbbb + bbbbb + bbbbb + bbbbb + bbbbb diff --git a/data/scenarios/Challenges/Ranching/powerset.yaml b/data/scenarios/Challenges/Ranching/powerset.yaml --- a/data/scenarios/Challenges/Ranching/powerset.yaml +++ b/data/scenarios/Challenges/Ranching/powerset.yaml @@ -99,7 +99,7 @@ description: - Allows one to `stride` across multiple cells properties: [known, pickable] - capabilities: [movemultiple] + capabilities: [stride] - name: bell display: char: 'B' @@ -182,7 +182,6 @@ dsl: | {grass} upperleft: [-1, -1] - offset: false palette: 'B': [grass, null, base] 'S': [grass, null, setup] diff --git a/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml b/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml --- a/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml +++ b/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml @@ -157,16 +157,16 @@ display: char: 'G' description: - - Generates a magnetic field gradient that allows the use of `resonate` + - Generates a magnetic field gradient that allows the use of `resonate` and `density`. properties: [known] - capabilities: [detectcount] + capabilities: [resonate, density] - name: locator display: char: '{' description: - - Enables the `detect` command + - Enables the `detect` command. properties: [known] - capabilities: [detectloc] + capabilities: [detect] - name: border display: char: '▒' @@ -724,7 +724,6 @@ dsl: | {grass} upperleft: [-3, 2] - offset: false palette: B: [grass, null, base] y: [grass, null, setup] diff --git a/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw b/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw --- a/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw +++ b/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw @@ -16,7 +16,9 @@ end def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); + match t1 \t11. \t12. + match t2 \t21. \t22. + (t11 + t21, t12 + t22); end; /** Teleports to a new location to execute a function @@ -28,12 +30,12 @@ teleport self newLoc; retval <- f; teleport self prevLoc; - return retval; + pure retval; end; def itemIsHere = \item. x <- scan down; - case x (\_. return false) (\found. return $ found == item); + case x (\_. pure false) (\found. pure $ found == item); end; def getLetterEntityByIndex = \idx. @@ -52,7 +54,7 @@ def getValueHere = maybeItem <- scan down; - ordNum <- case maybeItem (\_. return 0) getOrdinal; + ordNum <- case maybeItem (\_. pure 0) getOrdinal; end; def getIndexesTotal = \boardWidth. \boardHeight. \n. @@ -61,9 +63,9 @@ teleport self (idx/boardHeight, -(mod idx boardWidth)); valueHere <- getValueHere; runningTotal <- getIndexesTotal boardWidth boardHeight $ n - 1; - return $ valueHere + runningTotal; + pure $ valueHere + runningTotal; } { - return 0; + pure 0; } end; @@ -77,7 +79,7 @@ let tileCount = squareCount - 1 in let indicesSum = computeTriangularNumber tileCount in mySum <- getIndexesTotal boardWidth boardHeight squareCount; - return $ indicesSum - mySum; + pure $ indicesSum - mySum; end; def replenishInk = @@ -114,12 +116,12 @@ def hasAdjacentBlank = \tileIdx. \n. if (n > 0) { result <- scan forward; - case result (\_. handleLegalMove tileIdx; return true;) (\_. + case result (\_. handleLegalMove tileIdx; pure true;) (\_. turn left; hasAdjacentBlank tileIdx $ n - 1; ); } { - return false; + pure false; } end; @@ -141,7 +143,7 @@ def handleMarker = \boardWidth. \boardHeight. detectReferenceLoc <- whereami; result <- detect "sliding-tile" ((0, 0), (boardWidth - 1, boardHeight - 1)); - case result return (\badLoc. + case result pure (\badLoc. teleportToDetectResult detectReferenceLoc badLoc; missingIdx <- atLocation (0, 0) $ findMissingIndex boardWidth boardHeight; markIsLegal <- isLegalMark missingIdx; @@ -173,7 +175,8 @@ isOnRightBorder <- itemIsHere b; if isOnRightBorder { loc <- whereami; - teleport self (0, snd loc - 1); + match loc \_. \y. + teleport self (0, y - 1); } {}; iterateAllTiles func; } diff --git a/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw b/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw --- a/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw +++ b/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw @@ -29,7 +29,7 @@ def getValueHere = maybeItem <- scan down; - ordNum <- case maybeItem (\_. return 0) getOrdinal; + ordNum <- case maybeItem (\_. pure 0) getOrdinal; end; /** @@ -81,9 +81,9 @@ let addend = if (referenceVal > valueHere) {1} {0} in recursiveSum <- countInnerInversions n referenceVal $ j + 1; let foo = recursiveSum in - return $ addend + foo; + pure $ addend + foo; } { - return 0; + pure 0; }; end @@ -102,9 +102,9 @@ turn back; subarrayInversions <- countInversions n $ i + 1; let foo = subarrayInversions in - return $ innerCountFoo + foo; + pure $ innerCountFoo + foo; } { - return 0; + pure 0; }; end @@ -115,13 +115,13 @@ def scanValid : Dir -> Cmd (Bool + Text) = \d. maybeTileForward <- scan d; case maybeTileForward - (\_. return $ inL false) + (\_. pure $ inL false) (\x. if (x == "sliding-tile") { - return $ inL true; + pure $ inL true; } { y <- getOrdinal x; - return $ if (y > 0) { + pure $ if (y > 0) { inR x; } { inL false; @@ -145,14 +145,14 @@ move; grab; // Abort early from the recursion. - return false; + pure false; } { // The new tile is not a sliding tile. // We assume it's a blank tile and move there. // If it turns out not to be blank, that will // be addressed in the outer "observe" loop. move; - return false; + pure false; }; ) (\newItem. let isSame = newItem == original in @@ -160,7 +160,7 @@ if isSame {} { say $ "Original was " ++ original ++ "; newItem was " ++ newItem; }; - return isSame; + pure isSame; ); end; @@ -179,14 +179,14 @@ // Our assumption was invalid; we don't have a // valid reference tile to compared the drilled tile to. say "Unexpected drilling; no reference tile."; - return false; + pure false; } { - return true; + pure true; } ) (actOnItemComparison maybeItem2); - return keepGoing; + pure keepGoing; } { - return false; + pure false; }; end; @@ -249,7 +249,8 @@ def placeRandomizedPuzzle = \arrayLoc. \boardWidth. \rowIndex. if (rowIndex >= 0) { - placeSingleRow (snd arrayLoc) boardWidth rowIndex $ boardWidth - 1; + match arrayLoc \_. \array_y. + placeSingleRow array_y boardWidth rowIndex $ boardWidth - 1; placeRandomizedPuzzle arrayLoc boardWidth $ rowIndex - 1; } {}; end; diff --git a/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw b/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw --- a/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw +++ b/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw @@ -27,14 +27,14 @@ def abs = \n. if (n < 0) {-n} {n} end; -def mapTuple = \f. \t. - (f $ fst t, f $ snd t) - end; +def λmatch = \f. \p. match p f end -def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); +def sumTuples = λmatch \t11. \t12. λmatch \t21. \t22. + (t11 + t21, t12 + t22); end; +def mapTuple = \f. λmatch \a. \b. (f a, f b) end; + def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -57,13 +57,13 @@ def getRelativeLocation = \absLoc. myloc <- whereami; let negatedLoc = negateTuple myloc in - return $ sumTuples negatedLoc absLoc; + pure $ sumTuples negatedLoc absLoc; end; def getRelativeRectangle : (Int * Int) * (Int * Int) -> Cmd ((Int * Int) * (Int * Int)) = \corners. myloc <- whereami; let negatedLoc = negateTuple myloc in - return $ mapTuple (sumTuples negatedLoc) corners; + pure $ mapTuple (sumTuples negatedLoc) corners; end; /** @@ -82,9 +82,7 @@ loc <- detect entName corners; end; -def moveTuple = \tup. - let x = fst tup in - let y = snd tup in +def moveTuple = λmatch \x. \y. turn $ if (x > 0) {east} {west}; doN (abs x) move; @@ -108,14 +106,12 @@ we should extract the vertical or horizontal dimension. */ def getRectDimension = \vertical. \rect. - let extractor = if vertical {snd} {fst} in - let tuple = mapTuple extractor rect in - abs $ snd tuple - fst tuple; + let extractor = if vertical {λmatch \a. \_. a} {λmatch \_. \b. b} in + match (mapTuple extractor rect) \a. \b. + abs $ b - a; end; -def getOffsets = \rect. - subtractTuple (snd rect) (fst rect); - end; +def getOffsets = λmatch \a. \b. subtractTuple b a end; def getAbsDelta = \rect. let difference = getOffsets rect in @@ -124,7 +120,7 @@ def distance = \loc1. \loc2. let d = getAbsDelta (loc1, loc2) in - fst d + snd d; + match d \a. \b. a + b end; // NOT USED @@ -146,17 +142,13 @@ mapTuple (\x. x + 1) absDifference; end; -def getRectArea = \dims. - fst dims * snd dims; - end; +def getRectArea = λmatch \w. \h. w * h end; /** Determines whether the vertical dimension is larger than the horizontal dimension. */ -def isVerticalLarger = \dims. - snd dims > fst dims; - end; +def isVerticalLarger = λmatch \w. \h. h > w; end; /** Returns a tuple of the two rectangle partitions. @@ -168,21 +160,21 @@ The "rightward/downward offset" (i.e. +1 horizontally, -1 vertically) to the "avg" for the second rectangle depends on this assumption. */ -def splitRectangle = \vertically. \rect. - let cornerA = fst rect in - let cornerB = snd rect in +def splitRectangle = \vertically. λmatch \cornerA. \cornerB. + match cornerA \ax. \ay. + match cornerB \bx. \by. if vertically { // TODO: We should "round down" the height of the second partition // so that the first partition is more likely to contain // the target (i.e. we perform one fewer iteration). - let avgY = (snd cornerA + snd cornerB) / 2 in - let firstRect = (cornerA, (fst cornerB, avgY)) in - let secondRect = ((fst cornerA, avgY - 1), cornerB) in + let avgY = (ay + by) / 2 in + let firstRect = (cornerA, (bx, avgY)) in + let secondRect = ((ax, avgY - 1), cornerB) in (firstRect, secondRect) } { - let avgX = (fst cornerA + fst cornerB) / 2 in - let firstRect = (cornerA, (avgX, snd cornerB)) in - let secondRect = ((avgX + 1, snd cornerA), cornerB) in + let avgX = (ax + bx) / 2 in + let firstRect = (cornerA, (avgX, by)) in + let secondRect = ((avgX + 1, ay), cornerB) in (firstRect, secondRect) }; end; @@ -191,7 +183,7 @@ entCount <- density rect; let dims = getDimensions rect in let tileCount = getRectArea dims in - return $ entCount < tileCount; + pure $ entCount < tileCount; end; /** @@ -204,24 +196,23 @@ The "first" partition in a horizontal split is the "left" partition. */ def findEmptyCell = \foundCriteria. \rect. - + let dims = getDimensions rect in let tileCount = getRectArea dims in if (tileCount < 1) { - return $ inL (); + pure $ inL (); } $ elif (tileCount == 1) { foundHere <- foundCriteria rect; - return $ if foundHere { - inR $ fst rect; + pure $ if foundHere { + match rect \w. \_. inR w; } { inL (); }; } $ else { let isBiggerVertically = isVerticalLarger dims in let splitted = splitRectangle isBiggerVertically rect in - let firstPartition = fst splitted in - let secondPartition = snd splitted in + match splitted \firstPartition. \secondPartition. foundInFirst <- foundCriteria firstPartition; let selectedPartition = if foundInFirst {firstPartition} {secondPartition} in @@ -237,13 +228,17 @@ It is assumed that one of the candidates will meet this criteria, so we only need check the first. */ -def avoidCollinear = \blankloc. \tileloc. \loc1. \loc2. - let firstOk = if (fst blankloc == fst tileloc) { - fst loc1 != fst tileloc - } $ elif (snd blankloc == snd tileloc) { - snd loc1 != snd tileloc +def avoidCollinear = + λmatch \blankx. \blanky. + λmatch \tilex. \tiley. + λmatch \loc1x. \loc1y. + \loc2. + let firstOk = if (blankx == tilex) { + loc1x != tilex + } $ elif (blanky == tiley) { + loc1y != tiley } $ else {true} in - if firstOk {loc1} {loc2}; + if firstOk {(loc1x, loc1y)} {loc2}; end; /** @@ -258,11 +253,14 @@ */ def getInitialBlankDestination = \blankLoc. \letterloc. \targetloc. let getCoord = \f. signum (f targetloc - f letterloc) + f letterloc in - avoidCollinear blankLoc letterloc (getCoord fst, snd letterloc) (fst letterloc, getCoord snd); + let fst = λmatch \a. \_. a in + let snd = λmatch \_. \b. b in + match letterloc \letterx. \lettery. + avoidCollinear blankLoc letterloc (getCoord fst, lettery) (letterx, getCoord snd); end; def moveSpaceToTile = \blankLoc. \targetRelativeLoc. \letterloc. - + log $ "first letter loc: " ++ format letterloc; // Note: this rectangle might not be "normalized" in terms @@ -297,7 +295,7 @@ log $ "absolute target loc: " ++ format targetLocAbsolute; targetRelativeLoc <- getRelativeLocation targetLocAbsolute; -// case eitherLetterloc return $ moveSpaceToTile blankLoc targetRelativeLoc; +// case eitherLetterloc pure $ moveSpaceToTile blankLoc targetRelativeLoc; moveTuple blankLoc; end; @@ -412,7 +410,7 @@ corners <- getBoardRectangle; eitherBlankLoc <- findEmptyCell blankCellLocatorCriteria corners; - case eitherBlankLoc return $ placeTile boardWidth 1; + case eitherBlankLoc pure $ placeTile boardWidth 1; moveManually; end; diff --git a/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw b/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw --- a/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw +++ b/data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw @@ -4,7 +4,7 @@ def itemIsHere = \item. x <- scan down; - case x (\_. return false) (\found. return $ found == item); + case x (\_. pure false) (\found. pure $ found == item); end; def getOrdinal : Text -> Cmd Int = \item. @@ -19,10 +19,10 @@ def isMonotonic : Int -> Cmd (Unit + Int) = \expectedVal. maybeItem <- scan down; case maybeItem - (\_. return $ inR expectedVal) // Cell was blank + (\_. pure $ inR expectedVal) // Cell was blank (\entity. intVal <- getOrdinal entity; - return $ if (intVal == expectedVal) { + pure $ if (intVal == expectedVal) { inR $ expectedVal + 1; } { inL (); @@ -41,17 +41,18 @@ def loopMonotonicityCheck : Int -> Cmd Bool = \expectedVal. isOnBottomBorder <- itemIsHere "border"; if isOnBottomBorder { - return true; + pure true; } { maybeNextVal <- isMonotonic expectedVal; case maybeNextVal - (\_. return false) + (\_. pure false) (\nextVal. move; isOnRightBorder <- itemIsHere "border"; if isOnRightBorder { loc <- whereami; - teleport self (0, snd loc - 1); + match loc \_. \y. + teleport self (0, y - 1); } {}; loopMonotonicityCheck nextVal; ); @@ -65,7 +66,7 @@ teleport self (0, 0); loopMonotonicityCheck 1; } { - return false; + pure false; }; end; diff --git a/data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml b/data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml --- a/data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml +++ b/data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml @@ -69,7 +69,6 @@ dsl: | {grass, water} upperleft: [-1, 1] - offset: false palette: 'B': [grass, erase, base] '.': [grass, erase] diff --git a/data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml b/data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml --- a/data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml +++ b/data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml @@ -52,7 +52,6 @@ dsl: | {grass, water} upperleft: [-1, 1] - offset: false palette: 'B': [grass, erase, base] '.': [grass, erase] diff --git a/data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml b/data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml --- a/data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml +++ b/data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml @@ -104,7 +104,6 @@ dsl: | {grass, water} upperleft: [-1, 1] - offset: false palette: 'B': [ice, erase, base] '.': [grass, erase] diff --git a/data/scenarios/Challenges/Sokoban/foresight.yaml b/data/scenarios/Challenges/Sokoban/foresight.yaml --- a/data/scenarios/Challenges/Sokoban/foresight.yaml +++ b/data/scenarios/Challenges/Sokoban/foresight.yaml @@ -92,13 +92,12 @@ char: '#' description: - Unmovable barrier - properties: [known, unwalkable] + properties: [known, unwalkable, boundary] known: [mountain, water, 3D printer, flower] world: dsl: | {grass, water} upperleft: [-21, 10] - offset: false palette: 'B': [ice, erase, base] '.': [grass, erase] diff --git a/data/scenarios/Challenges/_blender/apprehension-checker.sw b/data/scenarios/Challenges/_blender/apprehension-checker.sw --- a/data/scenarios/Challenges/_blender/apprehension-checker.sw +++ b/data/scenarios/Challenges/_blender/apprehension-checker.sw @@ -2,12 +2,12 @@ let basename = "base" in x <- as r {whoami}; if (x == basename) { - return false; + pure false; } { mr0 <- as r {meet}; case mr0 - (\_. return false) - (\bot. name <- as bot {whoami}; return $ name == basename); + (\_. pure false) + (\bot. name <- as bot {whoami}; pure $ name == basename); }; end; @@ -26,11 +26,11 @@ let foo = intermediate in let newIdx = idx + 1 in recursiveResult <- anyHasMetBase newIdx; - return $ foo || recursiveResult; + pure $ foo || recursiveResult; } { // Terminates the recursion on the // lowest index at which a robot does not exist - return false; + pure false; }; end; diff --git a/data/scenarios/Challenges/_bridge-building/flower-ring-check.sw b/data/scenarios/Challenges/_bridge-building/flower-ring-check.sw --- a/data/scenarios/Challenges/_bridge-building/flower-ring-check.sw +++ b/data/scenarios/Challenges/_bridge-building/flower-ring-check.sw @@ -3,13 +3,13 @@ def isItemInDirection = \direction. \item. x <- scan direction; - return $ case x (\_. false) (\y. y == item); + pure $ case x (\_. false) (\y. y == item); end; def isFlankedByItem = \item. hasLeft <- isItemInDirection left item; hasRight <- isItemInDirection right item; - return $ hasLeft && hasRight; + pure $ hasLeft && hasRight; end; def flowersInCardinalDirections = \item. \n. @@ -19,10 +19,10 @@ turn left; flowersInCardinalDirections item $ n - 1; } { - return false; + pure false; }; } { - return true; + pure true; } end; @@ -38,12 +38,12 @@ isFlanked2 <- isFlankedByItem item; turn back; move; - return isFlanked2; + pure isFlanked2; } { - return false; + pure false; } } { - return false; + pure false; } end; diff --git a/data/scenarios/Challenges/_bucket-brigade/hauler.sw b/data/scenarios/Challenges/_bucket-brigade/hauler.sw --- a/data/scenarios/Challenges/_bucket-brigade/hauler.sw +++ b/data/scenarios/Challenges/_bucket-brigade/hauler.sw @@ -27,8 +27,8 @@ traverseRoad; doNTimesOr 40 ( briquetteIsHere <- ishere briquette; - if briquetteIsHere {grab; return ()} {}; - return briquetteIsHere; + if briquetteIsHere {grab; pure ()} {}; + pure briquetteIsHere; ); turn back; traverseRoad; diff --git a/data/scenarios/Challenges/_combo-lock/setup.sw b/data/scenarios/Challenges/_combo-lock/setup.sw --- a/data/scenarios/Challenges/_combo-lock/setup.sw +++ b/data/scenarios/Challenges/_combo-lock/setup.sw @@ -18,8 +18,7 @@ if (remainingCount > 0) { let splitted = split 1 colorString in - let nextLetter = fst splitted in - let remainingLetters = snd splitted in + match splitted \nextLetter. \remainingLetters. let expectedPixel = pixelFromColor nextLetter in move; @@ -31,7 +30,7 @@ // Replace the cell watches doN stepsTaken (watch down; move); turn back; - return noMismatchYet; + pure noMismatchYet; }; end; @@ -41,7 +40,7 @@ move; turn left; doN n (grab; move); - return () + pure () end; def doUntilCorrect = \colorString. @@ -49,7 +48,7 @@ if isCorrect { let remainingCount = chars colorString in unlockGate remainingCount; - return true; + pure true; } { wait 1000; doUntilCorrect colorString; @@ -69,7 +68,7 @@ createCombo $ newColor ++ colorString; } { turn back; - return colorString; + pure colorString; }; end; diff --git a/data/scenarios/Challenges/_combo-lock/solution.sw b/data/scenarios/Challenges/_combo-lock/solution.sw --- a/data/scenarios/Challenges/_combo-lock/solution.sw +++ b/data/scenarios/Challenges/_combo-lock/solution.sw @@ -10,7 +10,7 @@ if (n > 0) { drill down; maybeNextEnt <- scan east; - case maybeNextEnt return (\_. turn east; move; cycleCombos 3); + case maybeNextEnt pure (\_. turn east; move; cycleCombos 3); cycleCombos $ n - 1; } { turn west; diff --git a/data/scenarios/Challenges/_dimsum/cook.sw b/data/scenarios/Challenges/_dimsum/cook.sw --- a/data/scenarios/Challenges/_dimsum/cook.sw +++ b/data/scenarios/Challenges/_dimsum/cook.sw @@ -1,11 +1,11 @@ def modifyCart = \cartType. \device. result <- scan forward; - case result return (\item. + case result pure (\item. if (item == cartType) { use device forward; - return (); + pure (); } { - return (); + pure (); }; ); end; diff --git a/data/scenarios/Challenges/_dimsum/patron.sw b/data/scenarios/Challenges/_dimsum/patron.sw --- a/data/scenarios/Challenges/_dimsum/patron.sw +++ b/data/scenarios/Challenges/_dimsum/patron.sw @@ -1,11 +1,11 @@ def modifyCart = \cartType. \device. result <- scan forward; - case result return (\item. + case result pure (\item. if (item == cartType) { use device forward; - return (); + pure (); } { - return (); + pure (); }; ); end; diff --git a/data/scenarios/Challenges/_dna/lab.sw b/data/scenarios/Challenges/_dna/lab.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_dna/lab.sw @@ -0,0 +1,190 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def waypointByIndexRec : (rec l. Unit + (Int * Int) * l) -> Int -> (Int * Int) = \wps. \idx. + + case wps (\_. fail "invalid index") (\cons. + match cons \hd. \tl. + if (idx == 0) { + hd; + } { + waypointByIndexRec tl $ idx - 1; + } + ); + end; + +def waypointByIndex : Text -> Int -> (Int * Int) = \wpName. \idx. + let wpList = waypoints wpName in + waypointByIndexRec wpList idx; + end; + +def getBaseForNumber = \n. + if (n == 0) { + "guanine"; + } { + if (n == 1) { + "cytosine"; + } { + if (n == 2) { + "adenine"; + } { + "thymine"; + }; + }; + }; + end; + +def getNumberForBase = \n. + if (n == "guanine") { + 0; + } { + if (n == "cytosine") { + 1; + } { + if (n == "adenine") { + 2; + } { + 3; + }; + }; + }; + end; + +/** Toggle the lowest bit */ +def getComplementNumber = \n. + if (n == 0) { + 1; + } { + if (n == 1) { + 0; + } { + if (n == 2) { + 3; + } { + 2; + }; + }; + }; + end; + +def waitUntilSomethingExists = + maybeItemHere <- scan down; + case maybeItemHere (\_. + watch down; + wait 1000; + waitUntilSomethingExists; + ) pure; + end; + +def waitUntilHere = \item. + hereNow <- ishere item; + if hereNow {} { + watch down; + wait 1000; + waitUntilHere item; + }; + end; + +def waitUntilOccupied = + stillEmpty <- isempty; + if stillEmpty { + watch down; + wait 1000; + waitUntilOccupied; + } {}; + end; + +def myStandby = \receptacleLoc. + teleport self receptacleLoc; + entToClone <- grab; + teleport self (36, -11); + turn back; + pure $ inR entToClone; + end; + +def placeBase = \standbyFunc. \n. + + if (n > 0) { + idx <- random 4; + let entTemp = getBaseForNumber idx in + let ent = entTemp in + create ent; + place ent; + move; + + clonedOrganism <- placeBase standbyFunc $ n - 1; + + // Unwinds the stack; verifies the original placement order + placedEnt <- instant waitUntilSomethingExists; + let isGood = ent == placedEnt in + move; + + if isGood { + pure clonedOrganism; + } { + pure $ inL (); + } + } { + // Returns the clonedOrganism + standbyFunc; + }; + end; + +def makeDnaStrand = \receptacleLoc. + teleport self (5, -2); + + dims <- floorplan "DNA decoder"; + match dims \decoderWidth. \_. + eitherClonedOrganism <- placeBase (myStandby receptacleLoc) decoderWidth; + + case eitherClonedOrganism (\_. + create "pixel (R)"; + ) (\clonedItem. + instant $ ( + teleport self (0, -11); + waitUntilHere "switch (on)"; + + let receptacleLoc2 = waypointByIndex "receiver" 1 in + teleport self receptacleLoc2; + + sow clonedItem; + create clonedItem; + k <- robotnamed "keeper"; + give k clonedItem; + + let slideBox = "slide box" in + create slideBox; + give base slideBox; + say $ "You got a new \"" ++ slideBox ++ "\""; + ); + ); + end; + +def waitForCloneableOrganism = + let receptacleLoc = waypointByIndex "receiver" 0 in + organism <- instant ( + teleport self receptacleLoc; + + waitUntilOccupied; + + thingHere <- scan down; + pure $ case thingHere (\x. inL x) (\item. + if (hastag item "organism") {inR item} {inL ()} + ) + ); + + case organism (\_. + say "Not a cloneable organism!"; + waitForCloneableOrganism; + ) (\_. + create "pixel (G)"; + makeDnaStrand receptacleLoc; + ); + end; + +def go = + waitForCloneableOrganism; + turn east; + go; + end; + +go; diff --git a/data/scenarios/Challenges/_dna/mirrorbot.sw b/data/scenarios/Challenges/_dna/mirrorbot.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_dna/mirrorbot.sw @@ -0,0 +1,99 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def getBaseForNumber = \n. + if (n == 0) { + "guanine"; + } { + if (n == 1) { + "cytosine"; + } { + if (n == 2) { + "adenine"; + } { + "thymine"; + }; + }; + }; + end; + +def getNumberForBase = \n. + if (n == "guanine") { + 0; + } { + if (n == "cytosine") { + 1; + } { + if (n == "adenine") { + 2; + } { + if (n == "thymine") { + 3; + } {-1}; + }; + }; + }; + end; + +/** Toggle the lowest bit */ +def getComplementNumber = \n. + if (n == 0) { + 1; + } { + if (n == 1) { + 0; + } { + if (n == 2) { + 3; + } { + 2; + }; + }; + }; + end; + +def placeComplementOf = \item. + let baseNumber = getNumberForBase item in + if (baseNumber >= 0) { + let complementNumber = getComplementNumber baseNumber in + let newItem = getBaseForNumber complementNumber in + move; + create newItem; + place newItem; + } { + let sludge = "organic sludge" in + create sludge; + place sludge; + } + end; + +def waitUntilHere = + watch down; + wait 1000; + + maybeItemDown <- scan down; + case maybeItemDown (\_. waitUntilHere) (\itemHere. + placeComplementOf itemHere; + ); + end; + +def waitUntilEmpty = + watch down; + wait 1000; + emptyHere <- isempty; + if emptyHere { + // reset the position + turn back; + move; + turn back; + } { + waitUntilEmpty; + } + end; + +def go = + instant waitUntilHere; + waitUntilEmpty; + go; + end; + +go; diff --git a/data/scenarios/Challenges/_dna/resetter.sw b/data/scenarios/Challenges/_dna/resetter.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_dna/resetter.sw @@ -0,0 +1,48 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +/** +Assumes we are on the left edge of a row of nucleobases +*/ +def resetPlayfieldRow = + dims <- floorplan "DNA decoder"; + match dims \decoderWidth. \_. + doN decoderWidth (grab; move;); + end; + +def resetPlayfield = + teleport self (5, -2); + resetPlayfieldRow; + teleport self (5, -3); + resetPlayfieldRow; + + teleport self (5, -11); + resetPlayfieldRow; + teleport self (5, -12); + resetPlayfieldRow; + end; + +def watchSwitch = \lastState. + watch down; + wait 1000; + found <- scan down; + case found pure (\item. + if (item != lastState) { + if (item == "switch (off)") { + loc <- whereami; + resetPlayfield; + teleport self loc; + } { + }; + } {}; + watchSwitch item; + ); + end; + +def go = + instant $ ( + found <- scan down; + case found pure watchSwitch; + ); + end; + +go; diff --git a/data/scenarios/Challenges/_dna/solution.sw b/data/scenarios/Challenges/_dna/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_dna/solution.sw @@ -0,0 +1,262 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def moveUntilBlocked = + blockedHere <- blocked; + if blockedHere {} { + move; + moveUntilBlocked; + } + end; + +def getBaseForNumber = \n. + if (n == 0) { + "guanine"; + } { + if (n == 1) { + "cytosine"; + } { + if (n == 2) { + "adenine"; + } { + "thymine"; + }; + }; + }; + end; + +def getNumberForBase = \n. + if (n == "guanine") { + 0; + } { + if (n == "cytosine") { + 1; + } { + if (n == "adenine") { + 2; + } { + 3; + }; + }; + }; + end; + +/** Toggle the lowest bit */ +def getComplementNumber = \n. + if (n == 0) { + 1; + } { + if (n == 1) { + 0; + } { + if (n == 2) { + 3; + } { + 2; + }; + }; + }; + end; + +def waitWhileHere = \item. + stillHere <- ishere item; + if stillHere { + watch down; + wait 1000; + waitWhileHere item; + } {}; + end; + +def waitUntilHere = \item. + hereNow <- ishere item; + if hereNow {} { + watch down; + wait 1000; + waitUntilHere item; + }; + end; + +def moveToPattern = + turn back; + doN 5 move; + turn left; + doN 4 move; + turn left; + move; + end; + +def moveToOtherRow = + turn right; + doN 2 move; + turn right; + doN 4 move; + turn left; + doN 4 move; + turn left; + doN 4 move; + turn right; + doN 2 move; + turn right; + move; + end; + +def waitForItem : Dir -> Cmd Text = \d. + item <- scan d; + case item (\_. + watch d; + wait 1000; + waitForItem d; + ) pure; + end; + +def waitForSpecificItem = \item. \d. + itemIsHere <- ishere item; + if itemIsHere { + } { + watch d; + wait 1000; + waitForSpecificItem item d; + } + end; + +def placeComplementOf = \item. + let baseNumber = getNumberForBase item in + let complementNumber = getComplementNumber baseNumber in + let newItem = getBaseForNumber complementNumber in + place newItem; + end; + +/** +Store the observed entities in the recursion stack. +*/ +def replicatePattern = \standbyFunc. \n. + if (n > 0) { + thingTemp <- waitForItem left; + let thing = thingTemp in + placeComplementOf thing; + move; + replicatePattern standbyFunc $ n - 1; + + place thing; + move; + } { + standbyFunc; + } + end; + +/** +Position self at entrance +*/ +def pickFlowerAndWater = + doN 6 move; + dahlia <- grab; + + turn left; + doN 8 move; + turn right; + doN 31 move; + clover <- grab; + turn back; + doN 35 move; + d <- grab; + doN 10 move; + + turn left; + + doN 18 move; + use "siphon" forward; + turn left; + doN 7 ( + move; + use "siphon" right; + ); + doN 4 move; + turn right; + doN 16 move; + + mushroom <- grab; + + turn back; + doN 23 move; + + turn right; + pure dahlia; + + // pure mushroom; + // pure d; + end; + + +def waitUntilOccupied = + stillEmpty <- isempty; + if stillEmpty { + watch down; + wait 1000; + waitUntilOccupied; + } {}; + end; + +def returnToInputReceptacle = + turn back; + doN 5 move; + turn left; + moveUntilBlocked; + turn left; + doN 29 move; + turn right; + moveUntilBlocked; + turn left; + doN 4 move; + turn right; + doN 6 move; + turn right; + moveUntilBlocked; + end; + +def completeDnaTask = \sentinel. + place sentinel; + make "specimen slide"; + + doN 16 $ make "cytosine"; + + waitWhileHere sentinel; + moveToPattern; + replicatePattern moveToOtherRow 32; + + // Activate the switch + doN 3 move; + drill forward; + wait 2; + drill forward; + + turn left; + doN 6 move; + turn left; + doN 32 move; + turn left; + doN 2 move; + turn left; + move; + + waitUntilOccupied; + grab; + + returnToInputReceptacle; + end; + +def λcase = \f. \g. \s. case s f g end +def λmatch = \f. \p. match p f end + +def mapM_ : (a -> Cmd b) -> (rec l. Unit + a * l) -> Cmd Unit = \f. λcase + (\_. pure ()) + (λmatch \hd. \tl. f hd; mapM_ f tl) +end; + +def go = + _sentinel <- pickFlowerAndWater; + moveUntilBlocked; + + let organisms = tagmembers "organism" in + mapM_ completeDnaTask organisms; + end; + +go; diff --git a/data/scenarios/Challenges/_dna/topchecker.sw b/data/scenarios/Challenges/_dna/topchecker.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_dna/topchecker.sw @@ -0,0 +1,107 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def getBaseForNumber = \n. + if (n == 0) { + "guanine"; + } { + if (n == 1) { + "cytosine"; + } { + if (n == 2) { + "adenine"; + } { + "thymine"; + }; + }; + }; + end; + +def getNumberForBase = \n. + if (n == "guanine") { + 0; + } { + if (n == "cytosine") { + 1; + } { + if (n == "adenine") { + 2; + } { + if (n == "thymine") { + 3; + } {-1}; + }; + }; + }; + end; + +/** Toggle the lowest bit */ +def getComplementNumber = \n. + if (n == 0) { + 1; + } { + if (n == 1) { + 0; + } { + if (n == 2) { + 3; + } { + 2; + }; + }; + }; + end; + +def waitUntilHere = \remainingCount. + if (remainingCount > 0) { + maybeItemHere <- scan down; + case maybeItemHere (\_. + watch down; + wait 1000; + waitUntilHere remainingCount; + ) (\itemHere. + + maybeItemAbove <- scan left; + case maybeItemAbove (\_. fail "Expected an item here.") (\itemAbove. + let num = getNumberForBase itemAbove in + if (num >= 0) { + let complementNum = getComplementNumber num in + let complementItem = getBaseForNumber complementNum in + if (complementItem == itemHere) { + move; + waitUntilHere $ remainingCount - 1; + } { + create "pixel (R)"; + } + } { + fail "Expected nonnegative item index." + } + ); + ); + } { + create "pixel (G)"; + }; + end; + +def waitUntilEmpty = + watch down; + wait 1000; + emptyHere <- isempty; + if emptyHere {} { + waitUntilEmpty; + } + end; + +def waitForReset = + backup; + waitUntilEmpty; + end; + +def go = \startingLoc. + instant $ waitUntilHere 32; + waitForReset; + teleport self startingLoc; + go startingLoc; + end; + +loc <- whereami; +go loc; diff --git a/data/scenarios/Challenges/_flower-count/judge.sw b/data/scenarios/Challenges/_flower-count/judge.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_flower-count/judge.sw @@ -0,0 +1,35 @@ +def win = + try { + firestarter <- robotNamed "firestarter"; + halt firestarter + } {}; + try { + fire <- robotNamed "fire"; + halt fire; wait 1; + reprogram fire { selfdestruct }; + } {}; + create "gold" +end + +def judgeCount : Int -> Cmd Unit = \actual. + watch down; + wait 1024; + s <- scan down; + case s + (\_. pure ()) + (\p. + try { + let c = read @Int p in + if (c == actual) { win } {} + } {} + ) +end + +def forever = \c. c; forever c end + +def judge = + numFlowers <- resonate "flower" ((-59,-19),(60,20)); + forever (judgeCount numFlowers); +end; + +judge diff --git a/data/scenarios/Challenges/_flower-count/solution.sw b/data/scenarios/Challenges/_flower-count/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_flower-count/solution.sw @@ -0,0 +1,114 @@ +def doN : Int -> Cmd a -> Cmd Unit = \n. \c. + if (n == 0) {} {c; doN (n-1) c} +end + +def abs : Int -> Int = \n. + if (n < 0) {-n} {n} +end + +def λmatch = \f. \p. match p f end +def λcase = \f. \g. \s. case s f g end + +// Go to the given absolute coordinates. End facing east. +def goto : Int * Int -> Cmd Unit = λmatch \destx. \desty. + cur <- whereami; + match cur \x. \y. + let dx = destx - x in + let dy = desty - y in + if (dx < 0) {turn west} {turn east}; + doN (abs dx) move; + if (dy < 0) {turn south} {turn north}; + doN (abs dy) move; + turn east; +end + +def liftA2 : (a -> b -> c) -> Cmd a -> Cmd b -> Cmd c = \f. \ca. \cb. + a <- ca; + b <- cb; + pure (f a b) +end + +def add : Cmd Int -> Cmd Int -> Cmd Int = liftA2 (\x. \y. x + y) end + +def countCell : Cmd Int = + s <- scan down; + pure $ case s + (\_. 0) + (\t. if (t == "flower") {1} {0}) +end + +tydef List a = rec l. Unit + (a * l) end + +def sum : List Int -> Int = λcase + (\_. 0) + (λmatch \hd. \tl. hd + sum tl) +end + +def for : Int -> (Int -> Cmd a) -> Cmd (List a) = \n. \k. + if (n == 0) {pure (inl ())} {a <- k n; b <- for (n-1) k; pure (inr (a,b))} +end + +def countRow : Int -> Cmd Int = \w. + ns <- for (w-1) (\_. n <- countCell; move; pure n); + last <- countCell; + pure (sum ns + last) +end + +def isEven : Int -> Bool = \n. (n / 2) * 2 == n end + +def around : Dir -> Cmd Unit = \d. turn d; move; turn d end + +// countFlowers (w,h) (x,y) counts the number of flowers +// in the w by h rectangle with lower-left corner at (x,y) +def countFlowers : Int * Int -> Int * Int -> Cmd Int = \size. \ll. + goto ll; + match size \w. \h. + cnts <- for (h-1) (\i. + cnt <- countRow w; + if (isEven i) { around right } { around left }; + pure cnt + ); + last <- countRow w; + pure (sum cnts + last) +end + +def acquire : Cmd Text = + thing <- atomic (b <- isempty; if b {pure ""} {grab}); + if (thing == "") {acquire} {pure thing} +end + +def countAndReport : Int * Int -> Int * Int -> Cmd Unit = \size. \ll. + cnt <- countFlowers size ll; + goto (0,0); + paper <- acquire; + let soFar = read @Int paper in + erase paper; + newPaper <- print "paper" (format (soFar + cnt)); + place newPaper; +end + +def until : Cmd Bool -> Cmd a -> Cmd Unit = \test. \body. + b <- test; if b {} {body; until test body} +end + +def acquireFlower : Cmd Unit = + until (ishere "flower") move; grab; pure () +end + +def go = + for 4 (\r. + for 3 (\c. + build {countAndReport (40,10) (-59 + 40*(c-1), -19 + 10*(r-1))} + ) + ); + print "paper" "0"; + turn left; move; place "paper: 0"; + wait 1024; + acquireFlower; + turn back; + goto (20,0); + res <- meet; + case res (\_. pure ()) (\truelove. give truelove "flower") +end; + +go; diff --git a/data/scenarios/Challenges/_friend/cat.sw b/data/scenarios/Challenges/_friend/cat.sw --- a/data/scenarios/Challenges/_friend/cat.sw +++ b/data/scenarios/Challenges/_friend/cat.sw @@ -11,7 +11,7 @@ def randdir : Cmd Dir = d <- random 4; - return ( + pure ( if (d == 0) {north} $ elif (d == 1) {east} $ elif (d == 2) {south} @@ -21,7 +21,7 @@ def chooseWait : Cmd Int = t <- random (16*2); - return (16 + t) + pure (16 + t) end def wander = @@ -37,9 +37,11 @@ def follow : Cmd Unit -> Actor -> Cmd Unit = \cat. \r. rLoc <- as r {whereami}; + match rLoc \rx. \ry. myLoc <- whereami; - let dx = fst rLoc - fst myLoc in - let dy = snd rLoc - snd myLoc in + match myLoc \myx. \myy. + let dx = rx - myx in + let dy = ry - myy in if (abs dx > abs dy) { if (dx < 0) {turn west} {turn east} } { if (dy < 0) {turn south} {turn north} }; diff --git a/data/scenarios/Challenges/_friend/friend-solution.sw b/data/scenarios/Challenges/_friend/friend-solution.sw --- a/data/scenarios/Challenges/_friend/friend-solution.sw +++ b/data/scenarios/Challenges/_friend/friend-solution.sw @@ -11,7 +11,7 @@ end; build { - require 3 "fish"; + stock 3 "fish"; m2; turn left; m20; give_fish 3; turn back; m20; turn right; m2 diff --git a/data/scenarios/Challenges/_gallery/setup.sw b/data/scenarios/Challenges/_gallery/setup.sw --- a/data/scenarios/Challenges/_gallery/setup.sw +++ b/data/scenarios/Challenges/_gallery/setup.sw @@ -1,3 +1,5 @@ +instant ( + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; def isDivisibleBy = \dividend. \divisor. @@ -60,7 +62,7 @@ if (isBitSet bitmask nextRandomVal) { getUnusedRandom maxval bitmask; } { - return nextRandomVal; + pure nextRandomVal; } end; @@ -75,7 +77,7 @@ nextRandomVal <- getUnusedRandom maxval bitmask; let newBitmask = bitmask + shiftLeft 1 nextRandomVal in naiveRandomStack valueFunc maxval newBitmask $ n - 1; - return nextRandomVal; + pure nextRandomVal; } { // We're at the peak of the stack. // Now we unwind it. @@ -83,18 +85,28 @@ // Saves some time in generating the last number by inferring the // only remaining possible choice. let missingBit = getMissingBit bitmask maxval in - return missingBit; + pure missingBit; }; valueFunc val; end; -def getEntName = \idx. - result <- tagmembers "bust" idx; - return $ snd result; - end; +def λcase = \f. \g. \s. case s f g end +def λmatch = \f. \p. match p f end +def index : Int -> (rec l. Unit + a * l) -> a = \i. λcase + (\_. fail "bad index") + (λmatch \hd. \tl. if (i == 0) {hd} {index (i-1) tl}) +end + +def length : (rec l. Unit + a * l) -> Int = λcase + (\_. 0) (λmatch \_. \tl. 1 + length tl) +end + +def busts : (rec l. Unit + Text * l) = tagmembers "bust" end +def bustCount : Int = length busts end + def placeThing = \entIdx. - entName <- getEntName entIdx; + let entName = index entIdx busts in create entName; place entName; end; @@ -116,13 +128,10 @@ "idx" counts upwards. */ def populateInventory = \baseCount. \idx. - - result <- tagmembers "bust" idx; - let total = fst result in - if (idx < total) { + if (idx < bustCount) { - let item = snd result in + let item = index idx busts in // Give copies to the base baseExtras <- random 5; @@ -143,19 +152,18 @@ end; def setup = - result <- tagmembers "bust" 0; - let totalCount = fst result in - populateInventory 0 0; - naiveRandomStack placeEntByIndex totalCount 0 totalCount; + naiveRandomStack placeEntByIndex bustCount 0 bustCount; turn back; move; create "bitcoin"; end; def go = - instant setup; + setup; end; go; + +) diff --git a/data/scenarios/Challenges/_gallery/solution.sw b/data/scenarios/Challenges/_gallery/solution.sw --- a/data/scenarios/Challenges/_gallery/solution.sw +++ b/data/scenarios/Challenges/_gallery/solution.sw @@ -3,7 +3,7 @@ def countRow = \currentCount. emptyHere <- isempty; if emptyHere { - return currentCount; + pure currentCount; } { move; countRow $ 1 + currentCount; @@ -12,9 +12,9 @@ def getOrdinal = \d. maybeEntity <- scan d; - case maybeEntity (\nothing. return $ inL nothing) (\item. + case maybeEntity (\nothing. pure $ inL nothing) (\item. myCount <- count item; - return $ inR myCount; + pure $ inR myCount; ); end; @@ -72,7 +72,7 @@ thisOrdinal <- if (remainingSteps > 1) { getOrdinal right; } { - return $ inL (); + pure $ inL (); }; case thisOrdinal (\_. @@ -83,9 +83,9 @@ let shouldSwap = num < previousOrdinal in ordinal <- if shouldSwap { doSwap; - return previousOrdinal; + pure previousOrdinal; } { - return num; + pure num; }; move; swapAdjacent (remainingSteps - 1) ordinal; @@ -96,7 +96,7 @@ if (unsortedCount > 1) { prevOrdinal <- getOrdinal right; move; - case prevOrdinal return $ swapAdjacent unsortedCount; + case prevOrdinal pure $ swapAdjacent unsortedCount; doLoop $ unsortedCount - 1; } {} end; diff --git a/data/scenarios/Challenges/_gopher/gopher.sw b/data/scenarios/Challenges/_gopher/gopher.sw --- a/data/scenarios/Challenges/_gopher/gopher.sw +++ b/data/scenarios/Challenges/_gopher/gopher.sw @@ -7,9 +7,9 @@ def randSign = \x. opposite <- random 2; if (opposite == 1) { - return (-x); + pure (-x); } { - return x; + pure x; } end; @@ -33,8 +33,10 @@ end; def converge = \dest. \currentLoc. - let xDist = fst currentLoc - fst dest in - let yDist = snd currentLoc - snd dest in + match dest \destx. \desty. + match currentLoc \curx. \cury. + let xDist = curx - destx in + let yDist = cury - desty in randSwap (goDir xDist east west) (goDir yDist north south); end; @@ -84,7 +86,7 @@ // but *before* it executes `grab`, the gopher will crash. // Thus we have wrapped this `grab` in a `try`. grab; - return (); + pure (); } {}; }; } {}; @@ -94,9 +96,9 @@ newCount <- count dropping; if (newCount > 0) { let tauntStage = getTauntStage startingAmount newCount in - let tauntIndex = fst tauntStage in + match tauntStage \tauntIndex. \taunt. if (tauntIndex != lastTauntIndex) { - say $ snd tauntStage; + say taunt } {}; appear "o" (inl ()); @@ -115,7 +117,7 @@ place reward; } { swap reward; - return (); + pure (); }; baseloc <- as base {whereami}; diff --git a/data/scenarios/Challenges/_gopher/solution.sw b/data/scenarios/Challenges/_gopher/solution.sw --- a/data/scenarios/Challenges/_gopher/solution.sw +++ b/data/scenarios/Challenges/_gopher/solution.sw @@ -34,15 +34,15 @@ let d = getDirection n in out <- scan d; shouldContinue <- case out - (\_. return true) + (\_. pure true) (\x. if (x == "mound") { drill d; - return true; + pure true; } { // A "flower" shall serve as // a semaphore to terminate the loop, // so that the base can `salvage` us. - return $ x != "flower"; + pure $ x != "flower"; }); if shouldContinue { @@ -58,7 +58,7 @@ def deploySensor = _s <- build {scanDirections 0}; - return (); + pure (); end; def isDivisibleBy = \dividend. \divisor. @@ -100,13 +100,13 @@ def pickupToolkit = x <- scan down; case x - (\_. return false) + (\_. pure false) (\y. if (y == "toolkit") { tk <- grab; equip tk; - return true + pure true } { - return false + pure false }); end; diff --git a/data/scenarios/Challenges/_hackman/ghost.sw b/data/scenarios/Challenges/_hackman/ghost.sw --- a/data/scenarios/Challenges/_hackman/ghost.sw +++ b/data/scenarios/Challenges/_hackman/ghost.sw @@ -6,7 +6,7 @@ def isItemInDirection = \direction. \item. x <- scan direction; - return $ case x (\_. false) (\y. y == item); + pure $ case x (\_. false) (\y. y == item); end; // A ghost is not blocked by a "gate" when it is leaving the "nursery". @@ -14,27 +14,27 @@ isGate <- isItemInDirection forward "gate"; loc <- whereami; let amCentered = loc == (0, 0) in - return $ isGate && amCentered; + pure $ isGate && amCentered; end; def isBlockedAhead = isBlockedByWall <- blocked; ghostCanCrossGate <- canCrossGate; - return $ isBlockedByWall && not ghostCanCrossGate; + pure $ isBlockedByWall && not ghostCanCrossGate; end; def checkLeftBlocked = turn left; isBlocked <- isBlockedAhead; turn right; - return isBlocked; + pure isBlocked; end; def checkRightBlocked = turn right; isBlocked <- isBlockedAhead; turn left; - return isBlocked; + pure isBlocked; end; def chooseDirection : Cmd Dir = @@ -43,7 +43,7 @@ forwardBlocked <- isBlockedAhead; if (leftBlocked && rightBlocked && forwardBlocked) { say "Dead end; turning back"; - return back; + pure back; } { // Since we're in the "else" case of all three // being blocked, we know that at least one @@ -51,13 +51,13 @@ // the combinations. if (leftBlocked && rightBlocked) { // Keep going straight - return forward; + pure forward; } { if (leftBlocked && forwardBlocked) { - return right; + pure right; } { if (rightBlocked && forwardBlocked) { - return left; + pure left; } { // Now we have exhaused all of the combinations // of *two* directions being blocked, so we @@ -67,30 +67,30 @@ // Decide whether to go right or straight d <- random 2; if (d == 0) { - return right; + pure right; } { // go straight - return forward; + pure forward; } } { if rightBlocked { // Decide whether to go left or straight d <- random 2; if (d == 0) { - return left; + pure left; } { // go straight - return forward; + pure forward; } } { if forwardBlocked { // Decide whether to go left or right d <- random 2; if (d == 0) { - return left; + pure left; } { // go right - return right; + pure right; } } { // No directions are blocked, so we can @@ -99,13 +99,13 @@ d <- random 3; if (d == 0) { - return left; + pure left; } { if (d == 1) { - return right; + pure right; } { // go straight - return forward; + pure forward; } } } diff --git a/data/scenarios/Challenges/_hackman/solution.sw b/data/scenarios/Challenges/_hackman/solution.sw --- a/data/scenarios/Challenges/_hackman/solution.sw +++ b/data/scenarios/Challenges/_hackman/solution.sw @@ -3,7 +3,7 @@ def tryGrab = try { grab; - return (); + pure (); } {}; end; @@ -12,7 +12,7 @@ if hasPowerup { r <- meet; case r - (\_. return ()) + (\_. pure ()) (\r. give r thing; wait 10); } {}; end; diff --git a/data/scenarios/Challenges/_hackman/teleport_monitor.sw b/data/scenarios/Challenges/_hackman/teleport_monitor.sw --- a/data/scenarios/Challenges/_hackman/teleport_monitor.sw +++ b/data/scenarios/Challenges/_hackman/teleport_monitor.sw @@ -12,7 +12,9 @@ def go = \lastBasePos. wait 1; curBasePos <- getBasePos; - let deltaX = abs(fst curBasePos - fst lastBasePos) in + match curBasePos \curx. \_. + match lastBasePos \lastx. \_. + let deltaX = abs (curx - lastx) in if (deltaX > 1) { create "bit (0)"; } {go curBasePos}; diff --git a/data/scenarios/Challenges/_hanoi/hanoi-count.sw b/data/scenarios/Challenges/_hanoi/hanoi-count.sw --- a/data/scenarios/Challenges/_hanoi/hanoi-count.sw +++ b/data/scenarios/Challenges/_hanoi/hanoi-count.sw @@ -9,7 +9,7 @@ def cscan = \d. s <- scan d; - if (s == inl ()) {return 0} {return 1} + if (s == inl ()) {pure 0} {pure 1} end; def count_column = @@ -24,7 +24,7 @@ // wait 8; // log (format k); // wait 8; - return (i + j + k) + pure (i + j + k) end; @@ -47,7 +47,7 @@ // log (format y); // wait 8; // log (format z); - return $ i2e (x + y + z) + pure $ i2e (x + y + z) }; //let sum = i2e (x + y + z) in teleport self (0,-6); @@ -57,6 +57,6 @@ case counted (\e. fail $ "Fatal error: there should always be a count entity at (0,-6)! " ++ format e ++ " " ++ format counted ) (\e. - if (e == sum) {} {swap sum; return ()} + if (e == sum) {} {swap sum; pure ()} ) } diff --git a/data/scenarios/Challenges/_hanoi/hanoi-increasing.sw b/data/scenarios/Challenges/_hanoi/hanoi-increasing.sw --- a/data/scenarios/Challenges/_hanoi/hanoi-increasing.sw +++ b/data/scenarios/Challenges/_hanoi/hanoi-increasing.sw @@ -24,8 +24,9 @@ end; w <- whereami; +match w \wx. \wy. // the middle of the column -let a = (fst w, snd w + 3) in +let a = (wx, wy + 3) in repeat ( o <- as self { teleport self a; @@ -34,15 +35,15 @@ z <- scan north; if (z == null) { if (y == null) { - return true + pure true } { - return $ f x y + pure $ f x y } } { - return $ f x y && f y z + pure $ f x y && f y z } }; try { - if o {place "OK"} {grab; return ()} + if o {place "OK"} {grab; pure ()} } {} ) diff --git a/data/scenarios/Challenges/_hanoi/hanoi-invariant.sw b/data/scenarios/Challenges/_hanoi/hanoi-invariant.sw --- a/data/scenarios/Challenges/_hanoi/hanoi-invariant.sw +++ b/data/scenarios/Challenges/_hanoi/hanoi-invariant.sw @@ -10,7 +10,7 @@ repeat ( me <- scan down; -case me (\_. return ()) (\e. +case me (\_. pure ()) (\e. // if // 0. I stand on unlocked X // 1. place north of me is NOT empty @@ -25,13 +25,13 @@ case mn (\_. teleport self (0,-6); allPlaced <- ishere "three"; - return (not allPlaced) + pure (not allPlaced) ) (\_. - return true + pure true ); }; if northFullOrAllPlaced { - swap ("blocked " ++ e); return () + swap ("blocked " ++ e); pure () } {} } // if @@ -56,9 +56,9 @@ o2 <- ishere "OK"; teleport self (2,-5); o3 <- ishere "OK"; - return (o1 && o2 && o3) + pure (o1 && o2 && o3) }; - if (allPlaced && allSorted) {swap (unlock e); return ()} {} - ) (\_. return ()) + if (allPlaced && allSorted) {swap (unlock e); pure ()} {} + ) (\_. pure ()) } )) diff --git a/data/scenarios/Challenges/_hanoi/hanoi-solution.sw b/data/scenarios/Challenges/_hanoi/hanoi-solution.sw --- a/data/scenarios/Challenges/_hanoi/hanoi-solution.sw +++ b/data/scenarios/Challenges/_hanoi/hanoi-solution.sw @@ -4,12 +4,12 @@ def ifC = \p. \t. \e. res <- p; if res t e end; def orC = \c1. \c2. - b1 <- c1; b2 <- c2; return (b1 || b2) + b1 <- c1; b2 <- c2; pure (b1 || b2) end; def somethingHere = res <- scan down; - return (res != inl ()) + pure (res != inl ()) end; def fwdToThing = until blocked move end; @@ -26,7 +26,7 @@ fwdToThing; d <- grab; goBack; - return d + pure d end; def placeDisk = \d. @@ -49,7 +49,7 @@ Int -> // The offset to third column Cmd Int = \n. \o. \a. \b. \c. - if (n == 0) {return o} + if (n == 0) {pure o} { o_new <- hanoi (n-1) o a c b; moveToCol o_new a; diff --git a/data/scenarios/Challenges/_ice-cream/customer.sw b/data/scenarios/Challenges/_ice-cream/customer.sw --- a/data/scenarios/Challenges/_ice-cream/customer.sw +++ b/data/scenarios/Challenges/_ice-cream/customer.sw @@ -11,13 +11,13 @@ scoopCountExtra <- random 4000; let scoopCount = 1000 + scoopCountExtra in say $ format scoopCount ++ " scoops of vanilla ice cream, no more, no less! And top it with a cherry, please."; - return scoopCount; + pure scoopCount; end; def waitForItem = \item. hasItem <- has item; if hasItem { - return (); + pure (); } { wait 1; waitForItem item; diff --git a/data/scenarios/Challenges/_ice-cream/solution.sw b/data/scenarios/Challenges/_ice-cream/solution.sw --- a/data/scenarios/Challenges/_ice-cream/solution.sw +++ b/data/scenarios/Challenges/_ice-cream/solution.sw @@ -30,12 +30,12 @@ move; move; turn right; - return (cone, cherry); + pure (cone, cherry); end; def meetCustomer = maybeCustomer <- meet; - case maybeCustomer (\_. meetCustomer) return; + case maybeCustomer (\_. meetCustomer) pure; end; def serveScoop = \customer. @@ -55,11 +55,10 @@ def runSolution = \targetRemainingIngredientCount. getBriefcase; coneAndCherry <- getIngredients; + match coneAndCherry \cone. \cherry. getCounter; customer <- meetCustomer; - let cone = fst coneAndCherry in - let cherry = snd coneAndCherry in serveCustomer cone customer; scoopUntil customer targetRemainingIngredientCount; give customer cherry; diff --git a/data/scenarios/Challenges/_lights-out/assistant.sw b/data/scenarios/Challenges/_lights-out/assistant.sw --- a/data/scenarios/Challenges/_lights-out/assistant.sw +++ b/data/scenarios/Challenges/_lights-out/assistant.sw @@ -24,18 +24,20 @@ } {}; end; -def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); - end; +def λmatch = \f. \p. match p f end -def mapTuple = \f. \t. - (f $ fst t, f $ snd t) +def sumTuples = + λmatch \t11. \t12. + λmatch \t21. \t22. + (t11 + t21, t12 + t22); end; +def mapTuple = \f. λmatch \a. \b. (f a, f b) end; + def replaceWith = \withThis. create withThis; swap withThis; - return (); + pure (); end; /** Modifies the cell */ @@ -49,7 +51,7 @@ def toggleLightHere = entHere <- scan down; - case entHere return invertLight; + case entHere pure invertLight; end; /** Precondition: in the middle of a "cross" */ @@ -79,7 +81,7 @@ def togglePending = \state. let pendingEntityName = "pending-" ++ state in maybePending <- detect pendingEntityName ((1, 1), (6, 6)); - case maybePending return $ flipSelfAndNeighbors state; + case maybePending pure $ flipSelfAndNeighbors state; end; def observe = @@ -134,15 +136,16 @@ def advanceRowViaTeleport = curLoc <- whereami; - teleport self (0, snd curLoc - 1); + match curLoc \_. \y. + teleport self (0, y - 1); end; def shouldCorrectTile : (Bool * Bool) -> (Bool * Bool) -> Cmd Bool = \evenOverlaps. \isQuietTiles. if (evenOverlaps == isQuietTiles) { toggleLightHere; - return true; + pure true; } { - return false; + pure false; } end; @@ -161,18 +164,18 @@ shouldAbort <- abortFunc quietTuple; if shouldAbort { - return ((0, 0), true); + pure ((0, 0), true); } { let quietCellOn = mapTuple (\x. x && isCurrentlyOn) quietTuple in let addend = mapTuple boolToInt quietCellOn in move; retval <- prepareBoardRow abortFunc rowIdx $ colIdx - 1; - let subTotal = fst retval in - return $ (sumTuples addend subTotal, snd retval); + match retval \subTotal. \b. + pure (sumTuples addend subTotal, b); } } { - return ((0, 0), false); + pure ((0, 0), false); } end; @@ -182,25 +185,24 @@ def prepareBoardAllRows = \abortFunc. \boardWidth. \rowIdx. if (rowIdx >= 0) { retval <- prepareBoardRow abortFunc rowIdx $ boardWidth - 1; - let rowCommonCount = fst retval in - let shouldAbort = snd retval in + match retval \rowCommonCount. \shouldAbort. if shouldAbort { - return (0, 0); + pure (0, 0); } { advanceRowViaTeleport; totalCommonCount <- prepareBoardAllRows abortFunc boardWidth $ rowIdx - 1; - return $ sumTuples rowCommonCount totalCommonCount + pure $ sumTuples rowCommonCount totalCommonCount } } { - return (0, 0); + pure (0, 0); } end; def checkIsSolvable = \boardWidth. \boardHeight. - overlapCounts <- prepareBoardAllRows (\_. return false) boardWidth $ boardHeight - 1; + overlapCounts <- prepareBoardAllRows (\_. pure false) boardWidth $ boardHeight - 1; // say $ "Overlap counts: " ++ format overlapCounts; - return $ mapTuple isEven overlapCounts; + pure $ mapTuple isEven overlapCounts; end; /** Teleports to a new location to execute a function @@ -212,7 +214,7 @@ teleport self newLoc; retval <- f; teleport self prevLoc; - return retval; + pure retval; end; def analyzeSolvability : Int -> Int -> Cmd (Bool * Bool) = \boardWidth. \boardHeight. @@ -227,12 +229,13 @@ end; def ensureSolvability = \evenOverlaps. \boardWidth. \boardHeight. - let isSolvable = fst evenOverlaps && snd evenOverlaps in + match evenOverlaps \a. \b. + let isSolvable = a && b in // say $ "isSolvable: " ++ format isSolvable; if isSolvable {} { atLocation (0, 0) $ prepareBoardAllRows (shouldCorrectTile $ mapTuple not evenOverlaps) boardWidth $ boardHeight - 1; - return () + pure () } end; diff --git a/data/scenarios/Challenges/_lights-out/solution.sw b/data/scenarios/Challenges/_lights-out/solution.sw --- a/data/scenarios/Challenges/_lights-out/solution.sw +++ b/data/scenarios/Challenges/_lights-out/solution.sw @@ -12,7 +12,7 @@ /** Precondition: facing "d" direction */ def toggleToDark = \d. onHere <- ishere "on"; - if onHere {drill d; return ()} {}; + if onHere {drill d; pure ()} {}; end; def visitSingleRow = \rowWidth. \d. @@ -48,7 +48,7 @@ def onInDirection = \d. entHere <- scan d; - return $ case entHere (\_. false) (\e. e == "on"); + pure $ case entHere (\_. false) (\e. e == "on"); end; /** diff --git a/data/scenarios/Challenges/_maypole/monitor.sw b/data/scenarios/Challenges/_maypole/monitor.sw --- a/data/scenarios/Challenges/_maypole/monitor.sw +++ b/data/scenarios/Challenges/_maypole/monitor.sw @@ -6,6 +6,8 @@ i - m * (i / m) end +def λmatch = \f. \p. match p f end + /* Quadrants are numbered counter-clockwise, staring in the northeast: | @@ -17,12 +19,9 @@ This is same as the standard graph quadrants in mathematics, except for 0-based numbering rather than 1-based. */ -def getQuadrant : (Int * Int) -> (Int * Int) -> Int = \baseLoc. \myLoc. - let baseX = fst baseLoc in - let baseY = snd baseLoc in - - let myX = fst myLoc in - let myY = snd myLoc in +def getQuadrant : (Int * Int) -> (Int * Int) -> Int = + λmatch \baseX. \baseY. + λmatch \myX. \myY. let isUp = myY < baseY in let isRight = myX < baseX in @@ -55,7 +54,7 @@ def getCurrentQuadrant : (Int * Int) -> Cmd Int = \myLoc. baseLoc <- as base {whereami}; - return $ getQuadrant baseLoc myLoc; + pure $ getQuadrant baseLoc myLoc; end; def checkNewQuadrant = \myLoc. \prevQuadrant. \quadrantTraversalCount. @@ -65,9 +64,9 @@ if (changeCount != 0) { swap $ "maypole " ++ format currentQuadrant; - return (); + pure (); } {}; - return (currentQuadrant, newQuadrantCount); + pure (currentQuadrant, newQuadrantCount); end; /* @@ -83,15 +82,14 @@ def monitorAngle : (Int * Int) -> Int -> Int -> Int -> Cmd Unit = \myLoc. \targetQuadrantCount. \prevQuadrant. \quadrantTraversalCount. result <- instant $ checkNewQuadrant myLoc prevQuadrant quadrantTraversalCount; - let currentQuadrant = fst result in - let newQuadrantCount = snd result in + match result \currentQuadrant. \newQuadrantCount. if (newQuadrantCount < targetQuadrantCount) { monitorAngle myLoc targetQuadrantCount currentQuadrant newQuadrantCount; } { create "dizzy"; swap "bitcoin"; - return (); + pure (); } end; diff --git a/data/scenarios/Challenges/_telephone/judge.sw b/data/scenarios/Challenges/_telephone/judge.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_telephone/judge.sw @@ -0,0 +1,82 @@ +def forever: ∀ a b. {Cmd a} -> Cmd b = \c. force c; forever c end + +def x : Int -> Cmd a -> Cmd Unit = \n. \c. + if (n == 0) {} {c; x (n-1) c} +end + +def andC : Cmd Bool -> Cmd Bool -> Cmd Bool = \c1. \c2. + b1 <- c1; + if b1 {c2} {pure false} +end + +tydef List a = rec l. Unit + a * l end + +def for : Int -> (Int -> Cmd a) -> Cmd (List a) = \n. \k. + if (n == 0) + { pure $ inl () } + { x <- k (n-1); + xs <- for (n-1) k; + pure (inr (x,xs)) + } +end + +def readRow : Cmd (List (Unit + Text)) = + r <- for 8 (\_. s <- scan down; move; pure s); + turn back; x 8 move; turn right; move; turn right; + pure r +end + +tydef Rect = List (List (Unit + Text)) end + +def readRect : Cmd Rect = + lst <- for 4 (\_. readRow); + turn right; x 4 move; turn left; + pure lst +end + +def checkCell : Unit + Text -> Cmd Bool = \pat. + actual <- scan down; + move; + pure (actual == pat) +end + +def λmatch = \f. \p. match p f end +def λcase = \f. \g. \s. case s f g end + +def checkRow : List (Unit + Text) -> Cmd Bool = λcase + (\_. turn back; x 8 move; turn right; move; turn right; pure true) + (λmatch \hd. \tl. andC (checkCell hd) (checkRow tl)) +end + +def checkRect : Rect -> Cmd Bool = λcase + (\_. pure true) + (λmatch \hd. \tl. andC (checkRow hd) (checkRect tl)) +end + +def check : Rect -> Cmd Unit = \rect. + log "check!"; + origLoc <- whereami; + teleport self (53, -8); + b <- checkRect rect; + if b {create "X"} {}; + teleport self origLoc; turn east; +end + +def judge = + instant ( + loc <- whereami; + match loc \locx. \locy. + for 4 (\y. + for 8 (\x. + surveil (locx + x, locy + y) + ) + ); + ); + wait 1024; + instant ( + rect <- readRect; + check rect; + ) +end + +forever {judge}; diff --git a/data/scenarios/Challenges/_telephone/photocopier.sw b/data/scenarios/Challenges/_telephone/photocopier.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_telephone/photocopier.sw @@ -0,0 +1,32 @@ +def forever: ∀ a b. {Cmd a} -> Cmd b = \c. force c; forever c end + +def X : Int -> Cmd Unit -> Cmd Unit = \n. \c. + if (n == 0) {} {c; X (n-1) c} +end + +def pixel : (Int * Int) * Text -> Cmd Unit = \instr. + match instr \loc. \ty. + match loc \x. \y. + turn back; X 5 move; turn right; X 2 move; + turn west; X x move; turn north; X y move; + place ty; + turn south; X y move; turn east; X x move; + X 5 move; turn right; X 2 move; turn east +end + +def followInstructions : Text -> Cmd Unit = \paper. + try { + let res = read @((Int * Int) * Text) paper + in pixel res + } {} +end + +def copy : Cmd Unit = + watch down; wait 1024; + p <- atomic (b <- isempty; if b {pure ""} {grab}); + if (p == "") {} {followInstructions p} +end + +def go = forever {copy} end + +go; diff --git a/data/scenarios/Challenges/_telephone/shuttle.sw b/data/scenarios/Challenges/_telephone/shuttle.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_telephone/shuttle.sw @@ -0,0 +1,47 @@ +def ifC: ∀ a. Cmd Bool -> {Cmd a} -> {Cmd a} -> Cmd a + = \test. \then. \else. + b <- test; + if b then else +end + +def while: ∀ a. Cmd Bool -> {Cmd a} -> Cmd Unit + = \test. \body. + ifC test {force body; while test body} {} +end + +def forever: ∀ a b. {Cmd a} -> Cmd b = \c. force c; forever c end + +def notC : Cmd Bool -> Cmd Bool = \c. + b <- c; pure (not b) +end + +def or : Cmd Bool -> Cmd Bool -> Cmd Bool = \c1. \c2. + ifC c1 {pure true} {c2} +end + +def followTrack : Cmd Unit = + move; + while (or (isHere "track") (isHere "mountain")) { move }; + turn back; +end + +def pickup : Cmd Text = + atomic (b <- isempty; if b {pure ""} {grab}); +end + +def dropoff : Text -> Cmd Bool = \thing. + atomic (b <- isempty; if b {place thing} {}; pure b) +end + +def deliver : Text -> Cmd Unit = \thing. + move; + followTrack; + if (thing == "") {} + { + while (notC (dropoff thing)) { followTrack; followTrack } + }; +end + +def go = forever {followTrack; thing <- pickup; deliver thing} end + +go; diff --git a/data/scenarios/Challenges/_telephone/solution.sw b/data/scenarios/Challenges/_telephone/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_telephone/solution.sw @@ -0,0 +1,77 @@ +def x : Int -> Cmd a -> Cmd Unit = \n. \c. + if (n == 0) {} {c; x (n-1) c} +end + +def ifC: ∀ a. Cmd Bool -> {Cmd a} -> {Cmd a} -> Cmd a + = \test. \then. \else. + b <- test; + if b then else +end + +def while: ∀ a. Cmd Bool -> {Cmd a} -> Cmd Unit + = \test. \body. + ifC test {force body; while test body} {} +end + +def for : Int -> (Int -> Cmd a) -> Cmd Unit = \n. \k. + if (n == 0) {} {k n; for (n-1) k} +end + +def harvestMay = + e <- isempty; + if e {} {harvest; pure ()} +end + +def harvestTrees = + turn back; move; turn left; x 5 move; + turn left; + x 5 (x 10 (harvestMay; move); turn back; x 10 move; turn left; move; turn left); + turn left; x 10 move; turn right; move +end + +def getWater = + turn back; x 3 move; turn left; move; + x 32 grab; + turn back; move; turn right; x 3 move +end + +def getPaper = + harvestTrees; + while (has "tree") {make "log"}; + x 2 (make "board"); make "boat"; equip "boat"; + getWater; x 4 (make "paper") +end + +def scanAt : Int -> Int -> Cmd (Unit + Text) = \h. \v. + x h move; turn right; x v move; + s <- scan down; + turn back; x v move; turn left; x h move; turn back; + pure s +end + +def atTerminal : Cmd a -> Cmd a = \c. + x 12 move; turn left; x 2 move; + a <- c; + turn back; x 2 move; turn right; x 12 move; turn back; + pure a +end + +def waitToPlace : Text -> Cmd Unit = \t. + success <- atomic (b <- isempty; if b {place t} {}; pure b); + if success {} { watch down; wait 1024; waitToPlace t } +end + +def go = + getPaper; + x 2 move; turn left; x 4 move; + for 8 (\h. + for 4 (\v. + res <- scanAt (h-1) (v-1); + case res + (\_. pure ()) + (\t. atTerminal (p <- print "paper" (format ((h-1,v-1),t)); waitToPlace p)) + ) + ) +end + +go; diff --git a/data/scenarios/Challenges/_wolf-goat-cabbage/multi-item-possession.sw b/data/scenarios/Challenges/_wolf-goat-cabbage/multi-item-possession.sw --- a/data/scenarios/Challenges/_wolf-goat-cabbage/multi-item-possession.sw +++ b/data/scenarios/Challenges/_wolf-goat-cabbage/multi-item-possession.sw @@ -1,4 +1,4 @@ has_wolf <- has "wolf"; has_goat <- has "goat"; has_cabbage <- has "cabbage"; -return $ (has_wolf && has_goat) || (has_goat && has_cabbage) || (has_wolf && has_cabbage); +pure $ (has_wolf && has_goat) || (has_goat && has_cabbage) || (has_wolf && has_cabbage); diff --git a/data/scenarios/Challenges/_wolf-goat-cabbage/together-on-east-bank.sw b/data/scenarios/Challenges/_wolf-goat-cabbage/together-on-east-bank.sw --- a/data/scenarios/Challenges/_wolf-goat-cabbage/together-on-east-bank.sw +++ b/data/scenarios/Challenges/_wolf-goat-cabbage/together-on-east-bank.sw @@ -1,7 +1,8 @@ def get_x_coord = \r. as r { pos <- whereami; - return $ fst pos; + match pos \x. \_. + pure x }; end; @@ -10,16 +11,16 @@ thisX <- get_x_coord r; as r { - try {grab; return ()} {}; + try {grab; pure ()} {}; move; - try {grab; return ()} {}; + try {grab; pure ()} {}; move; - try {grab; return ()} {}; + try {grab; pure ()} {}; has_wolf <- has "wolf"; has_goat <- has "goat"; has_cabbage <- has "cabbage"; - return $ baseX == thisX && has_wolf && has_goat && has_cabbage; + pure $ baseX == thisX && has_wolf && has_goat && has_cabbage; }; end; diff --git a/data/scenarios/Challenges/_wolf-goat-cabbage/unattended-together.sw b/data/scenarios/Challenges/_wolf-goat-cabbage/unattended-together.sw --- a/data/scenarios/Challenges/_wolf-goat-cabbage/unattended-together.sw +++ b/data/scenarios/Challenges/_wolf-goat-cabbage/unattended-together.sw @@ -1,7 +1,8 @@ def get_x_coord = \r. as r { pos <- whereami; - return $ fst pos; + match pos \x. \_. + pure x; }; end; @@ -10,20 +11,20 @@ thisX <- get_x_coord r; if (baseX == thisX) { - return false; + pure false; } { as r { - try {grab; return ()} {}; + try {grab; pure ()} {}; move; - try {grab; return ()} {}; + try {grab; pure ()} {}; move; - try {grab; return ()} {}; + try {grab; pure ()} {}; has_wolf <- has "wolf"; has_goat <- has "goat"; has_cabbage <- has "cabbage"; - return $ (has_wolf && has_goat) || (has_goat && has_cabbage); - }; + pure $ (has_wolf && has_goat) || (has_goat && has_cabbage); + }; } end; @@ -32,4 +33,4 @@ west_bad <- is_unattended_together baseX "west_detector"; east_bad <- is_unattended_together baseX "east_detector"; -return $ west_bad || east_bad; +pure $ west_bad || east_bad; diff --git a/data/scenarios/Challenges/_word-search/create-puzzle.sw b/data/scenarios/Challenges/_word-search/create-puzzle.sw --- a/data/scenarios/Challenges/_word-search/create-puzzle.sw +++ b/data/scenarios/Challenges/_word-search/create-puzzle.sw @@ -11,15 +11,15 @@ def whichOrdinal = \str. if (str == "capital C") { - return 0; + pure 0; } { if (str == "capital O") { - return 1; + pure 1; } { if (str == "capital W") { - return 2; + pure 2; } { - return (-1); + pure (-1); } } } @@ -30,7 +30,7 @@ */ def getAdjacentOrdinal = \d. maybeEntity <- scan d; - str <- case maybeEntity (\_. return "") (\s. return s); + str <- case maybeEntity (\_. pure "") (\s. pure s); whichOrdinal str; end; @@ -48,12 +48,12 @@ def chooseLetter = \i. if (i == 0) { - return "capital C"; + pure "capital C"; } { if (i == 1) { - return "capital O"; + pure "capital O"; } { - return "capital W"; + pure "capital W"; } }; end; @@ -68,21 +68,22 @@ northOrdinal <- getAdjacentOrdinal north; if (northOrdinal == 1) { currentLoc <- whereami; - teleport self (fst currentLoc, snd currentLoc + 1); + match currentLoc \x. \y. + teleport self (x, y + 1); doubleNorthOrdinal <- getAdjacentOrdinal north; teleport self currentLoc; if (doubleNorthOrdinal == 2) { - return 0; + pure 0; } { if (doubleNorthOrdinal == 0) { - return 2; + pure 2; } { - return (-1); + pure (-1); } } } { - return (-1); + pure (-1); } end; @@ -106,18 +107,18 @@ if excludeZero { if (excludedVertical == 2) { - return 1; + pure 1; } { // Zero is the only excluded value, // so just offset a choice between 0 and 1 upward by 1, // to make it a choice between 1 and 2. val <- random 2; - return $ val + 1; + pure $ val + 1; }; } { if excludeTwo { if (excludedVertical == 0) { - return 1; + pure 1; } { // Two is the only excluded value, // so make it a choice between 0 and 1. @@ -129,7 +130,7 @@ // so just offset a choice between 0 and 1 upward by 1, // to make it a choice between 1 and 2. val <- random 2; - return $ val + 1; + pure $ val + 1; } { if (excludedVertical == 2) { // Two is the only excluded value, @@ -150,12 +151,13 @@ letterIndex <- reRoll excludedVertical expectedFwdOrdinal expectedBkwdOrdinal; chosenLetter <- chooseLetter letterIndex; place chosenLetter; - return letterIndex; + pure letterIndex; end; def crossBack = \_n. currentLoc <- whereami; - teleport self (0, snd currentLoc - 1); + match currentLoc \_. \y. + teleport self (0, y - 1); end; /** @@ -169,15 +171,15 @@ move; newFwdOrdinal <- if (placedIndex == expectedFwdOrdinal || placedIndex == 0) { - return $ placedIndex + 1; + pure $ placedIndex + 1; } { - return 0; + pure 0; }; newBkwdOrdinal <- if (placedIndex == expectedBkwdOrdinal || placedIndex == 2) { - return $ placedIndex - 1; + pure $ placedIndex - 1; } { - return 2; + pure 2; }; layTilesRow newFwdOrdinal newBkwdOrdinal $ n - 1; @@ -191,7 +193,8 @@ def removeBoulder = baseLoc <- as base {whereami}; - teleport self (fst baseLoc - 1, snd baseLoc); + match baseLoc \x. \y. + teleport self (x - 1, y); // Remove the boulder blocking the player's path grab; diff --git a/data/scenarios/Challenges/_word-search/solution.sw b/data/scenarios/Challenges/_word-search/solution.sw --- a/data/scenarios/Challenges/_word-search/solution.sw +++ b/data/scenarios/Challenges/_word-search/solution.sw @@ -20,17 +20,17 @@ def whichOrdinal = isC <- ishere "capital C"; if (isC) { - return 0; + pure 0; } { isO <- ishere "capital O"; if (isO) { - return 1; + pure 1; } { isW <- ishere "capital W"; if (isW) { - return 2; + pure 2; } { - return (-1); + pure (-1); } } } @@ -39,9 +39,10 @@ // Go to upper-left corner def goToCorner = myLoc <- whereami; - doN (fst myLoc) move; + match myLoc \x. \y. + doN x move; turn right; - doN (-(snd myLoc)) move; + doN (-y) move; turn right; end; @@ -57,23 +58,23 @@ // considered a "match". let shouldAdvance = theFoundOrdinal == expectedOrdinal || theFoundOrdinal == 0 in newExpectedOrdinal <- if shouldAdvance { - return $ theFoundOrdinal + 1; + pure $ theFoundOrdinal + 1; } { // Reset the progress - return 0; + pure 0; }; if (newExpectedOrdinal == 3) { turn back; intersperse 3 move highlightLetter; - return true; + pure true; } { if (colCount > 1) { move; traverseRow newExpectedOrdinal (colCount - 1); } { - return false; + pure false; }; }; end; @@ -92,18 +93,18 @@ def traverseCols = \width. \height. didWin <- traverseRow 0 width; if didWin { - return true; + pure true; } { turn back; didWinBackward <- traverseRow 0 width; if didWinBackward { - return true; + pure true; } { if (height > 1) { advanceRow; traverseCols width $ height - 1; } { - return false; + pure false; }; } } @@ -115,7 +116,7 @@ wonHorizontally <- traverseCols boardWidth boardHeight; if wonHorizontally { - return true; + pure true; } { // If we did not find a horizontal solution, // look for vertical solutions. diff --git a/data/scenarios/Challenges/arbitrage.yaml b/data/scenarios/Challenges/arbitrage.yaml --- a/data/scenarios/Challenges/arbitrage.yaml +++ b/data/scenarios/Challenges/arbitrage.yaml @@ -20,7 +20,7 @@ condition: | as base { pcount <- count "paperclip"; - return $ pcount >= 100; + pure $ pcount >= 100; }; - teaser: Beginner capital goal: @@ -32,7 +32,7 @@ condition: | as base { pcount <- count "paperclip"; - return $ pcount >= 20; + pure $ pcount >= 20; }; attrs: - name: shopA @@ -381,7 +381,6 @@ dsl: | {dirt} upperleft: [0, 0] - offset: false palette: '.': [grass] '*': [stone] diff --git a/data/scenarios/Challenges/blender.yaml b/data/scenarios/Challenges/blender.yaml --- a/data/scenarios/Challenges/blender.yaml +++ b/data/scenarios/Challenges/blender.yaml @@ -28,12 +28,12 @@ let basename = "base" in x <- as r {whoami}; if (x == basename) { - return false; + pure false; } { mr0 <- as r {meet}; case mr0 - (\_. return false) - (\bot. name <- as bot {whoami}; return $ name == basename); + (\_. pure false) + (\bot. name <- as bot {whoami}; pure $ name == basename); }; end; @@ -52,11 +52,11 @@ let foo = intermediate in let newIdx = idx + 1 in recursiveResult <- anyHasMetBase newIdx; - return $ foo || recursiveResult; + pure $ foo || recursiveResult; } { // Terminates the recursion on the // lowest index at which a robot does not exist - return false; + pure false; }; end; @@ -193,7 +193,6 @@ dsl: | {stone, water} upperleft: [0, 0] - offset: false palette: '0': [stone, water] '@': [stone, granite boulder] diff --git a/data/scenarios/Challenges/bridge-building.yaml b/data/scenarios/Challenges/bridge-building.yaml --- a/data/scenarios/Challenges/bridge-building.yaml +++ b/data/scenarios/Challenges/bridge-building.yaml @@ -71,8 +71,8 @@ condition: | as base { c <- whereami; - let x = fst c in - return $ x >= 1 && x <= 2 && snd c == -30; + match c \x. \y. + pure $ x >= 1 && x <= 2 && y == -30; }; - id: get_pebble teaser: Off-piste diff --git a/data/scenarios/Challenges/bucket-brigade.yaml b/data/scenarios/Challenges/bucket-brigade.yaml --- a/data/scenarios/Challenges/bucket-brigade.yaml +++ b/data/scenarios/Challenges/bucket-brigade.yaml @@ -79,6 +79,27 @@ solution: | run "scenarios/Challenges/_bucket-brigade/brigade.sw" entities: + - name: upper left corner + display: + attr: entity + char: '┌' + description: + - Upper left corner. + properties: [unwalkable, known] + - name: upper right corner + display: + attr: entity + char: '┐' + description: + - An upper right corner wall. + properties: [unwalkable, known] + - name: vertical wall + display: + attr: entity + char: '│' + description: + - A vertical wall. + properties: [unwalkable, known] - name: bucketwheel excavator display: char: 'x' @@ -123,6 +144,12 @@ description: - Kit that can be unpacked into everything a robot needs to reproduce. properties: [known, pickable] + - name: wall + display: + char: '#' + description: + - Unmovable barrier + properties: [known, unwalkable, boundary] recipes: - in: - [1, repro kit] @@ -185,13 +212,11 @@ 'H': [stone, null, hauler] 'Z': [stone, null, powerplant] 'w': [grass] + 'x': [stone, wall] 's': [stone] 'A': [stone, boulder] '┌': [stone, upper left corner] '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] '│': [stone, vertical wall] upperleft: [0, 0] map: |- @@ -203,11 +228,11 @@ ..AA...................... ...A..A...............┌┐.. ..A.................┌┐││.. - .....A.............┌────┐. - ...................│sZss│. - .A.................└────┘. + .....A.............xxxxxx. + ...................xsZssx. + .A.................xxxxxx. .....A......B==========H=. .......................... - .............┌┐.┌──────┐.. - w......A.....└┘.└──────┘.. + .............xx.xxxxxxxx.. + w......A.....xx.xxxxxxxx.. ww........................ diff --git a/data/scenarios/Challenges/chess_horse.yaml b/data/scenarios/Challenges/chess_horse.yaml --- a/data/scenarios/Challenges/chess_horse.yaml +++ b/data/scenarios/Challenges/chess_horse.yaml @@ -12,8 +12,8 @@ bloc <- as base {whereami}; king <- robotNamed "king"; kloc <- as king {whereami}; - return (bloc == kloc) - } { return false } + pure (bloc == kloc) + } { pure false } solution: | move; move; move; turn right; move; turn left; move; robots: @@ -31,6 +31,13 @@ dir: [0, 0] display: char: '♚' +entities: + - name: wall + display: + char: '#' + description: + - Unmovable barrier + properties: [known, unwalkable, boundary] known: [water] world: dsl: | @@ -38,21 +45,16 @@ palette: '.': [grass, erase] '#': [ice, erase] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + 'w': [stone, wall] upperleft: [-1, 1] map: | - ┌────────┐ - │.#.#.#.#│ - │#.#.#.#.│ - │.#.#.#.#│ - │#.#.#.#.│ - │.#.#.#.#│ - │#.#.#.#.│ - │.#.#.#.#│ - │#.#.#.#.│ - └────────┘ + wwwwwwwwww + w.#.#.#.#w + w#.#.#.#.w + w.#.#.#.#w + w#.#.#.#.w + w.#.#.#.#w + w#.#.#.#.w + w.#.#.#.#w + w#.#.#.#.w + wwwwwwwwww diff --git a/data/scenarios/Challenges/combo-lock.yaml b/data/scenarios/Challenges/combo-lock.yaml --- a/data/scenarios/Challenges/combo-lock.yaml +++ b/data/scenarios/Challenges/combo-lock.yaml @@ -106,7 +106,6 @@ dsl: | {water} upperleft: [-1, -1] - offset: false palette: '.': [grass, erase] '$': [grass, bitcoin] diff --git a/data/scenarios/Challenges/dimsum.yaml b/data/scenarios/Challenges/dimsum.yaml --- a/data/scenarios/Challenges/dimsum.yaml +++ b/data/scenarios/Challenges/dimsum.yaml @@ -12,10 +12,14 @@ p <- robotnamed "patron"; as p { foodCount <- count "food"; - return $ foodCount >= 2; + pure $ foodCount >= 2; } solution: | run "scenarios/Challenges/_dimsum/solution.sw" +attrs: + - name: barrier + fg: "#222222" + bg: "#111111" robots: - name: base dir: [1, 0] @@ -73,6 +77,13 @@ program: | run "scenarios/Challenges/_dimsum/patron.sw" entities: + - name: wall + display: + attr: barrier + char: '#' + description: + - Unmovable barrier + properties: [known, unwalkable, boundary] - name: table display: attr: wood @@ -134,7 +145,7 @@ 'B': [grass, erase, base] '.': [grass, erase] 'S': [dirt, erase] - '@': [grass, boulder] + '@': [grass, wall] 'd': [grass, table] 'k': [grass, table, cook] 'p': [grass, table, patron] diff --git a/data/scenarios/Challenges/dna.yaml b/data/scenarios/Challenges/dna.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/dna.yaml @@ -0,0 +1,597 @@ +version: 1 +name: DNA +author: Karl Ostmo +description: | + Copy strands of DNA in the lab to replicate organisms +creative: false +seed: 9 +attrs: + - name: floorattr + bg: "#111111" + - name: wall2 + fg: "#88ee22" + - name: pink + fg: "#ff99bb" + - name: lemon + fg: "#eeee99" + - name: clover + bg: "#225522" + - name: beige + fg: "#f5f5dc" + - name: soup + fg: "#338822" + bg: "#774422" +terrains: + - name: floor + attr: floorattr + description: | + Laboratory floor +objectives: + - id: place_flower + teaser: Place subject + goal: + - | + The laboratory building ahead is neatly landscaped, though + its decorative `pond`{=structure} exudes a peculiar quality. + There may be a device you can `use` to sample its contents. + + The DNA lab has two large apparatus inside. + The first is a `DNA sequencer`{=structure} that + determines the arrangement of ATCG pairs within an `organism`{=tag}'s genome. + + The `DNA decoder`{=structure} in the lab's south wing can reconstitute + an `organism`{=tag} from its genome. + + To get started, borrow a `dahlia`{=entity} from the flowerbed at the lab + entrance and place it in the receptacle directly to your east. + condition: | + r <- robotnamed "lab"; + as r { + has "pixel (G)"; + } + - id: place_complements + teaser: Complement strand + prerequisite: place_flower + goal: + - | + The `DNA sequencer`{=structure} will begin to decode the subject's DNA. + The subject will be dematerialized once the top row + of the "double helix" has been decoded. + + You must then complete the double helix (fill in the second row within the device) + with complementary base pairs. + Use your `soup strainer`{=entity} to obtain ingredients. + Consult your *Compendium* for appropriate pairings. + + Note that `scan`ning has a cost, and you have a limited supply of + `specimen slide`{=entity}s (in a `slide box`{=entity}) with which to + `scan` DNA bases using your `microscope`{=entity}. + condition: | + r <- robotnamed "topchecker"; + as r { + has "pixel (G)"; + } + - id: create_clone + prerequisite: place_complements + teaser: Create clone + goal: + - | + Now let's make a clone! Recreate the top half of the + DNA strand in the south wing's `DNA decoder`{=structure} + (you remember the sequence, right?). + + Each element you `place` will be automatically complemented. + + When all segments are placed, `drill` the switch on the western wall to + commence rematerialization. `grab` the clone (once matured) as a souvenir! + condition: | + def λmatch = \f. \p. match p f end + def λcase = \f. \g. \s. case s f g end + + def hasAll : (rec l. Unit + Text * l) -> Cmd Bool = λcase + (\_. pure true) + (λmatch \hd. \tl. b1 <- has hd; if b1 {hasAll tl} {pure false}) + end; + + k <- robotnamed "keeper"; + as k { + let organisms = tagmembers "organism" in + hasAll organisms; + } + - prerequisite: create_clone + teaser: More clones + goal: + - | + Toggle the switch off to reset the lab. + - | + Find three more different `organism`{=tag}s to clone. + Explore outside nearby the lab for specimens. + condition: | + def λmatch = \f. \p. match p f end + def λcase = \f. \g. \s. case s f g end + + def hasCount : (rec l. Unit + Text * l) -> Cmd Int = λcase + (\_. pure 0) + (λmatch \hd. \tl. b <- has hd; n <- hasCount tl; pure (if b {1} {0} + n)) + end; + + k <- robotnamed "keeper"; + as k { + let organisms = tagmembers "organism" in + c <- hasCount organisms; + pure $ c >= 4; + } +robots: + - name: base + dir: east + loc: [-8, 4] + devices: + - antenna + - ADT calculator + - barcode reader + - branch predictor + - comparator + - compass + - dictionary + - feeler + - grabber + - hearing aid + - lambda + - logger + - microscope + - rolex + - siphon + - soup strainer + - strange loop + - switch puller + - treads + - welder + - workbench + inventory: + - [1, slide box] + - name: lab + system: true + dir: east + display: + invisible: true + attr: 'robot' + devices: + - switch puller + inventory: + - [1, branch predictor] + - [1, treads] + - [1, beaglepuss] + - [1, antenna] + - [1, comparator] + - [1, clock] + - [1, workbench] + - [1, grabber] + - [1, ADT calculator] + - [1, dictionary] + - [1, lambda] + - [1, logger] + - [1, welder] + - [1, hearing aid] + - [1, scanner] + - [1, strange loop] + - [1, solar panel] + program: | + run "data/scenarios/Challenges/_dna/lab.sw" + - name: topchecker + system: true + dir: east + display: + invisible: true + attr: 'robot' + program: | + run "data/scenarios/Challenges/_dna/topchecker.sw" + - name: mirrorbot + system: true + dir: south + display: + invisible: true + attr: 'robot' + program: | + run "data/scenarios/Challenges/_dna/mirrorbot.sw" + - name: resetter + description: resets the apparatus after completion by watching the switch + system: true + dir: east + display: + invisible: true + attr: 'robot' + program: | + run "data/scenarios/Challenges/_dna/resetter.sw" + - name: keeper + description: keeps track of cloned specimens + system: true + dir: south + display: + invisible: true + attr: 'robot' +solution: | + run "data/scenarios/Challenges/_dna/solution.sw" +structures: + - name: pond + recognize: + - north + structure: + mask: '.' + palette: + 'x': [grass, rock] + 'w': [dirt, pond broth] + map: | + ...xxxxxxxx.. + ..xwwwwwwwwx. + ..xwwwwwwwwwx + ..xwwwwwwwwwx + .xwwwwwwxxxx. + xwwwwwwx..... + xwwwwwwx..... + .xxxxxx...... + - name: fairy ring + structure: + mask: '.' + palette: + 'm': [grass, mushroom] + map: | + ....mm.m... + ..m........ + .........m. + ..m........ + ...m...m... + - name: receptacle + structure: + mask: '.' + palette: + 'x': [floor, wall] + 'w': [floor, wall2] + 'f': + cell: [floor, erase] + waypoint: + name: receiver + map: | + ww........ + fwxxxxxxxx + ww.x.x.x.x + - name: decoder base + structure: + palette: + '┬': [stone, down and horizontal wall] + '┴': [stone, up and horizontal wall] + ':': [floor, erase] + map: | + ┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬ + :::::::::::::::::::::::::::::::: + :::::::::::::::::::::::::::::::: + ┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴ + - name: copybots overlay + structure: + mask: '.' + palette: + 'm': [floor, erase, mirrorbot] + map: | + ................................ + mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm + ................................ + ................................ + - name: decoder overlay + structure: + mask: '.' + palette: + 'c': [floor, erase, topchecker] + map: | + ................................ + ................................ + c............................... + ................................ + - name: DNA decoder + recognize: + - north + structure: + placements: + - src: decoder base + - src: copybots overlay + - src: receptacle + offset: [18, -4] + orient: + up: south + map: "" + - name: DNA sequencer + recognize: + - north + structure: + placements: + - src: decoder base + - src: decoder overlay + - src: receptacle + offset: [4, 3] + map: "" +entities: + - name: down and horizontal wall + display: + attr: entity + char: '┬' + description: + - A down and horizontal wall. + properties: [unwalkable, known] + - name: up and horizontal wall + display: + attr: entity + char: '┴' + description: + - A up and horizontal wall. + properties: [unwalkable, known] + - name: barcode reader + display: + attr: red + char: 'S' + description: + - Reads the 'tag' of an item + properties: [pickable] + capabilities: [hastag, tagmembers] + - name: dahlia + display: + char: '*' + attr: pink + description: + - Brightly colored flower + properties: [known, pickable, growable] + growth: + duration: [20, 30] + tags: [organism] + - name: daisy + display: + char: 'x' + attr: lemon + description: + - Pretty flower + properties: [pickable, growable] + growth: + duration: [15, 30] + tags: [organism] + - name: clover + display: + char: 'c' + attr: clover + description: + - A tiny, 3-leaf plant + properties: [pickable, growable] + growth: + duration: [10, 20] + tags: [organism] + - name: mushroom + display: + char: 'm' + attr: beige + description: + - Invasive fungus + properties: [pickable, growable] + growth: + duration: [15, 25] + spread: + radius: 2 + density: 0.5 + biomes: [floor, stone] + tags: [organism] + - name: wall2 + display: + char: 'w' + attr: wall2 + description: + - Just a wall + properties: [known, unwalkable, boundary] + - name: primordial soup + display: + char: 's' + attr: soup + description: + - Can be decomposed into nucleic acids + properties: [pickable, liquid] + - name: pond broth + display: + char: 's' + attr: soup + description: + - Can be decomposed into nucleic acids + properties: [pickable, liquid] + - name: soup strainer + display: + char: 'r' + description: + - Extracts nucleic acids from `primordial soup`{=entity} + properties: [known, pickable] + - name: feeler + display: + char: 'm' + description: + - Senses presence of specific entities + properties: [known, pickable] + capabilities: [blocked, ishere, isempty] + - name: microscope + display: + char: 'm' + description: + - Scan for the cost of 1 `specimen slide`{=entity} + properties: [known, pickable] + capabilities: + - capability: scan + cost: + - [1, "specimen slide"] + - name: specimen slide + display: + char: 'i' + attr: device + description: + - Can take a sample of DNA for scanning + - name: slide box + display: + char: 'b' + attr: device + description: + - Contains `specimen slides`{=entity} + - name: guanine + display: + char: 'G' + attr: red + description: + - One of the four nucleobases in DNA. + - Is paired with `cytosine`{=entity}. + properties: [known] + - name: cytosine + display: + char: 'C' + attr: blue + description: + - One of the four nucleobases in DNA. + - Is paired with `guanine`{=entity}. + properties: [known] + - name: adenine + display: + char: 'A' + attr: green + description: + - One of the four nucleobases in DNA. + - Is paired with `thymine`{=entity}. + properties: [known] + - name: thymine + display: + char: 'T' + attr: gold + description: + - One of the four nucleobases in DNA. + - Is paired with `adenine`{=entity}. + properties: [known] + - name: switch (off) + display: + attr: red + char: '•' + description: + - A control in the deactivated position. + properties: [known] + - name: switch (on) + display: + attr: green + char: '•' + description: + - A control in the activated position. + properties: [known] + - name: organic sludge + display: + attr: green + char: 'S' + description: + - A repulsive, shuddering mass of slime. + properties: [pickable] + - name: switch puller + display: + char: 'P' + attr: gold + capabilities: [drill] + description: + - Can pull switches + - name: siphon + display: + char: 's' + attr: device + capabilities: [drill] + description: + - Can retrieve liquid +recipes: + - in: + - [1, slide box] + out: + - [32, specimen slide] + - in: + - [1, primordial soup] + out: + - [4, cytosine] + - [4, guanine] + - [4, adenine] + - [4, thymine] + required: + - [1, soup strainer] + - in: + - [1, switch (off)] + out: + - [1, switch (on)] + required: + - [1, switch puller] + - in: + - [1, switch (on)] + out: + - [1, switch (off)] + required: + - [1, switch puller] + - in: + - [1, pond broth] + out: + - [8, primordial soup] + required: + - [1, siphon] +known: [flower, rock] +world: + dsl: | + let + flowerNoise = perlin seed 1 0.15 0.0, + soupNoise = perlin seed 2 0.04 1.0, + + flowers = flowerNoise > 0.70, + soup = soupNoise > 0.9 + in + overlay + [ {grass} + , mask (flowers && (x - y) % 3 == 0) {daisy} + , mask soup {clover} + ] + upperleft: [-2, 4] + mask: 'q' + palette: + 'z': [stone, wall] + '.': [stone, erase] + 'G': + cell: [stone, erase] + 'o': [stone, erase] + 'd': [dirt, dahlia] + 'v': [stone, erase, lab, keeper] + '0': + cell: [stone, switch (off), resetter] + waypoint: + name: switch + 'D': + structure: + name: DNA decoder + cell: [floor, erase] + 'E': + structure: + name: DNA sequencer + cell: [floor, erase] + placements: + - src: pond + offset: [-17, -10] + - src: fairy ring + offset: [-5, -25] + map: | + dzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz + dzv.........................................z + zzz........oo...............................z + ............o...............................z + zzz........oo...............................z + dz.....Eooooooooooooooooooooooooooooooo.....z + dz.....o..............................o.....z + dz.....o..............................o.....z + dz.....oooooooooooooooooooooooooooooooo.....z + qz..........................................z + qzzzzzzzzz.zzzzzzzzzzzzzzzzzzzzzzzz.zzzzzzzzz + qqqqqqqqqzGzqqqqqqqqqqqqqqqqqqqqqqzGzqqqqqqqq + qzzzzzzzzz.zzzzzzzzzzzzzzzzzzzzzzzz.zzzzzzzzz + qz..........................................z + qzz....D....................................z + qz0.........................................z + qzz.........................................z + qz..........................................z + qz..........................................z + qz..........................................z + qz..........................................z + qz..........................................z + qzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz diff --git a/data/scenarios/Challenges/flower-count.yaml b/data/scenarios/Challenges/flower-count.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/flower-count.yaml @@ -0,0 +1,177 @@ +version: 1 +name: Flower Count +author: Brent Yorgey +description: | + Count the flowers quickly... or else! +creative: false +objectives: + - id: count_flowers + teaser: Count the flowers! + goal: + - | + Your evil nemesis, the sadistic arithmomaniac supervillain Count Nemesis, is + at it again! They have wired up some explosives to your + `True Love`{=robot} and lit the fuse, but promised to stop it... IF you can + count all the flowers in time! + - | + Specifically, Count Nemesis demands that you count the + total number of flowers in the 120x40 field bounded by walls, + `print` the number on a piece of `paper`{=entity}, and place + the paper at the origin, `(0,0)`. If the number is correct, + the countdown stops and your True Love is saved. If the + number is incorrect... nothing happens, but the fuse continues + to burn! + - | + And watch out, Count Nemesis won't abide anyone picking his flowers. + condition: | + judge <- robotNamed "judge"; + as judge { has "gold" } + - id: pick_flower + hidden: true + optional: true + teaser: You just don't listen, do you + goal: + - | + I told you not to pick any flowers! Now your True Love is + dead... because of YOU! + - | + Perhaps you would like to go back in time and try again. + condition: | + f <- as base { has "flower" }; + judge <- robotNamed "judge"; + g <- as judge { has "gold" }; + pure (not g && f) + - id: out_of_time + hidden: true + optional: true + teaser: Not fast enough + goal: + - | + You were not fast enough, and now your True Love is + dead... because of YOU! + - | + Perhaps you would like to go back in time and try again. + condition: | + truelove <- robotNamed "truelove"; + as truelove { b <- ishere "fuse"; pure (not b) } + - id: joinpoint + hidden: true + teaser: Follow instructions! + prerequisite: + logic: + and: + - count_flowers + - not: pick_flower + - not: out_of_time + condition: | + pure true + - id: win + teaser: Give a flower + prerequisite: joinpoint + goal: + - | + Congratulations! You foiled the plan of evil Dr. Nemesis and + saved your True Love! The only thing left is to give your + True Love a `flower`{=entity}! + condition: | + truelove <- robotNamed "truelove"; + as truelove { has "flower" } +solution: | + run "scenarios/Challenges/_flower-count/solution.sw" +robots: + - name: base + dir: north + devices: + - solar panel + - treads + - antenna + - comparator + - ADT calculator + - workbench + - grabber + - dictionary + - lambda + - logger + - welder + - scanner + - strange loop + - typewriter + - 3D printer + - branch predictor + - clock + - GPS receiver + - compass + - counter + inventory: + - [12, solar panel] + - [12, dictionary] + - [12, lambda] + - [12, treads] + - [12, branch predictor] + - [12, comparator] + - [12, hyperloop] + - [12, compass] + - [12, scanner] + - [12, logger] + - [12, GPS receiver] + - [12, string] + - [12, typewriter] + - [12, rubber band] + - [12, grabber] + - [12, parsley] + - [1, paper] + - name: igniter + system: true + dir: east + devices: + - logger + program: 'ignite down' + - name: judge + system: true + dir: east + devices: + - logger + program: | + run "scenarios/Challenges/_flower-count/judge.sw" + - name: truelove + system: true + display: + invisible: false + attr: red + char: '♥' + description: Your One True Love. +attrs: + - name: fuse + fg: '#cccccc' + bg: '#002f00' +entities: + - name: fuse + display: + attr: fuse + char: '-' + description: + - Slow-burning fuse + properties: [combustible, known, boundary] + combustion: + ignition: 20 + duration: [64, 64] + delay: 63 + product: ash +known: [flower, wall, ash] +world: + dsl: | + overlay + [ if (hash % 7 <= 2) then {grass, flower} else {grass} + , mask ((x == 61 || x == (-60)) && y <= 21 && y >= -20) {wall, stone} + , mask ((y == 21 || y == (-20)) && x <= 61 && x >= -60) {wall, stone} + ] + upperleft: [0, 0] + palette: + 'B': [grass, null, base] + 'J': [grass, erase, judge] + '.': [grass] + '-': [grass, fuse] + 'L': [grass, fuse, truelove] + 'I': [grass, fuse, igniter] + map: | + JB..I---------------L diff --git a/data/scenarios/Challenges/friend.yaml b/data/scenarios/Challenges/friend.yaml --- a/data/scenarios/Challenges/friend.yaml +++ b/data/scenarios/Challenges/friend.yaml @@ -63,7 +63,7 @@ c <- robotNamed "cat"; catLoc <- as c {whereami}; baseLoc <- as base {whereami}; - return (catLoc == baseLoc) + pure (catLoc == baseLoc) solution: | run "scenarios/Challenges/_friend/friend-solution.sw" entities: @@ -74,9 +74,8 @@ - A smelly fish. Rather unappetizing to a robot. properties: [known, pickable] known: [fish] -seed: 0 +seed: 1 world: - offset: true palette: 'Ω': [grass, null, base] '.': [stone] diff --git a/data/scenarios/Challenges/gallery.yaml b/data/scenarios/Challenges/gallery.yaml --- a/data/scenarios/Challenges/gallery.yaml +++ b/data/scenarios/Challenges/gallery.yaml @@ -51,27 +51,35 @@ condition: | def ensureMonotonicDecreasing = \itemCount. \prevOrdinal. maybeEntity <- scan down; - case maybeEntity (\_. return $ itemCount == 0) (\item. + case maybeEntity (\_. pure $ itemCount == 0) (\item. myCount <- count item; if (myCount <= prevOrdinal) { move; ensureMonotonicDecreasing (itemCount - 1) myCount; } { - return false; + pure false; }; ); end; + def λmatch = \f. \p. match p f end + def λcase = \f. \g. \s. case s f g end + + def length : (rec l. Unit + a * l) -> Int = λcase + (\_. 0) + (λmatch \_. \rest. 1 + length rest) + end + j <- robotnamed "judge"; as j { // Flag that setup is done hasBitcoin <- has "bitcoin"; if hasBitcoin { - result <- tagmembers "bust" 0; - let itemCount = fst result in - ensureMonotonicDecreasing itemCount $ itemCount + 1; + let busts = tagmembers "bust" in + let bustCount = length busts in + ensureMonotonicDecreasing bustCount $ bustCount + 1; } { - return false; + pure false; } }; robots: @@ -245,7 +253,6 @@ , if (((3 - y) % 20)/11 + ((x + 3) % 20)/11) == 0 then {terrain: grass} else {blank} ] upperleft: [0, 11] - offset: false palette: 'B': [stone, null, base] 'j': [stone, null, judge] diff --git a/data/scenarios/Challenges/gopher.yaml b/data/scenarios/Challenges/gopher.yaml --- a/data/scenarios/Challenges/gopher.yaml +++ b/data/scenarios/Challenges/gopher.yaml @@ -20,9 +20,9 @@ condition: | try { robotnamed "gopher"; - return false; + pure false; } { - return true; + pure true; } - teaser: Recover equipment prerequisite: defeat_gopher @@ -34,7 +34,7 @@ condition: | as base { sCount <- count "scanner"; - return $ sCount >= 120; + pure $ sCount >= 120; } robots: - name: base @@ -132,7 +132,6 @@ dsl: | "classic" upperleft: [-1, 1] - offset: false palette: 'x': [dirt, erase] '.': [grass, erase] diff --git a/data/scenarios/Challenges/hackman.yaml b/data/scenarios/Challenges/hackman.yaml --- a/data/scenarios/Challenges/hackman.yaml +++ b/data/scenarios/Challenges/hackman.yaml @@ -29,7 +29,7 @@ as base { pcount <- count "pellet"; donut_count <- count "donut"; - return $ pcount >= 181; + pure $ pcount >= 181; }; - id: donut_given teaser: Give to ghost @@ -47,12 +47,12 @@ }; if hasPowerup { - return true; + pure true; } { if (n > 1) { anyHasPowerup $ n - 1; } { - return false; + pure false; } } end; @@ -68,7 +68,7 @@ loc <- as base { whereami; }; - return $ loc == (0, 0); + pure $ loc == (0, 0); - teaser: World wrap hidden: true optional: true @@ -109,10 +109,10 @@ if (n > 1) { allHasPowerup $ n - 1; } { - return true; + pure true; } } { - return false; + pure false; } end; @@ -277,12 +277,7 @@ 'x': [blank, wall] 'T': [blank, null, teleport_monitor] '=': [blank, gate] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] 'W': cell: [blank] waypoint: @@ -317,9 +312,9 @@ Bx.....x....x....x.....xB Bxxxxx.xxxxBxBxxxx.xxxxxB BBBBBx.xBBBBBBBBBx.xBBBBB - Bxxxxx.xB┌──=──┐Bx.xxxxxB - ZYBBBB.BB│abBcd│BB.BBBBWX - Bxxxxx.xB└─────┘Bx.xxxxxB + Bxxxxx.xB+++=+++Bx.xxxxxB + ZYBBBB.BB+abBcd+BB.BBBBWX + Bxxxxx.xB+++++++Bx.xxxxxB BBBBBx.xBBBfΩBBBBx.xBBBBB Bxxxxx.xBxxxxxxxBx.xxxxxB Bx..........x..........xB 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 @@ -13,7 +13,7 @@ y <- ishere "blocked two"; teleport self (2,-3); z <- ishere "blocked three"; - return (x && y && z) + pure (x && y && z) solution: | run "scenarios/Challenges/_hanoi/hanoi-solution.sw" robots: @@ -143,6 +143,12 @@ attr: gold description: - This entity signals that the column is sorted. + - name: wall + display: + char: '#' + description: + - Unmovable barrier + properties: [known, unwalkable, boundary] known: - bottom tee - OK @@ -159,26 +165,20 @@ ',': [grass] '_': [stone] 'v': [stone, null, base] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] - '┴': [stone, bottom tee] '1': [stone, one, invariant] '2': [stone, blocked two, invariant] '3': [stone, blocked three, invariant] '.': [stone, null, invariant] '^': [grass, null, increasing] 'X': [grass, three, count] + 'w': [stone, wall] upperleft: [-3, 1] map: | - ┌─────┐ - │__v__│ - │1│.│.│ - │2│.│.│ - │3│.│.│ - └─┴─┴─┘ + wwwwwww + w__v__w + w1w.w.w + w2w.w.w + w3w.w.w + wwwwwww ,^,^,^, ,,,X,,, diff --git a/data/scenarios/Challenges/ice-cream.yaml b/data/scenarios/Challenges/ice-cream.yaml --- a/data/scenarios/Challenges/ice-cream.yaml +++ b/data/scenarios/Challenges/ice-cream.yaml @@ -195,6 +195,12 @@ description: - Decoration properties: [known] + - name: wall + display: + char: '#' + description: + - Unmovable barrier + properties: [known, unwalkable, boundary] recipes: - in: - [1, egg] @@ -209,7 +215,6 @@ dsl: | {grass} upperleft: [0, 0] - offset: false palette: '.': [grass] ':': [stone] @@ -220,12 +225,7 @@ X: [stone, null, customer] 'y': [stone, awning1] 'z': [stone, awning2] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + 'w': [stone, wall] '\': [stone, cone left] '/': [stone, cone right] 'Z': [stone, cone inside] @@ -239,6 +239,6 @@ ...:.......... ...:.......OO. yzy:yzyz..OOOO - ┌─┐x┌──┐..^^^^ - │B:Ω:V6│..\ZZ/ - └──────┘...\/. + wwwxwwww..^^^^ + wB:Ω:V6w..\ZZ/ + wwwwwwww...\/. diff --git a/data/scenarios/Challenges/lights-out.yaml b/data/scenarios/Challenges/lights-out.yaml --- a/data/scenarios/Challenges/lights-out.yaml +++ b/data/scenarios/Challenges/lights-out.yaml @@ -20,20 +20,21 @@ condition: | def advanceRow = curLoc <- whereami; - teleport self (0, snd curLoc - 1); + match curLoc \_. \y. + teleport self (0, y - 1); end; def isRowDark = \n. if (n > 0) { onHere <- ishere "on"; if onHere { - return false; + pure false; } { move; isRowDark $ n - 1; } } { - return true; + pure true; } end; @@ -44,10 +45,10 @@ advanceRow; areAllOff rowWidth $ n - 1; } { - return false; + pure false; } } { - return true; + pure true; } end; @@ -57,7 +58,7 @@ teleport self (0, 0); turn east; areAllOff 5 5; - } {return false}; + } {pure false}; end; j <- robotnamed "judge"; @@ -144,7 +145,6 @@ known: [] world: upperleft: [-1, 1] - offset: false palette: B: [blank, null, base] z: [blank, null, judge] diff --git a/data/scenarios/Challenges/maypole.yaml b/data/scenarios/Challenges/maypole.yaml --- a/data/scenarios/Challenges/maypole.yaml +++ b/data/scenarios/Challenges/maypole.yaml @@ -103,7 +103,6 @@ dsl: | {grass} upperleft: [0, 0] - offset: false palette: 'B': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Challenges/pack-tetrominoes.yaml b/data/scenarios/Challenges/pack-tetrominoes.yaml --- a/data/scenarios/Challenges/pack-tetrominoes.yaml +++ b/data/scenarios/Challenges/pack-tetrominoes.yaml @@ -21,8 +21,8 @@ Place all five tetrominoes. condition: | def found = \s. - fs <- structure s 0; - return $ case fs (\_. false) (\_. true); + fs <- structures s; + pure $ case fs (\_. false) (\_. true); end; foundT <- found "tee"; @@ -30,7 +30,7 @@ foundI <- found "line"; foundZ <- found "zee"; foundQ <- found "square"; - return $ foundT && foundJ && foundI && foundZ && foundQ; + pure $ foundT && foundJ && foundI && foundZ && foundQ; robots: - name: base dir: east diff --git a/data/scenarios/Challenges/telephone.yaml b/data/scenarios/Challenges/telephone.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/telephone.yaml @@ -0,0 +1,222 @@ +version: 1 +name: Telephone +author: Brent Yorgey +description: | + Give another robot instructions to duplicate a pattern. +creative: false +objectives: + - id: 'paper' + teaser: Make some paper + goal: + - | + As part of a scheme to prove your intelligence to anyone + watching from space, the mystical geoglyph of X's and O's in the + blue square needs to be copied into the square across the + mountains. + - | + One small problem is that the mountains are too high for you + to cross! However, there is a shuttle service, running on a + regular schedule through a tunnel, that can deliver small + packages to the terminal on the other side of the mountains. + At the other terminal is a general-purpose utility robot; you + will have to send it instructions so it can recreate the + design for you. + - | + As a first step, you will need `paper`{=entity} on which to + write the instructions; make at least 8 sheets of + `paper`{=entity}. + condition: | + as base { + pcount <- count "paper"; + pure $ pcount >= 8; + }; + - teaser: Duplicate the design + prerequisite: 'paper' + goal: + - | + Now that you have some `paper`{=entity}, you can use your + `typewriter`{=entity} to `print` on it. If you `format` a + value, `print` it on some paper, and send it via the shuttle, + the utility robot will be able to read the value. + - | + In particular, the utility robot is expecting to read values + of type `(Int * Int) * Text`{=type}, where the + `(Int * Int)`{=type} tuple is an x- and y-offset from the lower right + corner of the blue box, and the `Text`{=type} is the name of + the entity (either `X`{=entity} or `O`{=entity}) to place + there. For example, if you printed `((3,1), "O")` then the + utility robot would place an `O`{=entity} 3 units to the left + and 1 unit above the bottom-right corner of the blue square. + - | + To send something via the shuttle, just place the item you + wish to send on the purple cell at the center of the eastern + terminal, that is, the cell with coordinates `(88, -10)`. The + next time the shuttle arrives, it will notice the item and + pick it up for delivery. + condition: | + judge <- robotNamed "judge"; + as judge { has "X" } +solution: | + run "scenarios/Challenges/_telephone/solution.sw" +robots: + - name: base + dir: north + devices: + - branch predictor + - treads + - antenna + - comparator + - ADT calculator + - workbench + - harvester + - dictionary + - lambda + - logger + - welder + - scanner + - strange loop + - solar panel + - string + - typewriter + - rolex + - rubber band + - tweezers + inventory: [] + - name: shuttle + system: true + dir: east + display: + invisible: false + char: 'Ξ' + priority: 8 + program: | + run "scenarios/Challenges/_telephone/shuttle.sw" + - name: photocopier + system: true + dir: east + display: + invisible: false + char: '*' + inventory: + - [100, 'O'] + - [100, 'X'] + program: | + run "scenarios/Challenges/_telephone/photocopier.sw" + - name: judge + system: true + dir: east + devices: + - logger + program: | + run "scenarios/Challenges/_telephone/judge.sw" +attrs: + - name: greyborder + fg: '#cccccc' + bg: '#002f00' + - name: blueborder + fg: '#4287f5' + bg: '#002f00' + - name: purpleborder + fg: '#d885ff' + bg: '#002f00' + - name: purplebg + bg: '#d885ff' + - name: yg + fg: '#ffff8f' + bg: '#002f00' + - name: rg + fg: '#ff8f8f' + bg: '#002f00' +entities: + - name: mountain + display: + attr: snow + char: 'A' + priority: 9 + description: + - An impassably tall mountain. + properties: [unwalkable, opaque] + - name: blueborder + display: + char: '%' + attr: 'blueborder' + description: + - Decorative border + properties: [known, boundary] + - name: purpleborder + display: + char: '&' + attr: 'purpleborder' + description: + - Decorative border + properties: [known, boundary] + - name: track + display: + char: '=' + attr: entity + description: + - Narrow-gauge track. + properties: [known] + - name: O + display: + char: 'O' + attr: rg + description: + - O + properties: [known] + - name: X + display: + char: 'X' + attr: yg + description: + - X + properties: [known] +terrains: + - name: terminal + attr: purplebg + description: Shuttle terminal +known: [mountain, tree, water, wavy water] +world: + dsl: | + overlay + [ {grass} + , if (x >= 53 && x <= 60 && y >= -8 && y <= -5) then + (if (hash % 7 <= 1) then {X} else if (hash % 7 <= 3) then {O} else {grass}) + else {grass} + ] + upperleft: [0, 0] + palette: + '.': [grass] + '#': [grass, wall] + '%': [grass, blueborder] + 'A': [stone, mountain] + 'T': [grass, tree] + 'W': [stone, water] + '~': [stone, wavy water] + '^': [grass, null, base] + '&': [grass, purpleborder] + '=': [grass, track] + 'S': [grass, track, shuttle] + 'P': [grass, null, photocopier] + 'J': [grass, null, judge] + 't': [terminal] + map: | + ################################################################################ + #..............................AA..............................................# + #.............................AAA......................................T.......# + #............................AAA......................................TT.......# + #....%%%%%%%%%%...............AAAA..................%%%%%%%%%%.........TTT.....# + #....%........%................AAAAA................%........%.......TTT.......# + #....%........%...................AA................%........%.....TTTT........# + #....%........%...............AAAAA.................%........%.......TTT.......# + #....%J.......%..............AAA....................%........%.........T.......# + #....%%%%%%%%%%..&&&........AAAAA..............&&&..%%%%%%%%%%.......TTTT......# + #................&P===========AA========S=======t&..............^.....TTTT.....# + #................&&&.........AAAA..............&&&.....................TT......# + #..............................AAA.............................................# + #...............................AAAA.............................WWW...........# + #..............................AAAAAA............................WW~W..........# + #...............................AAAA...........................WW~WW...........# + #..............................AAAA..............................WW............# + #.............................AAA..............................................# + ################################################################################ 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 @@ -11,7 +11,7 @@ condition: | try { as base {has "lambda"} - } { return false } + } { pure false } solution: | def w2 = turn back; turn back end; def w10 = w2; w2; w2; w2; w2 end; @@ -54,6 +54,13 @@ basePos <- as base {whereami}; if (myPos == basePos) {teleport base destPos} {}; ); +entities: + - name: wall + display: + char: '#' + description: + - Unmovable barrier + properties: [known, unwalkable, boundary] known: [water, wavy water, flower, tree] world: dsl: | @@ -66,19 +73,14 @@ 'T': [grass, tree] '.': [grass, erase] '_': [stone, erase] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] 'λ': [grass, lambda] + 'x': [stone, wall] upperleft: [-1, 3] map: | ~~ ~ ~ ~ - ~┌─────┐~ ┌─────┐~ , - ┌┘.....└───┘T...*└┐ ~ - │_....._ _..λ.._│ , - └┐.....┌───┐*...T┌┘ ~ - ~└─────┘ ~~└─────┘~ , + ~xxxxxxx~ xxxxxxx~ , + xx.....xxxxxT...*xx ~ + x_....._ _..λ.._x , + xx.....xxxxx*...Txx ~ + ~xxxxxxx ~~xxxxxxx~ , ~~~ ~ ~ ~ diff --git a/data/scenarios/Challenges/wave.yaml b/data/scenarios/Challenges/wave.yaml --- a/data/scenarios/Challenges/wave.yaml +++ b/data/scenarios/Challenges/wave.yaml @@ -21,7 +21,7 @@ - | The robots caught you! condition: | - as base {x <- meet; return $ case x (\_. false) (\_. true)}; + as base {x <- meet; pure $ case x (\_. false) (\_. true)}; robots: - name: base dir: north @@ -56,7 +56,8 @@ end; def start = pos <- whereami; - wait $ fst pos; + match pos \x. \_. + wait x; go; end; start; @@ -71,7 +72,6 @@ , if (x / 2 - y) % 5 == 0 then {dirt, wavy water} else {blank} ] upperleft: [-3, 6] - offset: false palette: 'B': [grass, erase, base] 'w': [grass, erase, wavebot] diff --git a/data/scenarios/Challenges/word-search.yaml b/data/scenarios/Challenges/word-search.yaml --- a/data/scenarios/Challenges/word-search.yaml +++ b/data/scenarios/Challenges/word-search.yaml @@ -14,8 +14,8 @@ or vertically in either the upward or downward direction. Diagonal appearances are not valid. condition: | - foundStructure <- structure "cow" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructures <- structures "cow"; + pure $ case foundStructures (\_. false) (\_. true); robots: - name: base display: @@ -178,7 +178,6 @@ dsl: | {dirt} upperleft: [0, 0] - offset: false palette: '@': [stone, boulder] '.': [grass] diff --git a/data/scenarios/Fun/00-ORDER.txt b/data/scenarios/Fun/00-ORDER.txt --- a/data/scenarios/Fun/00-ORDER.txt +++ b/data/scenarios/Fun/00-ORDER.txt @@ -2,3 +2,4 @@ logo-burst.yaml horton.yaml snake.yaml +spider.yaml diff --git a/data/scenarios/Fun/GoL.yaml b/data/scenarios/Fun/GoL.yaml --- a/data/scenarios/Fun/GoL.yaml +++ b/data/scenarios/Fun/GoL.yaml @@ -33,7 +33,7 @@ h <- scan down; f <- scan forward; b <- scan back; - return (cnt h + cnt f + cnt b) + pure (cnt h + cnt f + cnt b) end; def mod : Int -> Int -> Int = \a. \b. a - (a/b)*b end; def waitUntil = \p. @@ -42,20 +42,20 @@ end; forever ( h <- scan down; - alive <- return (h != inl ()); + alive <- pure (h != inl ()); n1 <- count3; turn left; move; turn right; n2 <- count3; turn right; move; move; turn left; n3 <- count3; turn left; move; turn right; - total <- return (n1 + n2 + n3 - if alive {1} {0}); + total <- pure (n1 + n2 + n3 - if alive {1} {0}); if (alive && (total < 2 || total > 3)) - { grab; return () } + { grab; pure () } { if (not alive && total == 3) { place "rock" } {} }; // synchronize - waitUntil (t <- time; return (mod t 0x20 == 0)) + waitUntil (t <- time; pure (mod t 0x20 == 0)) ) world: dsl: | diff --git a/data/scenarios/Fun/_logo-burst/drone.sw b/data/scenarios/Fun/_logo-burst/drone.sw --- a/data/scenarios/Fun/_logo-burst/drone.sw +++ b/data/scenarios/Fun/_logo-burst/drone.sw @@ -8,7 +8,7 @@ def randdir : Cmd Dir = d <- random 4; - return ( + pure ( if (d == 0) {north} $ elif (d == 1) {east} $ elif (d == 2) {south} @@ -33,9 +33,10 @@ end; def converge = \loc. \currentLoc. - - let xDist = fst currentLoc - fst loc in - let yDist = snd currentLoc - snd loc in + match loc \x. \y. + match currentLoc \curx. \cury. + let xDist = curx - x in + let yDist = cury - y in if (xDist < 0) { turn east; diff --git a/data/scenarios/Fun/_snake/snake.sw b/data/scenarios/Fun/_snake/snake.sw --- a/data/scenarios/Fun/_snake/snake.sw +++ b/data/scenarios/Fun/_snake/snake.sw @@ -2,8 +2,10 @@ Uses a string to maintain a queue of coordinates. */ -def coordsToString : (Int * Int) -> Text = \coords. - format (fst coords) ++ "," ++ format (snd coords) +def λmatch = \f. \p. match p f end + +def coordsToString : (Int * Int) -> Text = λmatch \x. \y. + format x ++ "," ++ format y end def indexOfRec : Int -> Text -> Text -> (Unit + Int) = \pos. \inputString. \targetChar. @@ -24,17 +26,19 @@ // Drops the first character of a string def strTail : Text -> Text = \inputString. - snd $ split 1 inputString + match (split 1 inputString) \_. \rest. rest end def splitOnFirstChar : Text -> Text -> (Text * Text) = \inputString. \splitChar. - case (indexOf inputString splitChar) (\_. - // Did not find the split character, so return the original string - (inputString, "") - ) (\foundIdx. - let parts = split foundIdx inputString in - (fst parts, strTail $ snd parts) - ) + case (indexOf inputString splitChar) + (\_. + // Did not find the split character, so return the original string + (inputString, "") + ) + (\foundIdx. + match (split foundIdx inputString) \a. \b. + (a, strTail b) + ) end def getDecimalCharValue = \inputString. \idx. @@ -58,8 +62,8 @@ // Comma (",") is the separator between abscissa and ordinate def stringToCoords : Text -> (Int * Int) = \coordsString. - let pair = splitOnFirstChar coordsString "," in - (parseDecimal $ fst pair, parseDecimal $ snd pair) + match (splitOnFirstChar coordsString ",") \a. \b. + (parseDecimal a, parseDecimal b) end // APPEND to string representation of a coordinate list @@ -72,7 +76,8 @@ def pop : Text -> (Unit + ((Int * Int) * Text)) = \strList. if (chars strList > 0) { let pair = splitOnFirstChar strList ";" in - inR (stringToCoords $ fst pair, snd pair) + match pair \a. \b. + inR (stringToCoords a, b) } { inL (); } @@ -86,7 +91,7 @@ teleport self targetLoc; x <- func; teleport self currLoc; - return x; + pure x; end; def moveTail = \tailList. @@ -95,20 +100,17 @@ let maybeShifted = pop tailList in case maybeShifted (\_. // Nothing to pick up or replace - return tailList; - - ) (\newPair. + pure tailList; - let farthestTail = fst newPair in - let newInit = snd newPair in + ) (λmatch \farthestTail. \newInit. newLoc <- whereami; grabbedItem <- doAtLoc newLoc farthestTail grab; place grabbedItem; - return $ snoc newLoc newInit; + pure $ snoc newLoc newInit; ); } { - return tailList; + pure tailList; } end; @@ -119,11 +121,11 @@ targetLoc <- as r {whereami}; maybeD <- getDir targetLoc; - case maybeD (\_. say "Dead!"; return "") (\d. - turn $ fst d; + case maybeD (\_. say "Dead!"; pure "") (λmatch \dir. \_. + turn dir; newList <- moveTail tailList; move; - return newList + pure newList ); end @@ -139,10 +141,10 @@ modifiedTailList <- try { make "tail"; swap "tail"; - return $ snoc myLoc tailList; + pure $ snoc myLoc tailList; } { grab; - return tailList; + pure tailList; }; // Need to move here so that we get out of the way // if the tail gets elongated diff --git a/data/scenarios/Fun/_spider/spider.sw b/data/scenarios/Fun/_spider/spider.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Fun/_spider/spider.sw @@ -0,0 +1,62 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def intersperse = \n. \f2. \f1. if (n > 0) { + f1; + if (n > 1) { + f2; + } {}; + intersperse (n - 1) f2 f1; + } {}; + end; + +def placeBoulder = \border. + create border; + + isEmptyHere <- isempty; + if isEmptyHere { + place border + } { + swap border; + pure (); + }; + + pure (); +end + +def spinWeb = \border. + move; + turn left; + + try { + intersperse 2 move $ placeBoulder border; + doN 3 ( + turn left; + doN 2 (placeBoulder border; move); + ); + placeBoulder border; + } {}; +end + +def goDir = \result. + match result \d. \_. + if (d == down) { + spinWeb "mountain"; + } { + turn d; move; + }; +end; + +def followRoute = \item. + nextDir <- path (inL ()) (inR item); + case nextDir pure goDir; + followRoute item; + end; + +myname <- whoami; +let target_object = if (myname == "tree spider") { + "tree"; +} { + "flower" +} in + +followRoute target_object; diff --git a/data/scenarios/Fun/horton.yaml b/data/scenarios/Fun/horton.yaml --- a/data/scenarios/Fun/horton.yaml +++ b/data/scenarios/Fun/horton.yaml @@ -12,7 +12,7 @@ condition: | as base { flowerCount <- count "flower"; - return $ flowerCount >= 399; + pure $ flowerCount >= 399; } robots: - name: Horton @@ -35,13 +35,13 @@ - wayfinder solution: | def goDir = \f. \result. - let d = fst result in + match result \d. \_. if (d == down) {grab; f;} {turn d; move; f;} end; def followRoute = nextDir <- path (inL ()) (inR "flower"); - case nextDir return $ goDir followRoute; + case nextDir pure $ goDir followRoute; end; followRoute; @@ -79,7 +79,6 @@ , mask (x < -80 || x > 80 || y < -60 || y > 60) (overlay [{water}]) ] upperleft: [-4, 4] - offset: false palette: 'B': [grass, erase, Horton] '.': [grass, erase] diff --git a/data/scenarios/Fun/logo-burst.yaml b/data/scenarios/Fun/logo-burst.yaml --- a/data/scenarios/Fun/logo-burst.yaml +++ b/data/scenarios/Fun/logo-burst.yaml @@ -56,7 +56,6 @@ known: [boulder, tree, water, wavy water] world: upperleft: [0, 0] - offset: false palette: 'Ω': [blank, null, base] 's': [blank, null, stoplight] diff --git a/data/scenarios/Fun/snake.yaml b/data/scenarios/Fun/snake.yaml --- a/data/scenarios/Fun/snake.yaml +++ b/data/scenarios/Fun/snake.yaml @@ -13,7 +13,7 @@ r <- robotnamed "snake"; as r { appleCoreCount <- count "apple core"; - return $ appleCoreCount >= 40; + pure $ appleCoreCount >= 40; } robots: - name: base diff --git a/data/scenarios/Fun/spider.yaml b/data/scenarios/Fun/spider.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Fun/spider.yaml @@ -0,0 +1,57 @@ +version: 1 +name: Spiders +description: | + Spiders catching prey by spinning webs +creative: true +objectives: + - goal: + - | + Complete 10 `cocoon`{=structure}s + condition: | + def length : (rec l. Unit + a * l) -> Int = \l. + case l (\_. 0) (\cons. match cons \_. \tl. 1 + length tl) + end + + foundStructures <- structures "cocoon"; + pure $ length foundStructures >= 10; +robots: + - name: base + dir: north + loc: [5, 0] + - name: ground spider + display: + invisible: false + attr: blue + dir: north + system: true + loc: [0, 0] + program: | + run "scenarios/Fun/_spider/spider.sw" + - name: tree spider + display: + invisible: false + attr: red + dir: north + system: true + loc: [0, 0] + program: | + run "scenarios/Fun/_spider/spider.sw" +structures: + - name: cocoon + recognize: [north] + structure: + mask: '.' + palette: + 'b': [grass, mountain] + map: | + bbb + b.b + bbb +known: [tree] +world: + dsl: |- + overlay + [ {grass} + , mask ((hash % 200) == 0) {flower} + , mask (((hash+1) % 200) == 0) {tree} + ] diff --git a/data/scenarios/Speedruns/curry.yaml b/data/scenarios/Speedruns/curry.yaml --- a/data/scenarios/Speedruns/curry.yaml +++ b/data/scenarios/Speedruns/curry.yaml @@ -34,7 +34,6 @@ - [50, clock] - [5, toolkit] world: - offset: true scrollable: false dsl: | "classic" diff --git a/data/scenarios/Speedruns/forester.yaml b/data/scenarios/Speedruns/forester.yaml --- a/data/scenarios/Speedruns/forester.yaml +++ b/data/scenarios/Speedruns/forester.yaml @@ -5,7 +5,7 @@ objectives: - goal: - Harvest 1024 `tree`{=entity}s as quickly as possible! - condition: as base {n <- count "tree"; return (n >= 1024)} + condition: as base {n <- count "tree"; pure (n >= 1024)} robots: - name: base loc: [0, 0] @@ -34,7 +34,6 @@ - [50, clock] - [5, toolkit] world: - offset: true scrollable: false dsl: | "classic" diff --git a/data/scenarios/Speedruns/mithril.yaml b/data/scenarios/Speedruns/mithril.yaml --- a/data/scenarios/Speedruns/mithril.yaml +++ b/data/scenarios/Speedruns/mithril.yaml @@ -34,7 +34,6 @@ - [50, clock] - [5, toolkit] world: - offset: true scrollable: false dsl: | "classic" diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -36,6 +36,7 @@ 1218-stride-command.yaml 1234-push-command.yaml 1256-halt-command.yaml +1271-wall-boundaries.yaml 1262-display-device-commands.yaml 1295-density-command.yaml 1138-structures @@ -56,6 +57,7 @@ 1721-walkability-whitelist-path-cache.yaml 1535-ping 1575-structure-recognizer +1592-shared-template-robot-say-logs.yaml 1631-tags.yaml 1634-message-colors.yaml 1681-pushable-entity.yaml @@ -67,3 +69,9 @@ 1533-sow-command.yaml 1533-sow-seed-maturation.yaml 231-requirements +2085-toplevel-mask.yaml +2086-structure-palette.yaml +2239-custom-entity.yaml +2240-overridden-entity-capabilities.yaml +2253-halt-waiting.yaml +2270-instant-defs.yaml diff --git a/data/scenarios/Testing/1024-sand.yaml b/data/scenarios/Testing/1024-sand.yaml --- a/data/scenarios/Testing/1024-sand.yaml +++ b/data/scenarios/Testing/1024-sand.yaml @@ -6,7 +6,7 @@ https://github.com/swarm-game/swarm/pull/1024 objectives: - condition: | - as base {n <- count "sand"; return (n >= 32)} + as base {n <- count "sand"; pure (n >= 32)} goal: - Obtain 32 sand. solution: | diff --git a/data/scenarios/Testing/1034-custom-attributes.yaml b/data/scenarios/Testing/1034-custom-attributes.yaml --- a/data/scenarios/Testing/1034-custom-attributes.yaml +++ b/data/scenarios/Testing/1034-custom-attributes.yaml @@ -61,7 +61,8 @@ - Do nothing condition: | pos <- as base {whereami}; - return $ fst pos > 7; + match pos \x. \_. + pure $ x > 7; entities: - name: color1 display: diff --git a/data/scenarios/Testing/1138-structures/flip-and-rotate.yaml b/data/scenarios/Testing/1138-structures/flip-and-rotate.yaml --- a/data/scenarios/Testing/1138-structures/flip-and-rotate.yaml +++ b/data/scenarios/Testing/1138-structures/flip-and-rotate.yaml @@ -11,12 +11,7 @@ palette: '.': [grass] '*': [stone, flower] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] structures: - name: tetromino @@ -68,20 +63,20 @@ up: west flip: true map: | - ┌──────────────────────────────┐ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - └──────────────────────────────┘ + ++++++++++++++++++++++++++++++++ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + ++++++++++++++++++++++++++++++++ diff --git a/data/scenarios/Testing/1138-structures/nested-structure.yaml b/data/scenarios/Testing/1138-structures/nested-structure.yaml --- a/data/scenarios/Testing/1138-structures/nested-structure.yaml +++ b/data/scenarios/Testing/1138-structures/nested-structure.yaml @@ -11,22 +11,9 @@ palette: '.': [grass] '*': [stone, flower] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] structures: - - name: bitpair - structure: - palette: - '0': [stone, bit (0)] - '1': [stone, bit (1)] - map: | - 1 - 0 - name: bigbox structure: palette: @@ -37,16 +24,13 @@ structure: palette: '.': [stone] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] + '+': [stone, wall] placements: - src: bitpair offset: [1, 0] map: | - ┌.┐ - └.┘ + +.+ + +.+ placements: - src: minibox offset: [0, -1] @@ -57,6 +41,14 @@ T.T.T. .T.T.T TTTTTT + - name: bitpair + structure: + palette: + '0': [stone, bit (0)] + '1': [stone, bit (1)] + map: | + 1 + 0 placements: - src: bigbox offset: [1, -1] @@ -69,13 +61,13 @@ - src: bitpair offset: [3, -7] map: | - ┌────────────┐ - │*..*..*..*..│ - │.*..*..*..*.│ - │..*..*..*..*│ - │*..*..*..*..│ - │.*..*..*..*.│ - │..*..*..*..*│ - │*..*..*..*..│ - │.*..*..*..*.│ - └────────────┘ + ++++++++++++++ + +*..*..*..*..+ + +.*..*..*..*.+ + +..*..*..*..*+ + +*..*..*..*..+ + +.*..*..*..*.+ + +..*..*..*..*+ + +*..*..*..*..+ + +.*..*..*..*.+ + ++++++++++++++ diff --git a/data/scenarios/Testing/1140-detect-command.yaml b/data/scenarios/Testing/1140-detect-command.yaml --- a/data/scenarios/Testing/1140-detect-command.yaml +++ b/data/scenarios/Testing/1140-detect-command.yaml @@ -10,15 +10,13 @@ solution: | def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; loc <- detect "tree" ((0, 0), (6, 4)); - case loc return (\delta. - let xDelta = fst delta in - let yDelta = snd delta in + case loc pure (\delta. match delta \xDelta. \yDelta. if (yDelta < 0) {turn south;} {}; doN yDelta move; // y-movement if (xDelta < 0) {turn west;} {turn east}; doN xDelta move; // x-movement grab; - return (); + pure (); ); robots: - name: base diff --git a/data/scenarios/Testing/1157-drill-return-value.yaml b/data/scenarios/Testing/1157-drill-return-value.yaml --- a/data/scenarios/Testing/1157-drill-return-value.yaml +++ b/data/scenarios/Testing/1157-drill-return-value.yaml @@ -8,7 +8,7 @@ as base {ishere "gumball"}; solution: | out <- drill forward; - case out return place; + case out pure place; robots: - name: base dir: north diff --git a/data/scenarios/Testing/1171-resonate-command.yaml b/data/scenarios/Testing/1171-resonate-command.yaml --- a/data/scenarios/Testing/1171-resonate-command.yaml +++ b/data/scenarios/Testing/1171-resonate-command.yaml @@ -9,7 +9,7 @@ j <- robotnamed "judge"; as j { c <- resonate "tree" ((0, 0), (8, -2)); - return $ c >= 7; + pure $ c >= 7; }; solution: | def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; diff --git a/data/scenarios/Testing/1171-sniff-command.yaml b/data/scenarios/Testing/1171-sniff-command.yaml --- a/data/scenarios/Testing/1171-sniff-command.yaml +++ b/data/scenarios/Testing/1171-sniff-command.yaml @@ -16,9 +16,9 @@ turn back; move; turn left; - return oldDistance; + pure oldDistance; } { - return newDistance; + pure newDistance; }; homeIn item d; } { diff --git a/data/scenarios/Testing/1218-stride-command.yaml b/data/scenarios/Testing/1218-stride-command.yaml --- a/data/scenarios/Testing/1218-stride-command.yaml +++ b/data/scenarios/Testing/1218-stride-command.yaml @@ -26,7 +26,7 @@ try { stride 5; grab; - return (); + pure (); } { log "Could not grab northern flower"; }; @@ -42,7 +42,7 @@ try { stride 5; grab; - return (); + pure (); } { log "Could not grab southern flower"; }; @@ -75,7 +75,7 @@ description: - Allows one to "stride" across multiple cells properties: [known, pickable] - capabilities: [movemultiple] + capabilities: [stride] known: [tree, flower, boulder, water] world: palette: diff --git a/data/scenarios/Testing/1256-halt-command.yaml b/data/scenarios/Testing/1256-halt-command.yaml --- a/data/scenarios/Testing/1256-halt-command.yaml +++ b/data/scenarios/Testing/1256-halt-command.yaml @@ -9,7 +9,7 @@ as base {has "flower"} solution: | mr <- meet; - case mr (\_. return ()) (\r. halt r; turn west; move; salvage ) + case mr (\_. pure ()) (\r. halt r; turn west; move; salvage ) robots: - name: base dir: south diff --git a/data/scenarios/Testing/1271-wall-boundaries.yaml b/data/scenarios/Testing/1271-wall-boundaries.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1271-wall-boundaries.yaml @@ -0,0 +1,96 @@ +version: 1 +name: Wall boundary display +creative: false +description: | + Demonstrate rendering of contiguous boundaries. + + Only adjacent with the 'boundary' property + will be rendered with box border glyphs. +attrs: + - name: purpleWall + fg: '#ff00ff' + - name: cyanWall + fg: '#00ffff' +objectives: + - goal: + - Place all fences + condition: | + as base { + hasFence <- has "fence"; + pure $ not hasFence; + } +solution: | + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + doN 4 ( + doN 6 (place "fence"; move); + turn left; + ); + + doN 2 move; + turn left; + + doN 2 ( + doN 2 move; + place "fence"; + ); + turn right; + move; + turn right; + move; + place "fence"; + move; + place "fence"; + move; +robots: + - name: base + dir: east + display: + attr: robot + devices: + - branch predictor + - comparator + - compass + - dictionary + - grabber + - logger + - treads + - antenna + - ADT calculator + inventory: + - [28, fence] +entities: + - name: wall + display: + char: 'x' + attr: purpleWall + description: + - A wall + properties: [known, boundary] + - name: fence + display: + char: 'F' + attr: cyanWall + description: + - A fence + properties: [known, boundary] +known: [boulder] +world: + default: [blank] + palette: + 'Ω': [grass, null, base] + '.': [grass] + '#': [grass, wall] + '@': [grass, boulder] + upperleft: [0, 0] + map: | + Ω......... + ....#..... + ..####..## + ..#.##.... + ..#..#..#. + ..####..#. + .......... + ...@@@.... + ...@.@.... + ...@@@.... diff --git a/data/scenarios/Testing/1295-density-command.yaml b/data/scenarios/Testing/1295-density-command.yaml --- a/data/scenarios/Testing/1295-density-command.yaml +++ b/data/scenarios/Testing/1295-density-command.yaml @@ -9,7 +9,7 @@ j <- robotnamed "judge"; as j { c <- density ((0, 0), (3, 3)); - return $ c <= 13; + pure $ c <= 13; }; solution: | def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; diff --git a/data/scenarios/Testing/1320-world-DSL/constant.yaml b/data/scenarios/Testing/1320-world-DSL/constant.yaml --- a/data/scenarios/Testing/1320-world-DSL/constant.yaml +++ b/data/scenarios/Testing/1320-world-DSL/constant.yaml @@ -5,7 +5,7 @@ single cell value. objectives: - condition: | - as base { n <- count "tree"; return (n >= 4) } + as base { n <- count "tree"; pure (n >= 4) } goal: - Get 4 trees solution: | diff --git a/data/scenarios/Testing/1320-world-DSL/erase.yaml b/data/scenarios/Testing/1320-world-DSL/erase.yaml --- a/data/scenarios/Testing/1320-world-DSL/erase.yaml +++ b/data/scenarios/Testing/1320-world-DSL/erase.yaml @@ -4,7 +4,7 @@ Test that we can erase entities when overlaying objectives: - condition: | - as base { n <- count "tree"; return (n == 0) } + as base { n <- count "tree"; pure (n == 0) } goal: - Get rid of your trees. solution: | diff --git a/data/scenarios/Testing/1320-world-DSL/override.yaml b/data/scenarios/Testing/1320-world-DSL/override.yaml --- a/data/scenarios/Testing/1320-world-DSL/override.yaml +++ b/data/scenarios/Testing/1320-world-DSL/override.yaml @@ -4,7 +4,7 @@ Test that later entities override earlier ones when overlaying objectives: - condition: | - as base { n <- count "tree"; return (n == 1) } + as base { n <- count "tree"; pure (n == 1) } goal: - Get a tree. solution: | diff --git a/data/scenarios/Testing/1320-world-DSL/reflect.yaml b/data/scenarios/Testing/1320-world-DSL/reflect.yaml --- a/data/scenarios/Testing/1320-world-DSL/reflect.yaml +++ b/data/scenarios/Testing/1320-world-DSL/reflect.yaml @@ -8,7 +8,7 @@ - goal: - Pick up four trees condition: | - as base {n <- count "tree"; return (n >= 4)} + as base {n <- count "tree"; pure (n >= 4)} robots: - name: base loc: [0, 0] @@ -27,8 +27,8 @@ def x = \n. \c. if (n==0) {} {c; x (n-1) c} end def ifC = \p. \t. \e. b <- p; if b t e end def findTree = ifC (ishere "tree") {whereami} {move; findTree} end - def ell = \d. turn right; x (2*d) move; grab; return () end - def grabTrees = \loc. let x = fst loc in let y = snd loc in grab; ell y; ell x; ell y end + def ell = \d. turn right; x (2*d) move; grab; pure () end + def grabTrees = \loc. match loc \x. \y. grab; ell y; ell x; ell y end n <- random 10; x (n+1) move; turn right; move; loc <- findTree; diff --git a/data/scenarios/Testing/1322-wait-with-instant.yaml b/data/scenarios/Testing/1322-wait-with-instant.yaml --- a/data/scenarios/Testing/1322-wait-with-instant.yaml +++ b/data/scenarios/Testing/1322-wait-with-instant.yaml @@ -17,9 +17,11 @@ t <- robotnamed "tortoise"; tortoiseloc <- as t {whereami}; - let xDiff = fst hareloc - fst tortoiseloc in + match hareloc \harex. \_. + match tortoiseloc \tortoisex. \_. + let xDiff = harex - tortoisex in - return $ fst hareloc == 0 && xDiff == 3; + pure $ harex == 0 && xDiff == 3; solution: | noop; robots: @@ -58,7 +60,6 @@ dsl: | {blank} upperleft: [-6, 2] - offset: false palette: '.': [grass, erase] 'd': [dirt, erase] diff --git a/data/scenarios/Testing/1341-command-count.yaml b/data/scenarios/Testing/1341-command-count.yaml --- a/data/scenarios/Testing/1341-command-count.yaml +++ b/data/scenarios/Testing/1341-command-count.yaml @@ -22,7 +22,7 @@ move; grab; } { - return ""; + pure ""; }; robots: - name: base diff --git a/data/scenarios/Testing/1355-combustion.yaml b/data/scenarios/Testing/1355-combustion.yaml --- a/data/scenarios/Testing/1355-combustion.yaml +++ b/data/scenarios/Testing/1355-combustion.yaml @@ -21,6 +21,7 @@ ignite forward; turn right; move; move; move; + ignite left; turn right; move; ignite left; @@ -75,6 +76,18 @@ duration: [8, 8] product: null properties: [known, pickable, combustible] + - name: slowfuse + display: + attr: silver + char: '~' + description: + - Reliably combustible, but burns more slowly + combustion: + ignition: 20 + duration: [64, 64] + delay: 63 + product: null + properties: [known, pickable, combustible] - name: dynamite display: attr: red @@ -103,6 +116,7 @@ 'b': [grass, board] 'i': [grass, cotton] 'F': [grass, fuse] + 'f': [grass, slowfuse] 'd': [grass, dynamite, judge] '.': [grass] upperleft: [0, 0] @@ -123,11 +137,11 @@ ......iiiiiiii........F...F...F...F.. iiiiiiiiiiiiiii..Ω.FFFF...FFFFF...d.. ......iiiiiiii....................... - iiiiiiiiiiiii.....qqqqqqqqqqqqqqqq... - ......iiiiii......qqqqqqqqqqqqqqqq... - iiiiiiiiiii.......qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... + iiiiiiiiiiiii..f..qqqqqqqqqqqqqqqq... + ......iiiiii...f..qqqqqqqqqqqqqqqq... + iiiiiiiiiii....f..qqqqqqqqqqqqqqqq... + ...............f..qqqqqqqqqqqqqqqq... + ..ffff...ffff..f..qqqqqqqqqqqqqqqq... + ..f..f...f..f..f..qqqqqqqqqqqqqqqq... + ..f..fffff..ffff..qqqqqqqqqqqqqqqq... ..................qqqqqqqqqqqqqqqq... diff --git a/data/scenarios/Testing/1356-portals/_automatic-waypoint-patrol/program.sw b/data/scenarios/Testing/1356-portals/_automatic-waypoint-patrol/program.sw --- a/data/scenarios/Testing/1356-portals/_automatic-waypoint-patrol/program.sw +++ b/data/scenarios/Testing/1356-portals/_automatic-waypoint-patrol/program.sw @@ -1,12 +1,12 @@ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; def abs = \n. if (n < 0) {-n} {n} end; -def mapTuple = \f. \t. - (f $ fst t, f $ snd t) - end; +def λmatch = \f. \p. match p f end -def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); +def mapTuple = \f. λmatch \a. \b. (f a, f b) end; + +def sumTuples = λmatch \t11. \t12. λmatch \t21. \t22. + (t11 + t21, t12 + t22); end; def negateTuple = \t. @@ -15,12 +15,10 @@ def getRelativeLocation = \absCurrentLoc. \absDestLoc. let negatedLoc = negateTuple absCurrentLoc in - return $ sumTuples negatedLoc absDestLoc; + pure $ sumTuples negatedLoc absDestLoc; end; -def moveTuple = \tup. - let x = fst tup in - let y = snd tup in +def moveTuple = λmatch \x. \y. turn $ if (x > 0) {east} {west}; doN (abs x) move; turn $ if (y > 0) {north} {south}; @@ -32,18 +30,21 @@ moveTuple relativeDestination; end; -def visitNextWaypoint = \nextWpIdx. +def visitNextWaypoint : (rec l. Unit + (Int * Int) * l) -> (rec l. Unit + (Int * Int) * l) -> Cmd Unit = \originalList. \remainingList. loc <- whereami; - nextWaypointQuery <- waypoint "wp" nextWpIdx; - goToLocation loc $ snd nextWaypointQuery; - visitNextWaypoint $ nextWpIdx + 1; + // Wrap around + let myList = case remainingList (\_. originalList) (\_. remainingList) in + + case myList pure (λmatch \hd. \tl. + goToLocation loc hd; + visitNextWaypoint originalList tl; + ); end; def go = - waypointQuery <- waypoint "wp" 0; - teleport self $ snd waypointQuery; - visitNextWaypoint 1; + let wpList = waypoints "wp" in + visitNextWaypoint wpList wpList; end; go; diff --git a/data/scenarios/Testing/1356-portals/_portals-flip-and-rotate/solution.sw b/data/scenarios/Testing/1356-portals/_portals-flip-and-rotate/solution.sw --- a/data/scenarios/Testing/1356-portals/_portals-flip-and-rotate/solution.sw +++ b/data/scenarios/Testing/1356-portals/_portals-flip-and-rotate/solution.sw @@ -2,12 +2,12 @@ def abs = \n. if (n < 0) {-n} {n} end; -def mapTuple = \f. \t. - (f $ fst t, f $ snd t) - end; +def λmatch = \f. \p. match p f end -def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); +def mapTuple = \f. λmatch \a. \b. (f a, f b) end; + +def sumTuples = λmatch \t11. \t12. λmatch \t21. \t22. + (t11 + t21, t12 + t22); end; def negateTuple = \t. @@ -16,12 +16,10 @@ def getRelativeLocation = \absCurrentLoc. \absDestLoc. let negatedLoc = negateTuple absCurrentLoc in - return $ sumTuples negatedLoc absDestLoc; + pure $ sumTuples negatedLoc absDestLoc; end; -def moveTuple = \tup. - let x = fst tup in - let y = snd tup in +def moveTuple = λmatch \x. \y. turn $ if (x > 0) {east} {west}; doN (abs x) move; turn $ if (y > 0) {north} {south}; diff --git a/data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml b/data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml --- a/data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml +++ b/data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml @@ -21,12 +21,7 @@ palette: '.': [grass] '*': [stone, flower] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] structures: - name: bigbox structure: @@ -59,14 +54,14 @@ orient: up: west map: | - ┌───────────┐ - │*..*..*..*.│ - │.*..*..*..*│ - │..*..*..*..│ - │*..*..*..*.│ - │.*..*..*..*│ - │..*..*..*..│ - │*..*..*..*.│ - │.*..*..*..*│ - │..*..*..*..│ - └───────────┘ + +++++++++++++ + +*..*..*..*.+ + +.*..*..*..*+ + +..*..*..*..+ + +*..*..*..*.+ + +.*..*..*..*+ + +..*..*..*..+ + +*..*..*..*.+ + +.*..*..*..*+ + +..*..*..*..+ + +++++++++++++ diff --git a/data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml b/data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml --- a/data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml +++ b/data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml @@ -37,12 +37,7 @@ '.': [grass] '*': [stone, flower] 'p': [grass, telepad exit] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] structures: - name: bitpair structure: @@ -102,13 +97,13 @@ exitInfo: exit: meadow map: | - ┌────────────┐ - │*..*..*..*.p│ - │.*..*..*..*.│ - │..*..*..*..*│ - │*..*..*..*..│ - │.*..*..*..*.│ - │..*..*..*..*│ - │*..*..*..*..│ - │.*..*..*..*.│ - └────────────┘ + ++++++++++++++ + +*..*..*..*.p+ + +.*..*..*..*.+ + +..*..*..*..*+ + +*..*..*..*..+ + +.*..*..*..*.+ + +..*..*..*..*+ + +*..*..*..*..+ + +.*..*..*..*.+ + ++++++++++++++ diff --git a/data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml b/data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml --- a/data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml +++ b/data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml @@ -54,12 +54,7 @@ '.': [grass] '*': [stone, flower] 'b': [stone, bitcoin] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] 'p': cell: [dirt, telepad exit, base] waypoint: @@ -123,20 +118,20 @@ exitInfo: exit: portal_out map: | - ┌──────────────────────────────┐ - │p..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..*│ - │*..*..*..*..*..*..*..*..*..*..│ - │.*..*..*..*..*..*..*..*..*..*.│ - │..*..*..*..*..*..*..*..*..*..b│ - └──────────────────────────────┘ + ++++++++++++++++++++++++++++++++ + +p..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..*+ + +*..*..*..*..*..*..*..*..*..*..+ + +.*..*..*..*..*..*..*..*..*..*.+ + +..*..*..*..*..*..*..*..*..*..b+ + ++++++++++++++++++++++++++++++++ diff --git a/data/scenarios/Testing/1430-built-robot-ownership.yaml b/data/scenarios/Testing/1430-built-robot-ownership.yaml --- a/data/scenarios/Testing/1430-built-robot-ownership.yaml +++ b/data/scenarios/Testing/1430-built-robot-ownership.yaml @@ -48,7 +48,7 @@ condition: | r2 <- robotNumbered 2; r3 <- robotNumbered 3; - return true + pure true known: [] world: palette: diff --git a/data/scenarios/Testing/144-subworlds/00-ORDER.txt b/data/scenarios/Testing/144-subworlds/00-ORDER.txt --- a/data/scenarios/Testing/144-subworlds/00-ORDER.txt +++ b/data/scenarios/Testing/144-subworlds/00-ORDER.txt @@ -3,3 +3,4 @@ subworld-mapped-robots.yaml subworld-located-robots.yaml spatial-consistency-enforcement.yaml +teleport-and-query.yaml diff --git a/data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw b/data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw --- a/data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw +++ b/data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw @@ -6,5 +6,5 @@ doN 5 move; r <- meet; -case r return $ \j. give j f; +case r pure $ \j. give j f; diff --git a/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw b/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw --- a/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw +++ b/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw @@ -2,7 +2,7 @@ def getRobotNumber = \n. r <- robotnumbered n; if (r == self) { - return n; + pure n; } {getRobotNumber $ n + 1}; end; @@ -10,7 +10,7 @@ r <- robotnumbered idx; thisName <- as r {whoami}; if (thisName == targetName) { - return $ r == self; + pure $ r == self; } {amLowestRecursive targetName $ idx + 1}; end; diff --git a/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw b/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw --- a/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw +++ b/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw @@ -4,5 +4,5 @@ doN 16 move; r <- meet; -case r return $ \j. give j "bitcoin"; +case r pure $ \j. give j "bitcoin"; diff --git a/data/scenarios/Testing/144-subworlds/teleport-and-query.yaml b/data/scenarios/Testing/144-subworlds/teleport-and-query.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/teleport-and-query.yaml @@ -0,0 +1,67 @@ +version: 1 +name: Subworld teleportation +description: | + Surface and underground with portals. +objectives: + - goal: + - | + System robot must teleport the base to another subworld. + The goal condition utilizes location query command. + condition: | + as base { + myloc <- locateme; + match myloc \w. \_. + pure $ w == "underground"; + } +solution: | + noop +robots: + - name: base + dir: east + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads + - name: judge + dir: east + system: true + display: + char: 'J' + invisible: true + program: | + wait 10; + warp base ("underground", (0, 0)); +known: [flower, boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'b': [dirt, boulder] + upperleft: [-1, 1] + map: | + b..b..b..b + ....f..... + b..b..b..b +world: + name: root + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 't': [ice, null, judge] + upperleft: [-1, 1] + map: | + .......... + ...Bt..... + .......... diff --git a/data/scenarios/Testing/1533-sow-command.yaml b/data/scenarios/Testing/1533-sow-command.yaml --- a/data/scenarios/Testing/1533-sow-command.yaml +++ b/data/scenarios/Testing/1533-sow-command.yaml @@ -10,9 +10,6 @@ - name: clay fg: "#444444" bg: "#c2b280" - - name: wheat - fg: "#444444" - bg: "#F5DEB3" - name: barley fg: "#444444" bg: "#F6E9B1" @@ -34,7 +31,7 @@ r <- robotnamed "kudzubot"; as r { kCount <- resonate "kudzu" ((0, 0), (10, 4)); - return $ kCount >= 45; + pure $ kCount >= 45; } solution: | def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; @@ -80,19 +77,6 @@ dir: east system: true entities: - - name: wheat - display: - char: 'w' - attr: wheat - description: - - Grain - properties: [known, pickable, growable] - growth: - duration: [20, 30] - spread: - radius: 2 - density: 0.3 - biomes: [dirt, clay] - name: barley display: char: 'b' diff --git a/data/scenarios/Testing/1533-sow-seed-maturation.yaml b/data/scenarios/Testing/1533-sow-seed-maturation.yaml --- a/data/scenarios/Testing/1533-sow-seed-maturation.yaml +++ b/data/scenarios/Testing/1533-sow-seed-maturation.yaml @@ -22,7 +22,7 @@ condition: | as base { x <- has "acorn"; - return $ not x; + pure $ not x; } - goal: - | diff --git a/data/scenarios/Testing/1535-ping/1535-out-of-range.yaml b/data/scenarios/Testing/1535-ping/1535-out-of-range.yaml --- a/data/scenarios/Testing/1535-ping/1535-out-of-range.yaml +++ b/data/scenarios/Testing/1535-ping/1535-out-of-range.yaml @@ -11,7 +11,7 @@ r <- robotnamed "buddy"; as r { response <- ping base; - return $ case response (\_. true) (\_. false); + pure $ case response (\_. true) (\_. false); } solution: | run "scenarios/Testing/1535-ping/_1535-out-of-range/solution.sw" diff --git a/data/scenarios/Testing/1535-ping/_1535-in-range/solution.sw b/data/scenarios/Testing/1535-ping/_1535-in-range/solution.sw --- a/data/scenarios/Testing/1535-ping/_1535-in-range/solution.sw +++ b/data/scenarios/Testing/1535-ping/_1535-in-range/solution.sw @@ -3,26 +3,24 @@ def goToBuddy = \loc. // log $ format loc; - - let longitudinalDist = snd loc in + match loc \lateralDist. \longitudinalDist. absFwd <- if (longitudinalDist < 0) { turn back; - return $ -longitudinalDist; + pure $ -longitudinalDist; } { - return longitudinalDist; + pure longitudinalDist; }; doN absFwd move; if (longitudinalDist < 0) { turn back; } {}; - let lateralDist = fst loc in absSide <- if (lateralDist < 0) { turn left; - return $ -lateralDist; + pure $ -lateralDist; } { turn right; - return lateralDist; + pure lateralDist; }; doN absSide move; end; @@ -30,7 +28,7 @@ def checkNeedToMove = \f. \loc. wait 3; if (loc == (0, 0)) { - return () + pure () } { goToBuddy loc; f; @@ -39,7 +37,7 @@ def pingLoop = \buddy. maybeLoc <- ping buddy; - case maybeLoc return $ checkNeedToMove $ pingLoop buddy; + case maybeLoc pure $ checkNeedToMove $ pingLoop buddy; end; def giveToBuddy = \buddy. @@ -50,7 +48,7 @@ def go = move; maybeBuddy <- meet; - case maybeBuddy return giveToBuddy; + case maybeBuddy pure giveToBuddy; grab; end; diff --git a/data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-modes.yaml b/data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-modes.yaml --- a/data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-modes.yaml +++ b/data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-modes.yaml @@ -32,7 +32,7 @@ def forceBlockageInvalidation = build { - require 1 "monolith"; + stock 1 "monolith"; move; place "monolith"; turn back; @@ -55,7 +55,7 @@ def forceCompetingTargetInvalidation = build { - require 1 "flower"; + stock 1 "flower"; turn right; move; place "flower"; @@ -106,28 +106,28 @@ entities: - name: wayfinder display: - char: 'w' + char: "w" description: - Enables `path` command properties: [known, pickable] capabilities: [path] - name: monolith display: - char: '@' + char: "@" attr: rock description: - Pushable rock properties: [known, unwalkable, pickable] - name: lemon display: - char: 'o' + char: "o" attr: gold description: - Sour fruit properties: [known, pickable] - name: lemonade display: - char: 'c' + char: "c" attr: gold description: - Sweet drink @@ -166,9 +166,9 @@ known: [flower] world: palette: - 'B': [grass, erase, base] - '.': [grass] - 'f': [grass, flower] + "B": [grass, erase, base] + ".": [grass] + "f": [grass, flower] upperleft: [0, 0] map: | ..... diff --git a/data/scenarios/Testing/1569-pathfinding-cache/1569-harvest-batch.yaml b/data/scenarios/Testing/1569-pathfinding-cache/1569-harvest-batch.yaml --- a/data/scenarios/Testing/1569-pathfinding-cache/1569-harvest-batch.yaml +++ b/data/scenarios/Testing/1569-pathfinding-cache/1569-harvest-batch.yaml @@ -12,17 +12,17 @@ condition: | as base { fCount <- count "flower"; - return $ fCount >= 4; + pure $ fCount >= 4; }; solution: | def goDir = \f. \result. - let d = fst result in + match result \d. \_. if (d == down) {grab; f;} {turn d; move; f;} end; def followRoute = nextDir <- path (inL ()) (inR "flower"); - case nextDir return $ goDir followRoute; + case nextDir pure $ goDir followRoute; end; followRoute; diff --git a/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt b/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt --- a/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt +++ b/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt @@ -14,3 +14,9 @@ 1575-bounding-box-overlap.yaml 1644-rotated-recognition.yaml 1644-rotated-preplacement-recognition.yaml +2115-encroaching-upon-exterior-transparent-cells.yaml +2115-encroaching-upon-interior-transparent-cells.yaml +2201-piecewise-lines.yaml +2201-preclude-overlapping-recognition.yaml +2201-initial-recognition-overlap.yaml +2229-position-uniqueness-multiple-orientations.yaml diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-bounding-box-overlap.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-bounding-box-overlap.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-bounding-box-overlap.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-bounding-box-overlap.yaml @@ -14,8 +14,16 @@ - | Build 3 `chevron`{=structure} structures condition: | - foundStructure <- structure "chevron" 0; - return $ case foundStructure (\_. false) (\x. fst x >= 3); + def λmatch = \f. \p. match p f end + def λcase = \f. \g. \s. case s f g end + + def length : (rec l. Unit + a * l) -> Int = λcase + (\_. 0) + (λmatch \_. \rest. 1 + length rest) + end + + foundStructures <- structures "chevron"; + pure $ length foundStructures >= 3 robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml @@ -14,8 +14,8 @@ - | Build a `precious`{=structure} structure condition: | - foundStructure <- structure "precious" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "precious"; + pure $ case foundStructure (\_. false) (\_. true); robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml @@ -9,8 +9,11 @@ - | Build 12 copies of the `green_jewel`{=structure} structure condition: | - foundGreen <- structure "green_jewel" 0; - return $ case foundGreen (\_. false) (\x. fst x >= 12); + def length : (rec l. Unit + a * l) -> Int = \l. + case l (\_. 0) (\cons. match cons \_. \rest. 1 + length rest) + end; + foundGreen <- structures "green_jewel"; + pure $ length foundGreen >= 12; robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml @@ -16,11 +16,11 @@ - | Build 2 of the same structure condition: | - foundStructure <- structure "chessboard" 0; - return $ case foundStructure (\_. false) (\fs. - let boardCount = fst fs in - boardCount >= 2; - ); + def length : (rec l. Unit + a * l) -> Int = \l. + case l (\_. 0) (\cons. match cons \_. \rest. 1 + length rest) + end; + foundStructures <- structures "chessboard"; + pure $ length foundStructures >= 2 - id: premature_win teaser: Don't count win early optional: true @@ -29,13 +29,13 @@ Two structures shouldn't be recognized while the bases still possesses `silver`{=entity} condition: | + def length : (rec l. Unit + a * l) -> Int = \l. + case l (\_. 0) (\cons. match cons \_. \rest. 1 + length rest) + end; robotHasSilver <- as base {has "silver"}; - foundStructure <- structure "chessboard" 0; - return $ case foundStructure (\_. false) (\fs. - let boardCount = fst fs in - boardCount >= 2 && robotHasSilver; - ); + foundStructures <- structures "chessboard"; + pure $ length foundStructures >= 2 && robotHasSilver; robots: - name: base dir: south diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml @@ -13,11 +13,11 @@ - | Build 2 of the same structure condition: | - foundStructure <- structure "chessboard" 0; - return $ case foundStructure (\_. false) (\fs. - let boardCount = fst fs in - boardCount >= 2; - ); + def length : (rec l. Unit + a * l) -> Int = \l. + case l (\_. 0) (\cons. match cons \_. \rest. 1 + length rest) + end; + foundStructures <- structures "chessboard"; + pure $ length foundStructures >= 2; - id: premature_win teaser: Don't count win early optional: true @@ -26,13 +26,13 @@ Two structures shouldn't be recognized while the bases still possesses `gold`{=entity} condition: | + def length : (rec l. Unit + a * l) -> Int = \l. + case l (\_. 0) (\cons. match cons \_. \rest. 1 + length rest) + end; robotHasGold <- as base {has "gold"}; - foundStructure <- structure "chessboard" 0; - return $ case foundStructure (\_. false) (\fs. - let boardCount = fst fs in - boardCount >= 2 && robotHasGold; - ); + foundStructures <- structures "chessboard"; + pure $ length foundStructures >= 2 && robotHasGold; robots: - name: base dir: south diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-floorplan-command.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-floorplan-command.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-floorplan-command.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-floorplan-command.yaml @@ -11,8 +11,8 @@ Build a `wooden box`{=structure} structure. condition: | def isRight = \x. case x (\_. false) (\_. true); end; - foundBox <- structure "wooden box" 0; - return $ isRight foundBox; + foundBox <- structures "wooden box"; + pure $ isRight foundBox; robots: - name: base dir: east @@ -41,9 +41,7 @@ end; dims <- floorplan "wooden box"; - let width = fst dims in - let height = snd dims in - + match dims \width. \height. mkRows height width; structures: - name: wooden box diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml @@ -10,8 +10,8 @@ - | Build a `precious`{=structure} structure condition: | - foundStructure <- structure "precious" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "precious"; + pure $ case foundStructure (\_. false) (\_. true); robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml @@ -9,10 +9,6 @@ Additionally, recognition of statically-placed structures at scenario initialization is also unaffected by interior entities. - - However, any such "contaminating" entities - will prevent the recognition of a structure - when constructed by a robot. creative: false objectives: - teaser: Replace rock @@ -21,9 +17,9 @@ - | Place the `rock`{=entity} entity back inside the `pigpen`{=structure}. condition: | - foundBox <- structure "pigpen" 0; - case foundBox (\_. return false) (\struc. - let structPos = snd struc in + foundBoxes <- structures "pigpen"; + case foundBoxes (\_. pure false) (\cons. + match cons \structPos. \_. j <- robotnamed "judge"; as j { structBounds <- floorplan "pigpen"; @@ -32,7 +28,7 @@ teleport self structPos; rockCount <- resonate "rock" ((0, 0), structBounds); - return $ rockCount > 0; + pure $ rockCount > 0; } ); - teaser: Grab rock @@ -53,8 +49,8 @@ even with an extraneous entity within its bounds. condition: | def isRight = \x. case x (\_. false) (\_. true); end; - foundBox <- structure "pigpen" 0; - return $ isRight foundBox; + foundBoxes <- structures "pigpen"; + pure $ isRight foundBoxes; robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-nested-structure-definition.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-nested-structure-definition.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-nested-structure-definition.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-nested-structure-definition.yaml @@ -13,8 +13,8 @@ Replace `tree`{=entity} after grabbing. The `double ring`{=structure} structure should be recognized again. condition: | - foundStructure <- structure "double ring" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "double ring"; + pure $ case foundStructure (\_. false) (\_. true); - teaser: Pre-recognized id: pre_recognized prerequisite: @@ -23,8 +23,8 @@ - | Pre-placed structure must be recognized condition: | - foundStructure <- structure "double ring" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "double ring"; + pure $ case foundStructure (\_. false) (\_. true); - teaser: Grab tree id: grab_tree goal: diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml @@ -11,8 +11,8 @@ - | Build a 3x3 structure condition: | - foundStructure <- structure "large" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "large"; + pure $ case foundStructure (\_. false) (\_. true); - id: wrong_structure teaser: Don't recognize small structure optional: true @@ -20,8 +20,8 @@ - | The small structure shouldn't be recognized. condition: | - foundStructure <- structure "small" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "small"; + pure $ case foundStructure (\_. false) (\_. true); robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml @@ -12,8 +12,8 @@ - | Build a `topleft`{=structure} structure condition: | - foundStructure <- structure "topleft" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "topleft"; + pure $ case foundStructure (\_. false) (\_. true); - id: wrong_structure teaser: Don't recognize small structure optional: true @@ -21,8 +21,8 @@ - | The `bottomright`{=structure} structure shouldn't be recognized. condition: | - foundStructure <- structure "bottomright" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "bottomright"; + pure $ case foundStructure (\_. false) (\_. true); robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml @@ -15,8 +15,8 @@ condition: | def isRight = \x. case x (\_. false) (\_. true); end; - foundGreen <- structure "green_jewel" 0; - return $ isRight foundGreen; + foundGreen <- structures "green_jewel"; + pure $ isRight foundGreen; - id: complete_red_structure optional: true teaser: Complete red structure @@ -26,8 +26,8 @@ condition: | def isRight = \x. case x (\_. false) (\_. true); end; - foundRed <- structure "red_jewel" 0; - return $ isRight foundRed; + foundRed <- structures "red_jewel"; + pure $ isRight foundRed; robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml @@ -11,16 +11,16 @@ - | Remove a piece of the structure to destroy it condition: | - foundStructure <- structure "chessboard" 0; - return $ case foundStructure (\_. true) (\_. false); + foundStructures <- structures "chessboard"; + pure $ case foundStructures (\_. true) (\_. false); - id: complete_structure teaser: Complete structure goal: - | Build a `chessboard`{=structure} structure condition: | - foundStructure <- structure "chessboard" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructures <- structures "chessboard"; + pure $ case foundStructures (\_. false) (\_. true); robots: - name: base dir: south diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml @@ -13,10 +13,10 @@ condition: | def isRight = \x. case x (\_. false) (\_. true); end; - foundBlue <- structure "blue_jewel" 0; - foundGreen <- structure "green_jewel" 0; - foundRed <- structure "red_jewel" 0; - return $ isRight foundBlue && not (isRight foundRed) && not (isRight foundRed); + foundBlue <- structures "blue_jewel"; + foundGreen <- structures "green_jewel"; + foundRed <- structures "red_jewel"; + pure $ isRight foundBlue && not (isRight foundRed) && not (isRight foundRed); - id: complete_green_structure teaser: Complete green structure prerequisite: complete_red_structure @@ -26,9 +26,9 @@ condition: | def isRight = \x. case x (\_. false) (\_. true); end; - foundGreen <- structure "green_jewel" 0; - foundRed <- structure "red_jewel" 0; - return $ isRight foundGreen && not (isRight foundRed); + foundGreen <- structures "green_jewel"; + foundRed <- structures "red_jewel"; + pure $ isRight foundGreen && not (isRight foundRed); - id: complete_red_structure teaser: Complete red structure goal: @@ -37,8 +37,8 @@ condition: | def isRight = \x. case x (\_. false) (\_. true); end; - foundRed <- structure "red_jewel" 0; - return $ isRight foundRed; + foundRed <- structures "red_jewel"; + pure $ isRight foundRed; robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-preplacement-recognition.yaml b/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-preplacement-recognition.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-preplacement-recognition.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-preplacement-recognition.yaml @@ -9,8 +9,8 @@ - | Have a `tee`{=structure} structure condition: | - foundStructure <- structure "tee" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "tee"; + pure $ case foundStructure (\_. false) (\_. true); robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-recognition.yaml b/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-recognition.yaml --- a/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-recognition.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-recognition.yaml @@ -9,8 +9,8 @@ - | Build a `tee`{=structure} structure condition: | - foundStructure <- structure "tee" 0; - return $ case foundStructure (\_. false) (\_. true); + foundStructure <- structures "tee"; + pure $ case foundStructure (\_. false) (\_. true); robots: - name: base dir: east diff --git a/data/scenarios/Testing/1575-structure-recognizer/2115-encroaching-upon-exterior-transparent-cells.yaml b/data/scenarios/Testing/1575-structure-recognizer/2115-encroaching-upon-exterior-transparent-cells.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/2115-encroaching-upon-exterior-transparent-cells.yaml @@ -0,0 +1,77 @@ +version: 1 +name: Structure recognition - exterior transparency +description: | + Incursion of an entity of a foreign type + upon a "transparent" cell within the bounding box + of a recognizable structure shall not prevent + the structure from being recognized. + + If the incurring entity is the *same* type as + a participating entity in that structure, however, + it will prevent recognition. +creative: false +objectives: + - teaser: Recognize structure + goal: + - | + `chevron`{=structure} structure should be recognized upon completion, + even with an extraneous entity within its bounds. + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundBoxes <- structures "chevron"; + pure $ isRight foundBoxes; +robots: + - name: base + dir: east + devices: + - ADT calculator + - blueprint + - fast grabber + - logger + - treads + inventory: + - [1, board] + - name: judge + dir: east + system: true + display: + invisible: true +solution: | + move; move; move; + swap "board"; +structures: + - name: chevron + recognize: [north] + structure: + palette: + 'b': [stone, board] + mask: '.' + map: | + .b + bb + - name: stripe + recognize: [north] + structure: + palette: + 't': [grass, tree] + 'b': [grass, board] + map: | + btb +known: [board, mountain, tree] +world: + dsl: | + {blank} + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + 'j': [grass, erase, judge] + 't': [grass, tree] + 'b': [grass, board] + upperleft: [-7, 3] + map: | + j..... + ...... + .B.ttt + ...bb. + ...... diff --git a/data/scenarios/Testing/1575-structure-recognizer/2115-encroaching-upon-interior-transparent-cells.yaml b/data/scenarios/Testing/1575-structure-recognizer/2115-encroaching-upon-interior-transparent-cells.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/2115-encroaching-upon-interior-transparent-cells.yaml @@ -0,0 +1,85 @@ +version: 1 +name: Structure recognition - interior transparency +description: | + Incursion of an entity of a foreign type + upon a "transparent" cell within the bounding box + of a recognizable structure shall not prevent + the structure from being recognized. + + If the incurring entity is the *same* type as + a participating entity in that structure, however, + it will prevent recognition. +creative: false +objectives: + - teaser: Recognize structure + goal: + - | + `pigpen`{=structure} structure should be recognized upon completion, + even with an extraneous entity within its bounds. + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + foundBoxes <- structures "pigpen"; + pure $ isRight foundBoxes; +robots: + - name: base + dir: east + devices: + - ADT calculator + - blueprint + - fast grabber + - logger + - treads + inventory: + - [1, board] + - name: judge + dir: east + system: true + display: + invisible: true +solution: | + move; move; move; move; + swap "board"; +structures: + - name: pigpen + recognize: [north] + structure: + palette: + 'b': [stone, board] + mask: '.' + map: | + bbbb + b..b + b..b + bbbb + - name: obstruction + recognize: [north] + structure: + palette: + 't': [grass, tree] + 'b': [grass, board] + map: | + tttb +known: [board, mountain, tree] +world: + dsl: | + {blank} + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + 'r': [grass, mountain] + 'j': [grass, erase, judge] + 'p': + structure: + name: pigpen + cell: [grass] + 'b': + structure: + name: obstruction + cell: [grass] + upperleft: [-7, 3] + map: | + j..... + .p.... + ...r.. + B..b.. + ...... diff --git a/data/scenarios/Testing/1575-structure-recognizer/2201-initial-recognition-overlap.yaml b/data/scenarios/Testing/1575-structure-recognizer/2201-initial-recognition-overlap.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/2201-initial-recognition-overlap.yaml @@ -0,0 +1,62 @@ +version: 1 +name: Structure recognition - precluding initial overlaps +description: | + A cell may be a member of at most one structure. + + Since recognition of pre-placed structures bypasses + the regular "search" process, we need to ensure that + overlaps are properly excluded by this alternate mechanism. + In this scenario, only the upper-left structure should be recognized, + based on the precedence criteria (structure size, then grid location) +creative: false +objectives: + - teaser: Recognize exactly one structure + goal: + - | + `square`{=structure} structure should be recognized upon scenario start. + - | + Although two of these structures were initially placed, only + the upper-left one should be recognized. + condition: | + def length : (rec l. Unit + a * l) -> Int = \l. + case l (\_. 0) (\c. match c \_. \tl. 1 + length tl) + end; + foundStructures <- structures "square"; + pure $ length foundStructures == 1; +robots: + - name: base + dir: north + devices: + - ADT calculator + - blueprint + - fast grabber + - logger + - treads +solution: | + noop; +structures: + - name: square + recognize: [north] + structure: + palette: + 'x': [stone, rock] + mask: '.' + map: | + xx + xx +known: [rock] +world: + dsl: | + {blank} + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + 's': + structure: + name: square + cell: [grass] + upperleft: [0, 0] + map: | + ...s... + ....s.. + .B..... diff --git a/data/scenarios/Testing/1575-structure-recognizer/2201-piecewise-lines.yaml b/data/scenarios/Testing/1575-structure-recognizer/2201-piecewise-lines.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/2201-piecewise-lines.yaml @@ -0,0 +1,93 @@ +version: 1 +name: Structure recognition - piecewise row recognition +description: | + Demonstrate general solution for transparency. + + In this scenario, a structure called `spaceship`{=structure} is occluded + by a single cell overlay shape called `damage`{=structure}. + + The base swaps the "damage" entity with the correct part. +creative: false +objectives: + - teaser: Recognize structure + goal: + - | + `spaceship`{=structure} structure should be recognized upon completion. + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + foundStructures <- structures "spaceship"; + pure $ isRight foundStructures; +robots: + - name: base + dir: east + devices: + - ADT calculator + - blueprint + - fast grabber + - logger + - treads + inventory: + - [1, rock] +solution: | + move; move; move; move; move; move; move; + swap "rock"; +structures: + - name: fragment + recognize: [north] + structure: + palette: + 'z': [stone, pixel (R)] + 'w': [stone, pixel (B)] + 'x': [stone, rock] + 'y': [stone, mountain] + mask: '.' + map: | + zw.xy + - name: spaceship + recognize: [north] + structure: + palette: + 'p': [stone, board] + 'x': [stone, rock] + 'y': [stone, mountain] + 'z': [stone, pixel (R)] + 'w': [stone, pixel (B)] + 'q': [stone, pixel (G)] + mask: '.' + map: | + q....xy.zw.xy + qq....ppp.... + q....xy.xy.qq + - name: damage + description: A single-cell overwrite of the spaceship + structure: + palette: + 't': [stone, tree] + map: | + t + - name: modified ship + description: A spaceship with a single cell replaced by a `tree`{=entity} + structure: + placements: + - src: spaceship + - src: damage + offset: [5, 0] + map: "" +known: [board, mountain, rock, tree, pixel (R), pixel (B)] +world: + dsl: | + {blank} + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + 'p': + structure: + name: modified ship + cell: [grass] + upperleft: [100, -100] + map: | + .......... + B.p....... + .......... + .......... + .......... diff --git a/data/scenarios/Testing/1575-structure-recognizer/2201-preclude-overlapping-recognition.yaml b/data/scenarios/Testing/1575-structure-recognizer/2201-preclude-overlapping-recognition.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/2201-preclude-overlapping-recognition.yaml @@ -0,0 +1,94 @@ +version: 1 +name: Structure recognition - precluding overlaps +description: | + A cell may be a member of at most one structure. +creative: false +objectives: + - teaser: Recognize one structure + goal: + - | + `line`{=structure} structure should be recognized upon completion. + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + foundStructures <- structures "line"; + pure $ isRight foundStructures; + - teaser: Recognize second structure + id: found_elbow + optional: true + goal: + - | + `elbow`{=structure} structure should be recognized upon completion. + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + foundStructures <- structures "elbow"; + pure $ isRight foundStructures; + - teaser: Grab tree + prerequisite: + not: found_elbow + goal: + - | + `grab` the `tree`{=entity} to indicate we are done with the test. + condition: | + as base {has "tree"}; +robots: + - name: base + dir: north + devices: + - ADT calculator + - blueprint + - fast grabber + - logger + - treads + inventory: + - [5, rock] +solution: | + place "rock"; move; + place "rock"; move; + place "rock"; + turn right; + move; + turn right; + + // Try to complete a second structure + place "rock"; move; + place "rock"; + + // Grab the tree to indicate completion + turn left; + move; + move; + move; + grab; +structures: + - name: elbow + recognize: [north] + structure: + palette: + 'x': [stone, rock] + mask: '.' + map: | + xx + .x + - name: line + recognize: [north] + structure: + palette: + 'x': [stone, rock] + mask: '.' + map: | + x + x + x +known: [rock] +world: + dsl: | + {blank} + palette: + '.': [grass, erase] + 'T': [grass, tree] + 'B': [grass, erase, base] + upperleft: [0, 0] + map: | + ....... + .....T. + .B..... diff --git a/data/scenarios/Testing/1575-structure-recognizer/2229-position-uniqueness-multiple-orientations.yaml b/data/scenarios/Testing/1575-structure-recognizer/2229-position-uniqueness-multiple-orientations.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/2229-position-uniqueness-multiple-orientations.yaml @@ -0,0 +1,61 @@ +version: 1 +name: Structure recognition - rotated structures at same position +description: | + A map keyed by (position, structure name) would not be sufficient to + account for multiple orientations of the same structure, sharing the + same top-left corner position. + + This is why the found structure registry must include orientation + in its key. +creative: false +objectives: + - teaser: Recognize both structures + goal: + - | + Two `thingy`{=structure} structures should be recognized immediately. + Without distinguishing them by orientation in the registry, only + one would be recognized. + condition: | + def length : (rec l. Unit + a * l) -> Int = \l. + case l (\_. 0) (\c. match c \_. \tl. 1 + length tl) + end; + foundStructures <- structures "thingy"; + pure $ length foundStructures == 2; +robots: + - name: base + dir: north + devices: + - logger +solution: | + noop; +structures: + - name: thingy + recognize: [north, east] + structure: + palette: + 'x': [stone, rock] + 'y': [dirt] + mask: '.' + map: | + y.y + yxx +known: [rock] +world: + dsl: | + {blank} + placements: + - src: thingy + - src: thingy + offset: [0, 0] + orient: + up: east + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + upperleft: [-3, 3] + map: | + .........B. + ........... + ........... + ........... + ........... diff --git a/data/scenarios/Testing/1592-shared-template-robot-say-logs.yaml b/data/scenarios/Testing/1592-shared-template-robot-say-logs.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1592-shared-template-robot-say-logs.yaml @@ -0,0 +1,62 @@ +version: 1 +name: Logs from same-template robots +creative: false +description: | + Logs from different robots generated from the same template. + + The objective checks that base hears one message each tick, + afterwards the integration test checks that all messages + are present in the base log. +objectives: + - goal: + - Please `grab` the `token`{=entity} if you hear what you expected. + condition: | + as base { has "token" } +solution: | + s <- listen; + if (s == "Hello from (2, -2)!") { + s <- listen; + if (s == "Hello from (3, -2)!") { + s <- listen; + if (s == "Hello from (4, -2)!") { + grab; say "OK!" + } {say $ "3: Not what I expected: " ++ s} + } {say $ "2: Not what I expected: " ++ s} + } {say $ "1: Not what I expected: " ++ s} +robots: + - name: base + devices: + - logger + - hearing aid + - comparator + - branch predictor + - string + - grabber + - name: saybot + system: true + display: + invisible: false + attr: blue + program: | + loc <- whereami; + match loc \x. \_. + wait x; + say ("Hello from " ++ format loc ++ "!"); +entities: + - name: token + display: + char: 'W' + properties: + - known + - pickable + description: + - Signals a success. +world: + palette: + '.': [grass] + 'B': [grass, token, base] + 's': [grass, null, saybot] + map: | + B...s + ...ss + ..sss diff --git a/data/scenarios/Testing/1598-detect-entity-change.yaml b/data/scenarios/Testing/1598-detect-entity-change.yaml --- a/data/scenarios/Testing/1598-detect-entity-change.yaml +++ b/data/scenarios/Testing/1598-detect-entity-change.yaml @@ -100,7 +100,6 @@ dsl: | {blank} upperleft: [-1, -1] - offset: false palette: '.': [grass, erase] 'B': [grass, erase, base] diff --git a/data/scenarios/Testing/1631-tags.yaml b/data/scenarios/Testing/1631-tags.yaml --- a/data/scenarios/Testing/1631-tags.yaml +++ b/data/scenarios/Testing/1631-tags.yaml @@ -14,41 +14,29 @@ id: got_fruit optional: true condition: | - // Returns true if prohibited item is in inventory. - def checkFruit = \idx. - result <- tagmembers "fruit" idx; - let totalCount = fst result in - let member = snd result in - let nextIdx = idx + 1 in - - hasProhibited <- as base {has member}; - if hasProhibited { - return true; - } { - if (nextIdx < totalCount) { - checkFruit nextIdx; - } { - return false; - } - } - end; + def hasAny : (rec l. Unit + Text * l) -> Cmd Bool = \items. + case items + (\_. pure false) + (\c. match c \hd. \tl. b <- has hd; if b {pure true} {hasAny tl}) + end; - checkFruit 0; + let prohibited = tagmembers "fruit" in + hasAny prohibited goal: - | Do not pick up any fruit. solution: | def findTarget = result <- scan down; - isTarget <- case result (\_. return false) (\item. - isEdible <- hastag item "edible"; - isFruit <- hastag item "fruit"; - return $ isEdible && not isFruit; + isTarget <- case result (\_. pure false) (\item. + let isEdible = hastag item "edible" in + let isFruit = hastag item "fruit" in + pure $ isEdible && not isFruit; ); if isTarget { grab; - return (); + pure (); } { move; findTarget; diff --git a/data/scenarios/Testing/1634-message-colors.yaml b/data/scenarios/Testing/1634-message-colors.yaml --- a/data/scenarios/Testing/1634-message-colors.yaml +++ b/data/scenarios/Testing/1634-message-colors.yaml @@ -14,7 +14,8 @@ attr: blue program: | loc <- whereami; - let idx = -(snd loc) in + match loc \_. \y. + let idx = -y in wait $ idx + 1; say $ "Hello saybot" ++ format idx; world: diff --git a/data/scenarios/Testing/1642-biomes.yaml b/data/scenarios/Testing/1642-biomes.yaml --- a/data/scenarios/Testing/1642-biomes.yaml +++ b/data/scenarios/Testing/1642-biomes.yaml @@ -15,7 +15,7 @@ condition: | as base { c <- count "wheat"; - return $ c == 2; + pure $ c == 2; } - id: western_wheat_regrew optional: true @@ -40,7 +40,7 @@ baseLoc <- as base {whereami}; as goalbot { goalLoc <- whereami; - return $ baseLoc == goalLoc; + pure $ baseLoc == goalLoc; } prerequisite: logic: @@ -67,15 +67,6 @@ dir: east system: true entities: - - name: wheat - display: - char: 'w' - attr: gold - description: - - Grain - properties: [known, pickable, growable] - growth: [2, 4] - biomes: [dirt] - name: scythe display: char: 'y' diff --git a/data/scenarios/Testing/1721-custom-walkable-entities.yaml b/data/scenarios/Testing/1721-custom-walkable-entities.yaml --- a/data/scenarios/Testing/1721-custom-walkable-entities.yaml +++ b/data/scenarios/Testing/1721-custom-walkable-entities.yaml @@ -16,7 +16,7 @@ m <- robotnamed "monkey"; as m { p <- path (inR 10) (inR "banana"); - return $ case p (\_. false) (\_. true); + pure $ case p (\_. false) (\_. true); }; - id: placed_tree teaser: Tree placed @@ -26,7 +26,7 @@ - Tree must be placed condition: | x <- as base {has "tree"}; - return $ not x; + pure $ not x; solution: | move; move; diff --git a/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml b/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml --- a/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml +++ b/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml @@ -9,13 +9,13 @@ as base {ishere "platform"} solution: | def goDir = \f. \result. - let d = fst result in - if (d == down) {return ()} {turn d; move; f;} + match result \d. \_. + if (d == down) {pure ()} {turn d; move; f;} end; def followRoute = nextDir <- path (inL ()) (inR "platform"); - case nextDir return $ goDir followRoute; + case nextDir pure $ goDir followRoute; end; followRoute; diff --git a/data/scenarios/Testing/1747-volume-command.yaml b/data/scenarios/Testing/1747-volume-command.yaml --- a/data/scenarios/Testing/1747-volume-command.yaml +++ b/data/scenarios/Testing/1747-volume-command.yaml @@ -11,7 +11,7 @@ as base { let targetVolume = 14 in vol <- volume targetVolume; - return $case vol (\_. false) (\x. x == targetVolume); + pure $case vol (\_. false) (\x. x == targetVolume); } solution: | move; diff --git a/data/scenarios/Testing/1777-capability-cost.yaml b/data/scenarios/Testing/1777-capability-cost.yaml --- a/data/scenarios/Testing/1777-capability-cost.yaml +++ b/data/scenarios/Testing/1777-capability-cost.yaml @@ -17,10 +17,10 @@ judge <- robotnamed "judge"; as judge { maybePath <- path (inL ()) (inR "packing peanut"); - return $ case maybePath (\_. true) (\d. false); + pure $ case maybePath (\_. true) (\d. false); } } { - return false; + pure false; }; solution: | move; diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt b/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt --- a/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt +++ b/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt @@ -1,3 +1,6 @@ nonoverlapping-structure-merge.yaml root-map-expansion.yaml structure-composition.yaml +sequential-placement.yaml +coordinate-offset-propagation.yaml +simultaneous-north-and-west-offset.yaml diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/coordinate-offset-propagation.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/coordinate-offset-propagation.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/coordinate-offset-propagation.yaml @@ -0,0 +1,77 @@ +version: 1 +name: Structure coordinate offset propagation +author: Karl Ostmo +description: | + If a structure incorporates subplacements + entailing negative offsets, its coordinate origin must be shifted. + + The updated coordinate origin should be propagated to parent structures + and utilized to offset placement. +robots: + - name: base + dir: north + loc: [0, 3] +objectives: + - goal: + - Enjoy the view. + condition: | + pure true +solution: | + noop +known: [boulder, log, pixel (R), pixel (G), pixel (B), gold] +world: + structures: + - name: micro + structure: + mask: '.' + palette: + 'x': [stone, gold] + map: | + xx + - name: block + structure: + mask: '.' + palette: + 'x': [stone, pixel (R)] + map: | + xx + xx + - name: master + structure: + mask: '.' + palette: + 'x': [stone, pixel (B)] + placements: + - src: block + offset: [0, 1] + - src: micro + offset: [-2, 0] + map: | + ..x + ..x + ..x + - name: final + structure: + mask: '.' + palette: + 'x': [stone, pixel (G)] + placements: + - src: master + map: | + x + x + x + x + dsl: | + overlay + [ {grass} + , mask (y > -4 && y < 4 || x > -4 && x < 4) {stone} + , mask (y > -2 && y < 2 || x > -2 && x < 2) {ice} + , mask (y > -1 && y < 1 || x > -1 && x < 1) {dirt} + ] + mask: '.' + placements: + - src: final + offset: [0, 0] + upperleft: [0, 0] + map: "" diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/sequential-placement.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/sequential-placement.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/sequential-placement.yaml @@ -0,0 +1,95 @@ +version: 1 +name: Flipped structure placement +author: Karl Ostmo +description: | + Sequentially place structures that are larger than the map + with flipped orientation. +robots: + - name: base + dir: north +creative: true +objectives: + - goal: + - Must have 3 of each color visible + condition: | + def countColor = \e. + resonate e ((-6, 0), (4, -4)); + end; + + as base { + r <- countColor "pixel (R)"; + g <- countColor "pixel (G)"; + b <- countColor "pixel (B)"; + y <- countColor "gold"; + pure $ r == 3 && g == 3 && b == 3 && y == 3; + } +solution: | + noop +known: [boulder, log, pixel (R), pixel (G), pixel (B), gold] +world: + structures: + - name: reddish + structure: + mask: '.' + palette: + 'x': [stone, pixel (R)] + map: | + xx + x. + - name: greenish + structure: + mask: '.' + palette: + 'x': [stone, pixel (G)] + map: | + xx + x. + - name: bluish + structure: + mask: '.' + palette: + 'x': [stone, pixel (B)] + map: | + xx + x. + - name: goldish + structure: + mask: '.' + palette: + 'x': [stone, gold] + map: | + xx + x. + - name: block + structure: + mask: '.' + palette: + 'x': [ice, log] + placements: + - src: greenish + orient: + flip: true + offset: [-3, 2] + - src: reddish + offset: [-6, 0] + - src: goldish + orient: + flip: true + offset: [3, -1] + - src: bluish + offset: [0, 1] + map: | + xxx + xx. + x.. + palette: + 'Ω': [grass, erase, base] + mask: '.' + placements: + - src: block + offset: [0, -2] + upperleft: [0, 0] + dsl: | + {grass} + map: | + Ω diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml @@ -0,0 +1,56 @@ +version: 1 +name: Northwest sibling structure coordinate offsets +author: Karl Ostmo +description: | + Make sure that the second sibling is displayed correctly when there + is a simultaneous negative-x and positive-y offset on the first sibling. +robots: + - name: base + dir: north + loc: [0, 2] +objectives: + - goal: + - Enjoy the view. + condition: | + pure true +solution: | + noop +known: [pixel (R), gold] +world: + structures: + - name: micro + structure: + mask: '.' + palette: + 'x': [stone, gold] + map: | + x + - name: block + structure: + mask: '.' + palette: + 'x': [stone, pixel (R)] + map: | + xx + xx + - name: master + structure: + mask: '.' + placements: + - src: micro + offset: [-1, 1] + - src: block + map: "" + dsl: | + overlay + [ {grass} + , mask (y > -4 && y < 4 || x > -4 && x < 4) {stone} + , mask (y > -2 && y < 2 || x > -2 && x < 2) {ice} + , mask (y > -1 && y < 1 || x > -1 && x < 1) {dirt} + ] + mask: '.' + placements: + - src: master + offset: [0, 0] + upperleft: [0, 0] + map: "" diff --git a/data/scenarios/Testing/201-require/00-ORDER.txt b/data/scenarios/Testing/201-require/00-ORDER.txt --- a/data/scenarios/Testing/201-require/00-ORDER.txt +++ b/data/scenarios/Testing/201-require/00-ORDER.txt @@ -1,8 +1,8 @@ 201-require-device.yaml 201-require-device-creative.yaml 201-require-device-creative1.yaml -201-require-entities.yaml -201-require-entities-def.yaml +201-stock-entities.yaml +201-stock-entities-def.yaml 533-reprogram-simple.yaml 533-reprogram.yaml 1664-require-system-robot-children.yaml diff --git a/data/scenarios/Testing/201-require/1664-require-system-robot-children.yaml b/data/scenarios/Testing/201-require/1664-require-system-robot-children.yaml --- a/data/scenarios/Testing/201-require/1664-require-system-robot-children.yaml +++ b/data/scenarios/Testing/201-require/1664-require-system-robot-children.yaml @@ -11,9 +11,9 @@ - condition: | try { robotnamed "childbot"; - return true; + pure true; } { - return false; + pure false; } solution: | noop; diff --git a/data/scenarios/Testing/201-require/201-require-device-creative.yaml b/data/scenarios/Testing/201-require/201-require-device-creative.yaml --- a/data/scenarios/Testing/201-require/201-require-device-creative.yaml +++ b/data/scenarios/Testing/201-require/201-require-device-creative.yaml @@ -11,8 +11,8 @@ boatEquipped <- as r {equipped "boat"}; b1 <- as r {count "boat"}; b0 <- as base {count "boat"}; - return (p == (2,0) && b0 == 0 && boatEquipped && b1 == 0); - } { return false } + pure (p == (2,0) && b0 == 0 && boatEquipped && b1 == 0); + } { pure false } creative: true solution: | build {require "boat"; move; move} @@ -28,14 +28,9 @@ palette: '.': [grass] '~': [dirt, water] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │.~.│ - └───┘ + +++++ + +.~.+ + +++++ diff --git a/data/scenarios/Testing/201-require/201-require-device-creative1.yaml b/data/scenarios/Testing/201-require/201-require-device-creative1.yaml --- a/data/scenarios/Testing/201-require/201-require-device-creative1.yaml +++ b/data/scenarios/Testing/201-require/201-require-device-creative1.yaml @@ -11,8 +11,8 @@ boatEquipped <- as r {equipped "boat"}; b1 <- as r {count "boat"}; b0 <- as base {count "boat"}; - return (p == (2,0) && b0 == 1 && boatEquipped && b1 == 0); - } { return false } + pure (p == (2,0) && b0 == 1 && boatEquipped && b1 == 0); + } { pure false } creative: true solution: | build {require "boat"; move; move} @@ -29,17 +29,12 @@ palette: '.': [grass] '~': [dirt, knownwater] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │.~.│ - └───┘ + +++++ + +.~.+ + +++++ entities: - name: knownwater display: diff --git a/data/scenarios/Testing/201-require/201-require-device.yaml b/data/scenarios/Testing/201-require/201-require-device.yaml --- a/data/scenarios/Testing/201-require/201-require-device.yaml +++ b/data/scenarios/Testing/201-require/201-require-device.yaml @@ -11,8 +11,8 @@ boatEquipped <- as r {equipped "boat"}; b1 <- as r {count "boat"}; b0 <- as base {count "boat"}; - return (p == (2,0) && b0 == 0 && boatEquipped && b1 == 0); - } { return false } + pure (p == (2,0) && b0 == 0 && boatEquipped && b1 == 0); + } { pure false } solution: | build {require "boat"; move; require "boat"; move} robots: @@ -31,14 +31,9 @@ palette: '.': [grass] '~': [dirt, water] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │.~.│ - └───┘ + +++++ + +.~.+ + +++++ diff --git a/data/scenarios/Testing/201-require/201-require-entities-def.yaml b/data/scenarios/Testing/201-require/201-require-entities-def.yaml deleted file mode 100644 --- a/data/scenarios/Testing/201-require/201-require-entities-def.yaml +++ /dev/null @@ -1,45 +0,0 @@ -version: 1 -name: Require entities with definition -description: | - Require some entities using the 'require' command, and a definition. - https://github.com/swarm-game/swarm/issues/201 -objectives: - - condition: | - try { - r <- robotNumbered 1; - p <- as r {whereami}; - r1 <- as r {count "rock"}; - r0 <- as base {count "rock"}; - return (p == (4,0) && r0 == 5 && r1 == 1); - } { return false } -solution: | - def mp = move; place "rock" end; - build { log "hi"; require 5 "rock"; mp; mp; mp; mp } -robots: - - name: base - loc: [0, 0] - dir: east - devices: - - 3D printer - - logger - - dictionary - inventory: - - [10, rock] - - [1, solar panel] - - [1, treads] - - [1, grabber] - - [1, logger] -world: - palette: - '.': [grass] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] - upperleft: [-1, 1] - map: | - ┌─────┐ - │.....│ - └─────┘ diff --git a/data/scenarios/Testing/201-require/201-require-entities.yaml b/data/scenarios/Testing/201-require/201-require-entities.yaml deleted file mode 100644 --- a/data/scenarios/Testing/201-require/201-require-entities.yaml +++ /dev/null @@ -1,43 +0,0 @@ -version: 1 -name: Require entities -description: | - Require some entities using the 'require' command. - https://github.com/swarm-game/swarm/issues/201 -objectives: - - condition: | - try { - r <- robotNumbered 1; - r1 <- as r {count "rock"}; - r0 <- as base {count "rock"}; - return (r0 == 5 && r1 == 3); - } { return false } -solution: | - build { require 5 "rock"; move; place "rock"; move; place "rock" } -robots: - - name: base - loc: [0, 0] - dir: east - devices: - - 3D printer - - logger - - dictionary - inventory: - - [10, rock] - - [1, solar panel] - - [1, treads] - - [1, grabber] - - [1, logger] -world: - palette: - '.': [grass] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] - upperleft: [-1, 1] - map: | - ┌───┐ - │...│ - └───┘ diff --git a/data/scenarios/Testing/201-require/201-stock-entities-def.yaml b/data/scenarios/Testing/201-require/201-stock-entities-def.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/201-stock-entities-def.yaml @@ -0,0 +1,40 @@ +version: 1 +name: Stock entities with definition +description: | + Stock some entities using the 'stock' command, and a definition. + https://github.com/swarm-game/swarm/issues/201 +objectives: + - condition: | + try { + r <- robotNumbered 1; + p <- as r {whereami}; + r1 <- as r {count "rock"}; + r0 <- as base {count "rock"}; + pure (p == (4,0) && r0 == 5 && r1 == 1); + } { pure false } +solution: | + def mp = move; place "rock" end; + build { log "hi"; stock 5 "rock"; mp; mp; mp; mp } +robots: + - name: base + loc: [0, 0] + dir: east + devices: + - 3D printer + - logger + - dictionary + inventory: + - [10, rock] + - [1, solar panel] + - [1, treads] + - [1, grabber] + - [1, logger] +world: + palette: + '.': [grass] + '+': [stone, wall] + upperleft: [-1, 1] + map: | + +++++++ + +.....+ + +++++++ diff --git a/data/scenarios/Testing/201-require/201-stock-entities.yaml b/data/scenarios/Testing/201-require/201-stock-entities.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/201-stock-entities.yaml @@ -0,0 +1,38 @@ +version: 1 +name: Stock entities +description: | + Stock some entities using the 'stock' command. + https://github.com/swarm-game/swarm/issues/201 +objectives: + - condition: | + try { + r <- robotNumbered 1; + r1 <- as r {count "rock"}; + r0 <- as base {count "rock"}; + pure (r0 == 5 && r1 == 3); + } { pure false } +solution: | + build { stock 5 "rock"; move; place "rock"; move; place "rock" } +robots: + - name: base + loc: [0, 0] + dir: east + devices: + - 3D printer + - logger + - dictionary + inventory: + - [10, rock] + - [1, solar panel] + - [1, treads] + - [1, grabber] + - [1, logger] +world: + palette: + '.': [grass] + '+': [stone, wall] + upperleft: [-1, 1] + map: | + +++++ + +...+ + +++++ diff --git a/data/scenarios/Testing/201-require/533-reprogram-simple.yaml b/data/scenarios/Testing/201-require/533-reprogram-simple.yaml --- a/data/scenarios/Testing/201-require/533-reprogram-simple.yaml +++ b/data/scenarios/Testing/201-require/533-reprogram-simple.yaml @@ -19,12 +19,12 @@ solarEquipped <- as fred {equipped "solar panel"}; treadsEquipped <- as fred {equipped "treads"}; - return (p == (2,0) + pure (p == (2,0) && boatEquipped && drillEquipped && solarEquipped && treadsEquipped && base_boats == 1 && base_solar == 1 && base_treads == 1 && base_drills == 1 ); - } { return false } + } { pure false } solution: | fred <- build {require "boat"; setname "fred"}; wait 5; @@ -49,14 +49,9 @@ palette: '.': [grass] '~': [dirt, water] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │.~.│ - └───┘ + +++++ + +.~.+ + +++++ diff --git a/data/scenarios/Testing/201-require/533-reprogram.yaml b/data/scenarios/Testing/201-require/533-reprogram.yaml --- a/data/scenarios/Testing/201-require/533-reprogram.yaml +++ b/data/scenarios/Testing/201-require/533-reprogram.yaml @@ -19,16 +19,16 @@ drillEquipped <- as fred {equipped "metal drill"}; fred_rocks <- as fred {count "rock"}; - return (p == (2,0) && boatEquipped && drillEquipped + pure (p == (2,0) && boatEquipped && drillEquipped && base_boats == 1 && base_solar == 1 && base_treads == 1 && base_drills == 1 && base_rocks == 42 && fred_rocks == 8 ); - } { return false } + } { pure false } solution: | - fred <- build {require "boat"; require 5 "rock"; setname "fred"}; + fred <- build {require "boat"; stock 5 "rock"; setname "fred"}; wait 5; - reprogram fred {require "boat"; require "metal drill"; move; require 3 "rock"; move; require 5 "rock"} + reprogram fred {require "boat"; require "metal drill"; move; stock 3 "rock"; move; stock 5 "rock"} robots: - name: base loc: [0, 0] @@ -49,14 +49,9 @@ palette: '.': [grass] '~': [dirt, water] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │.~.│ - └───┘ + +++++ + +.~.+ + +++++ diff --git a/data/scenarios/Testing/2085-toplevel-mask.yaml b/data/scenarios/Testing/2085-toplevel-mask.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/2085-toplevel-mask.yaml @@ -0,0 +1,44 @@ +version: 1 +name: Toplevel palette mask +description: | + Demo equivalence of 'blank' terrain and + the 'mask' property for producing transparent cells. +seed: 0 +objectives: + - goal: + - | + `grab` a `flower`{=entity}. + condition: | + as base {has "flower"}; +solution: | + move; move; grab; +robots: + - name: base + dir: east + devices: + - treads + - logger + - grabber +known: [water, flower] +world: + dsl: | + overlay [ + {grass}, + mask ((x + y) % 2 == 0) {flower} + ] + upperleft: [-4, 4] + mask: x + palette: + 'B': [stone, erase, base] + '.': [stone, erase] + 'y': [blank] + map: |- + yyy...xxx + y.......x + y.......x + ......... + ....Bxxxx + ......... + x.......y + x.......y + xxx...yyy diff --git a/data/scenarios/Testing/2086-structure-palette.yaml b/data/scenarios/Testing/2086-structure-palette.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/2086-structure-palette.yaml @@ -0,0 +1,54 @@ +version: 1 +name: Structure markers +description: | + Reference structures in the palette +seed: 0 +objectives: + - goal: + - | + `grab` a `tree`{=entity}. + condition: | + as base {has "tree"}; +solution: | + move; move; grab; +robots: + - name: base + dir: east + devices: + - treads + - logger + - grabber +structures: + - name: rect + structure: + palette: + 'o': [dirt, tree] + map: | + ooo + ooo +known: [water, tree] +world: + dsl: | + {grass} + palette: + 'B': [stone, erase, base] + '.': [stone] + 'x': + structure: + name: rect + cell: [grass] + 'z': + structure: + name: rect + orientation: + up: east + cell: [grass] + map: |- + ...... + ...z.. + ...... + .B.... + ...... + .x.... + ...... + ...... diff --git a/data/scenarios/Testing/2239-custom-entity.yaml b/data/scenarios/Testing/2239-custom-entity.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/2239-custom-entity.yaml @@ -0,0 +1,42 @@ +version: 1 +name: Custom entity +description: | + Custom entity overriding standard entity +creative: false +objectives: + - goal: + - Move to (1,0) + condition: | + as base { + loc <- whereami; + pure $ loc == (1,0) + }; +entities: + - name: rock + display: + char: '$' + attr: gold + description: + - Not your average rock! + properties: [pickable] + capabilities: [move] +robots: + - name: base + dir: east + devices: + - logger + - grabber + - welder +solution: | + grab; + equip "rock"; + move +known: [rock] +world: + dsl: | + {grass} + palette: + 'B': [grass, rock, base] + upperleft: [0, 0] + map: | + B diff --git a/data/scenarios/Testing/2240-overridden-entity-capabilities.yaml b/data/scenarios/Testing/2240-overridden-entity-capabilities.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/2240-overridden-entity-capabilities.yaml @@ -0,0 +1,49 @@ +version: 1 +name: Overridden entity capabilities +description: | + Overridden standard entity should not still be suggested for its + capabilities. The error message should suggest "- tank treads", not + "- treads or tank treads". +creative: false +objectives: + - goal: + - Place a rock + condition: | + as base { + isHere "rock" + }; +entities: + - name: treads + display: + char: '#' + attr: red + description: + - Broken treads + properties: [known, pickable] +robots: + - name: base + dir: east + devices: + - logger + - clock + - grabber + inventory: + - [1, rock] + - name: crasher + dir: east + devices: + - logger + - treads + program: | + move +solution: | + wait 5; place "rock" +world: + dsl: | + {grass} + palette: + 'C': [grass, null, crasher] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + BC diff --git a/data/scenarios/Testing/2253-halt-waiting.yaml b/data/scenarios/Testing/2253-halt-waiting.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/2253-halt-waiting.yaml @@ -0,0 +1,27 @@ +version: 1 +name: Halt a waiting robot +description: | + Calling `halt` on a waiting robot should make it immediately idle, + so it can e.g. be `reprogram`med +creative: true +objectives: + - goal: + - Get some gold + condition: | + as base { has "gold" }; +robots: + - name: base + dir: north + devices: + - logger +solution: | + r <- build {move; wait 10000}; + wait 2; + halt r; wait 1; reprogram r {create "gold"; give base "gold"} +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + map: | + B diff --git a/data/scenarios/Testing/2270-instant-defs.yaml b/data/scenarios/Testing/2270-instant-defs.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/2270-instant-defs.yaml @@ -0,0 +1,42 @@ +version: 1 +name: Instant wrapped defs +description: | + `instant` should work when wrapped around definitions +creative: false +objectives: + - goal: + - Grab the rock + condition: | + as base { has "rock" } +robots: + - name: base + dir: east + devices: + - logger + - treads + - grabber + - name: judge + dir: east + system: true + program: | + instant ( + def fib : Int -> Int = \n. + if (n <= 1) {n} {fib (n-1) + fib (n-2)} + end + + def x = fib 10 end + + create "rock"; place "rock" + ) +solution: | + move; grab +known: [rock] +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + 'j': [grass, null, judge] + upperleft: [0, 0] + map: | + Bj diff --git a/data/scenarios/Testing/231-requirements/231-command-transformer-reqs.yaml b/data/scenarios/Testing/231-requirements/231-command-transformer-reqs.yaml --- a/data/scenarios/Testing/231-requirements/231-command-transformer-reqs.yaml +++ b/data/scenarios/Testing/231-requirements/231-command-transformer-reqs.yaml @@ -4,7 +4,7 @@ A function transforming a command correctly accumulates requirements. creative: false solution: | - def pr = require 1 "rock"; move; place "rock" end + def pr = stock 1 "rock"; move; place "rock" end def x4 = \c. c;c;c;c end build {x4 pr} objectives: diff --git a/data/scenarios/Testing/373-drill.yaml b/data/scenarios/Testing/373-drill.yaml --- a/data/scenarios/Testing/373-drill.yaml +++ b/data/scenarios/Testing/373-drill.yaml @@ -9,8 +9,8 @@ i <- as base {has "iron ore"}; c <- as base {has "copper ore"}; s <- as base {has "rock"}; - return (i && c && s) - } { return false } + pure (i && c && s) + } { pure false } solution: | build { move; drill forward; turn back; move; turn left; @@ -49,23 +49,18 @@ '~': [ice, wavy water] 'L': [grass, Linux] 'T': [grass, tree] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] 'A': [stone, mountain] 'C': [stone, copper vein] '@': [stone, boulder] 'I': [stone, iron vein] upperleft: [-1, 1] map: | - ┌─────┐ ~~ - │IAAT~ ~L~ - │..@AA│ ~~ - │Ω...C│ ~ - └─────┘ ~ + +++++++ ~~ + +IAAT~ ~L~ + +..@AA+ ~~ + +Ω...C+ ~ + +++++++ ~ entities: - name: copper vein display: diff --git a/data/scenarios/Testing/378-objectives.yaml b/data/scenarios/Testing/378-objectives.yaml --- a/data/scenarios/Testing/378-objectives.yaml +++ b/data/scenarios/Testing/378-objectives.yaml @@ -10,12 +10,12 @@ condition: | try { n <- as base {count "tree"}; - return (n >= 3) - } { return false } + pure (n >= 3) + } { pure false } - goal: - Nice job. Now, build a harvester. condition: | - try { as base {has "harvester"} } {return false} + try { as base {has "harvester"} } {pure false} prerequisite: get_trees solution: | build {turn right; move; move; grab; move; grab; move; grab; turn back; move; move; move; move}; @@ -50,14 +50,9 @@ 'Ω': [grass, null, base] '.': [grass] 'T': [grass, tree] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌────────┐ - │Ω.TTTTTT│ - └────────┘ + ++++++++++ + +Ω.TTTTTT+ + ++++++++++ diff --git a/data/scenarios/Testing/394-build-drill.yaml b/data/scenarios/Testing/394-build-drill.yaml --- a/data/scenarios/Testing/394-build-drill.yaml +++ b/data/scenarios/Testing/394-build-drill.yaml @@ -7,12 +7,12 @@ objectives: - condition: | try { - as base {l <- has "detonator"; return (not l)} - } { return false } + as base {l <- has "detonator"; pure (not l)} + } { pure false } # When testing, add `s <- build {...}; n <- as s {whoami}; log n` solution: | def forever = \c. c ; forever c end; - def unblock = try {drill forward; return ()} {} end; + def unblock = try {drill forward; pure ()} {} end; def doPush = unblock; move end; log "Hi, I am base"; r <- build { @@ -44,14 +44,9 @@ palette: '.': [grass] 'M': [stone, mountain] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │..M│ - └───┘ + +++++ + +..M+ + +++++ diff --git a/data/scenarios/Testing/397-wrong-missing.yaml b/data/scenarios/Testing/397-wrong-missing.yaml --- a/data/scenarios/Testing/397-wrong-missing.yaml +++ b/data/scenarios/Testing/397-wrong-missing.yaml @@ -8,7 +8,7 @@ https://github.com/swarm-game/swarm/issues/397 objectives: - condition: | - t <- time; return (t == 2) + t <- time; pure (t == 2) goal: - | This is a dummy condition that just ensures the base has had diff --git a/data/scenarios/Testing/428-drowning-destroy.yaml b/data/scenarios/Testing/428-drowning-destroy.yaml --- a/data/scenarios/Testing/428-drowning-destroy.yaml +++ b/data/scenarios/Testing/428-drowning-destroy.yaml @@ -8,13 +8,13 @@ def isAlive = \n. try { _ <- robotNamed n; log ("Is alive: " ++ n); - return true - } { return false } end; + pure true + } { pure false } end; try { baseAlive <- isAlive "base"; botAlive <- isAlive "bot"; - return (baseAlive && not botAlive); - } { return false; } + pure (baseAlive && not botAlive); + } { pure false; } solution: | log "start"; wait 5; @@ -37,15 +37,10 @@ palette: '.': [grass] ' ': [ice, water] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌──┐ - │. │ - │. │ - └──┘ + ++++ + +. + + +. + + ++++ diff --git a/data/scenarios/Testing/475-wait-one.yaml b/data/scenarios/Testing/475-wait-one.yaml --- a/data/scenarios/Testing/475-wait-one.yaml +++ b/data/scenarios/Testing/475-wait-one.yaml @@ -11,9 +11,9 @@ try { teleport self (0,0); ishere "lambda" - } { return false } + } { pure false } solution: | - log "I will win next tick!"; place "lambda"; + log "I will win next tick!"; wait 1; place "lambda"; robots: - name: base loc: [0, 0] @@ -21,6 +21,7 @@ devices: - logger - grabber + - clock inventory: - [1, lambda] - name: sleeper @@ -30,21 +31,16 @@ - logger - clock program: | - log "I shall sleep"; wait 1; log "I have awoken" + log "I shall sleep"; wait 2; log "I have awoken" world: palette: '.': [grass] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] 'λ': [grass, lambda] upperleft: [-1, 1] map: | - ┌─────┐ - │..λ..│ - │....λ│ - │...λ.│ - └─────┘ + +++++++ + +..λ..+ + +....λ+ + +...λ.+ + +++++++ diff --git a/data/scenarios/Testing/479-atomic-race.yaml b/data/scenarios/Testing/479-atomic-race.yaml --- a/data/scenarios/Testing/479-atomic-race.yaml +++ b/data/scenarios/Testing/479-atomic-race.yaml @@ -28,7 +28,7 @@ try { p <- robotNamed "planter"; as p {has "Win"} - } { return false } + } { pure false } solution: | def forever = \c. force c ; forever c end def tryharvest = diff --git a/data/scenarios/Testing/479-atomic.yaml b/data/scenarios/Testing/479-atomic.yaml --- a/data/scenarios/Testing/479-atomic.yaml +++ b/data/scenarios/Testing/479-atomic.yaml @@ -11,14 +11,14 @@ - condition: | try { p <- robotNamed "planter"; - as p {n <- count "weed"; return (n == 0)} - } { return false } + as p {n <- count "weed"; pure (n == 0)} + } { pure false } solution: | def forever = \c. force c ; forever c end def tryharvest = atomic ( b <- ishere "weed"; - if b {harvest; return ()} {} + if b {harvest; pure ()} {} ); n <- random 4; wait n end; diff --git a/data/scenarios/Testing/490-harvest.yaml b/data/scenarios/Testing/490-harvest.yaml --- a/data/scenarios/Testing/490-harvest.yaml +++ b/data/scenarios/Testing/490-harvest.yaml @@ -11,9 +11,9 @@ t1 <- ishere "tree"; move; t2 <- ishere "tree"; - t3 <- as base {n <- count "water"; return (n == 4)}; - return (t1 && not t2 && t3) - } { return false } + t3 <- as base {n <- count "water"; pure (n == 4)}; + pure (t1 && not t2 && t3) + } { pure false } solution: | move; harvest; move; grab; turn right; move; grab; grab; harvest; grab robots: @@ -29,16 +29,11 @@ palette: '.': [grass] 'T': [stone, tree] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] '~': [stone, water] upperleft: [-1, 1] map: | - ┌───┐ - │.TT│ - │~~~│ - └───┘ + +++++ + +.TT+ + +~~~+ + +++++ diff --git a/data/scenarios/Testing/504-teleport-self.yaml b/data/scenarios/Testing/504-teleport-self.yaml --- a/data/scenarios/Testing/504-teleport-self.yaml +++ b/data/scenarios/Testing/504-teleport-self.yaml @@ -9,7 +9,7 @@ create "tree"; place "tree"; teleport self (5,0); ishere "tree" - } { return false } + } { pure false } solution: | place "tree" robots: @@ -25,14 +25,9 @@ world: palette: '.': [grass] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌──────┐ - │......│ - └──────┘ + ++++++++ + +......+ + ++++++++ diff --git a/data/scenarios/Testing/508-capability-subset.yaml b/data/scenarios/Testing/508-capability-subset.yaml --- a/data/scenarios/Testing/508-capability-subset.yaml +++ b/data/scenarios/Testing/508-capability-subset.yaml @@ -10,8 +10,8 @@ p <- as r {whereami}; g <- as base {count "GPS"}; t <- as base {count "Tardis"}; - return (p == (5,0) && g == 1 && t == 0); - } { return false } + pure (p == (5,0) && g == 1 && t == 0); + } { pure false } solution: | log "Hi, I can build teleporting robots!"; try { @@ -42,17 +42,12 @@ palette: '.': [grass, erase] ' ': [ice, water] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌─┐ ┌─┐ - │.│ │.│ - └─┘ └─┘ + +++ +++ + +.+ +.+ + +++ +++ entities: - name: GPS display: @@ -61,7 +56,7 @@ description: - A satellite navigation device. properties: [known, pickable] - capabilities: [senseloc] + capabilities: [whereami] - name: Tardis display: attr: water @@ -69,4 +64,4 @@ description: - Bigger on the inside. properties: [known, pickable] - capabilities: [senseloc, teleport] + capabilities: [whereami, teleport] diff --git a/data/scenarios/Testing/555-teleport-location.yaml b/data/scenarios/Testing/555-teleport-location.yaml --- a/data/scenarios/Testing/555-teleport-location.yaml +++ b/data/scenarios/Testing/555-teleport-location.yaml @@ -8,7 +8,7 @@ - condition: | try { as base {has "rock"} - } { return false } + } { pure false } solution: | fred <- robotNamed "fred"; myLoc <- whereami; 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 @@ -5,8 +5,10 @@ if b t e end; -def until = \p.\t. - ifC p t {until p t} +def waitFor = \e.\t. + watch down; + wait 100; + ifC (ishere e) t {waitFor e t} end; def repeat = \c. @@ -29,18 +31,18 @@ // get one lodestone build {log "Hey!"; turn north; m2; l <- grab; turn back; m2; place l}; -until (ishere "lodestone") {grab}; +waitFor "lodestone" {grab}; // get two bit (0) build { log "Hi!"; repeat ( log "I am going for a bit"; - turn east; m2; x <- until (ishere "bit (0)") {harvest}; turn back; m2; place x; + turn east; m2; x <- waitFor "bit (0)" {harvest}; turn back; m2; place x; log "I brought a bit"; )}; -until (ishere "bit (0)") {grab}; -until (ishere "bit (0)") {grab}; +waitFor "bit (0)" {grab}; +waitFor "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 @@ -7,7 +7,7 @@ condition: | try { as base {has "drill bit"}; - } { return false } + } { pure false } solution: | run "scenarios/Testing/562-lodestone.sw" robots: @@ -25,6 +25,7 @@ - workbench - 3D printer - branch predictor + - rolex inventory: - [10, drill] - [10, lambda] @@ -37,6 +38,7 @@ - [10, strange loop] - [10, branch predictor] - [10, toolkit] + - [10, rolex] - [0, drill bit] - [0, bit (0)] - [0, bit (1)] @@ -50,23 +52,18 @@ '~': [ice, wavy water] 'L': [grass, Linux] 'T': [grass, tree] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] 'A': [stone, magnetic vein] 'o': [stone, lodestone] '0': [grass, bit (0)] 'B': [grass, erase, base] upperleft: [-1, 1] map: | - ┌─────┐ ~~ - │o.AT~ ~L~ - │..AAA│ ~~ - │B.0.A│ ~ - └─────┘ ~ + +++++++ ~~ + +o.AT~ ~L~ + +..AAA+ ~~ + +B.0.A+ ~ + +++++++ ~ entities: - name: magnetic vein display: diff --git a/data/scenarios/Testing/684-swap.yaml b/data/scenarios/Testing/684-swap.yaml --- a/data/scenarios/Testing/684-swap.yaml +++ b/data/scenarios/Testing/684-swap.yaml @@ -9,10 +9,10 @@ as base { l <- has "lambda"; b <- has "bitcoin"; - return $ l && b + pure $ l && b } } { - return false + pure false } solution: | swap "bitcoin"; swap "gold coin"; @@ -41,20 +41,15 @@ case d (\_. say "Fatal error: swap does not work atomically!" ) (\_. - return () + pure () ) ) world: palette: - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] 'λ': [grass, lambda] upperleft: [-1, 1] map: | - ┌─┐ - │λ│ - └─┘ + +++ + +λ+ + +++ diff --git a/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml b/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml --- a/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml +++ b/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml @@ -5,12 +5,12 @@ https://github.com/swarm-game/swarm/issues/699 objectives: - condition: | - def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; return $ l == loc} {return false} end; - def isDead = \name. try {robotNamed name; return false} {return true} end; + def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; pure $ l == loc} {pure false} end; + def isDead = \name. try {robotNamed name; pure false} {pure true} end; a1 <- isAliveOn "one" (0,-1); a2 <- isAliveOn "two" (1,-2); b <- isAliveOn "base" (0,0); - return (a1 && a2 && b) + pure (a1 && a2 && b) solution: | move; say "Fatal error: base was able to move into a boulder and not fail!" robots: @@ -34,16 +34,11 @@ 'B': [grass, null, base] '1': [grass, null, one] '2': [grass, null, two] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌──┐ - │B@│ - │1@│ - │2@│ - └──┘ + ++++ + +B@+ + +1@+ + +2@+ + ++++ diff --git a/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml b/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml --- a/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml +++ b/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml @@ -5,13 +5,13 @@ https://github.com/swarm-game/swarm/issues/699 objectives: - condition: | - def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; return $ l == loc} {return false} end; - def isDead = \name. try {robotNamed name; return false} {return true} end; + def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; pure $ l == loc} {pure false} end; + def isDead = \name. try {robotNamed name; pure false} {pure true} end; d1 <- isDead "one"; a2 <- isAliveOn "two" (1,-2); a3 <- isAliveOn "three" (1,-3); b <- isAliveOn "base" (0,0); - return (d1 && a2 && a3 && b) + pure (d1 && a2 && a3 && b) solution: | move; say "Fatal error: base was able to move into water and not fail!" robots: @@ -41,17 +41,12 @@ '1': [grass, null, one] '2': [grass, null, two] '3': [grass, null, three] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌──┐ - │B~│ - │1~│ - │2~│ - │3~│ - └──┘ + ++++ + +B~+ + +1~+ + +2~+ + +3~+ + ++++ diff --git a/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml b/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml --- a/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml +++ b/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml @@ -6,14 +6,14 @@ creative: true objectives: - condition: | - def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; return $ l == loc} {return false} end; - def isDead = \name. try {robotNamed name; return false} {return true} end; + def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; pure $ l == loc} {pure false} end; + def isDead = \name. try {robotNamed name; pure false} {pure true} end; d1 <- isDead "one"; d2 <- isDead "two"; a3 <- isAliveOn "three" (3,0); a4 <- isAliveOn "four" (3,0); b <- isAliveOn "base" (5,0); - return (d1 && d2 && a3 && a4 && b) + pure (d1 && d2 && a3 && a4 && b) solution: | o <- robotNamed "one"; reprogram o {t <- robotNamed "two"; teleport t (3,0); teleport self (3,0)}; try {teleport self (3,0)} {teleport self (5,0)} @@ -40,14 +40,9 @@ '2': [grass, null, two] '3': [grass, null, three] '4': [grass, null, four] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌──────┐ - │B12@34│ - └──────┘ + ++++++++ + +B12@34+ + ++++++++ diff --git a/data/scenarios/Testing/710-multi-robot.yaml b/data/scenarios/Testing/710-multi-robot.yaml --- a/data/scenarios/Testing/710-multi-robot.yaml +++ b/data/scenarios/Testing/710-multi-robot.yaml @@ -26,28 +26,20 @@ palette: '.': [blank] # FIRST ROOM - '┌': [blank, upper left corner] - '└': [blank, lower left corner] - '─': [blank, horizontal wall] - '│': [blank, vertical wall] - '┐': [blank, upper right corner, upright0] - '┘': [blank, lower right corner, lowright0] + '+': [blank, wall] + 'c': [blank, wall, corner0] # SECOND ROOM - '1': [blank, vertical wall, gate1] - '-': [blank, "1", horizon] - 'u': [blank, "1", upright, upright1] - 'l': [blank, "1", lowright, lowright1] - '2': [blank, "1", vertice, gate2] + '1': [blank, wall, gate1] + '-': [blank, "1", wally] + 'u': [blank, "1", wally, corner1] + '2': [blank, "1", wally, gate2] # THIRD ROOM - '~': [blank, "2", horizon] - '/': [blank, "2", vertice] - 'U': [blank, "2", upright] - 'L': [blank, "2", lowright] + '~': [blank, "2", wally] upperleft: [-1, 1] map: | - ┌────┐--u~~U - │....1..2../ - └────┘--l~~L + +++++c--u~~~ + +....1..2..~ + +++++c--u~~~ robots: - name: base dir: east @@ -67,8 +59,8 @@ until ( try { loc <- as base {whereami}; - return (loc == l) - } { return false } + pure (loc == l) + } { pure false } ); create "Win" - name: check2 @@ -83,8 +75,8 @@ until ( try { loc <- as base {whereami}; - return (loc == l) - } { return false } + pure (loc == l) + } { pure false } ); create "Win" - name: check3 @@ -99,114 +91,44 @@ until ( try { loc <- as base {whereami}; - return (loc == l) - } { return false } + pure (loc == l) + } { pure false } ); create "Win" - - name: horizon - dir: [0, 0] - system: true - display: - invisible: true - inventory: [[1, horizontal wall]] - program: | - def until = \c. b <- c; if b {} {until c} end; - n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return); - c1 <- robotNamed ("check" ++ n); - until (as c1 {has "Win"}); - swap "horizontal wall" - - name: vertice - dir: [0, 0] - system: true - display: - invisible: true - inventory: [[1, vertical wall]] - program: | - def until = \c. b <- c; if b {} {until c} end; - n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return); - c1 <- robotNamed ("check" ++ n); - until (as c1 {has "Win"}); - swap "vertical wall" - - name: upright - dir: [0, 0] - system: true - display: - invisible: true - inventory: [[1, upper right corner]] - program: | - def until = \c. b <- c; if b {} {until c} end; - n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return); - c1 <- robotNamed ("check" ++ n); - until (as c1 {has "Win"}); - swap "upper right corner" - - name: lowright - dir: [0, 0] - system: true - display: - invisible: true - inventory: [[1, lower right corner]] - program: | - def until = \c. b <- c; if b {} {until c} end; - n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return); - c1 <- robotNamed ("check" ++ n); - until (as c1 {has "Win"}); - swap "lower right corner" - - name: upleft + - name: wally dir: [0, 0] system: true display: invisible: true - inventory: [[1, upper left corner]] + inventory: [[1, wall]] program: | def until = \c. b <- c; if b {} {until c} end; - n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return); + n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") pure); c1 <- robotNamed ("check" ++ n); until (as c1 {has "Win"}); - swap "upper left corner" - - name: upright0 - dir: [0, 0] - system: true - display: - invisible: true - inventory: [[1, down and horizontal wall]] - program: | - def until = \c. b <- c; if b {} {until c} end; - c1 <- robotNamed "check1"; - until (as c1 {has "Win"}); - swap "down and horizontal wall" - - name: lowright0 + swap "wall" + - name: corner0 dir: [0, 0] system: true display: invisible: true - inventory: [[1, up and horizontal wall]] + inventory: [[1, wall]] program: | def until = \c. b <- c; if b {} {until c} end; c1 <- robotNamed "check1"; until (as c1 {has "Win"}); - swap "up and horizontal wall" - - name: upright1 - dir: [0, 0] - system: true - display: - invisible: true - inventory: [[1, down and horizontal wall]] - program: | - def until = \c. b <- c; if b {} {until c} end; - c1 <- robotNamed "check2"; - until (as c1 {has "Win"}); - swap "down and horizontal wall" - - name: lowright1 + swap "wall" + - name: corner1 dir: [0, 0] system: true display: invisible: true - inventory: [[1, up and horizontal wall]] + inventory: [[1, wall]] program: | def until = \c. b <- c; if b {} {until c} end; c1 <- robotNamed "check2"; until (as c1 {has "Win"}); - swap "up and horizontal wall" + swap "wall" - name: gate1 dir: [0, 0] system: true diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml --- a/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml @@ -7,7 +7,7 @@ - goal: - Achieve both of two other objectives condition: | - return true; + pure true; prerequisite: previewable: true logic: diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml --- a/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml @@ -7,7 +7,7 @@ - goal: - Either obtain a "furnace" WITHOUT a "flower", or obtain both a "wooden gear" and "flower". condition: | - return true; + pure true; prerequisite: previewable: true logic: diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml --- a/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml @@ -7,7 +7,7 @@ - goal: - Achieve one of two other objectives condition: | - return true; + pure true; prerequisite: previewable: true logic: diff --git a/data/scenarios/Testing/836-pathfinding/836-automatic-waypoint-navigation.yaml b/data/scenarios/Testing/836-pathfinding/836-automatic-waypoint-navigation.yaml --- a/data/scenarios/Testing/836-pathfinding/836-automatic-waypoint-navigation.yaml +++ b/data/scenarios/Testing/836-pathfinding/836-automatic-waypoint-navigation.yaml @@ -11,7 +11,7 @@ condition: | as base { eggCount <- count "egg"; - return $ eggCount >= 64; + pure $ eggCount >= 64; }; attrs: - name: easter_egg @@ -25,13 +25,6 @@ - Enables `path` command properties: [known, pickable] capabilities: [path] - - name: atlas - display: - char: 'a' - description: - - Enables `waypoint` command - properties: [known, pickable] - capabilities: [waypoint] - name: kudzu display: char: 'k' @@ -103,12 +96,7 @@ palette: '.': [grass] 'k': [stone, kudzu, gardener] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] structures: - name: cornerbox structure: @@ -141,14 +129,14 @@ orient: up: west map: | - ┌───────────┐ - │...........│ - │...........│ - │.....k.....│ - │...........│ - │...........│ - │...........│ - │.....k.....│ - │...........│ - │...........│ - └───────────┘ + +++++++++++++ + +...........+ + +...........+ + +.....k.....+ + +...........+ + +...........+ + +...........+ + +.....k.....+ + +...........+ + +...........+ + +++++++++++++ diff --git a/data/scenarios/Testing/836-pathfinding/836-no-path-exists1.yaml b/data/scenarios/Testing/836-pathfinding/836-no-path-exists1.yaml --- a/data/scenarios/Testing/836-pathfinding/836-no-path-exists1.yaml +++ b/data/scenarios/Testing/836-pathfinding/836-no-path-exists1.yaml @@ -10,7 +10,7 @@ condition: | as base { nextDir <- path (inL ()) (inR "flower"); - return $ case nextDir (\_. true) (\_. false); + pure $ case nextDir (\_. true) (\_. false); }; solution: | noop; diff --git a/data/scenarios/Testing/836-pathfinding/836-no-path-exists2.yaml b/data/scenarios/Testing/836-pathfinding/836-no-path-exists2.yaml --- a/data/scenarios/Testing/836-pathfinding/836-no-path-exists2.yaml +++ b/data/scenarios/Testing/836-pathfinding/836-no-path-exists2.yaml @@ -16,7 +16,7 @@ condition: | as base { nextDir <- path (inL ()) (inR "flower"); - return $ case nextDir (\_. true) (\_. false); + pure $ case nextDir (\_. true) (\_. false); }; solution: | noop; diff --git a/data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-reachable.yaml b/data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-reachable.yaml --- a/data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-reachable.yaml +++ b/data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-reachable.yaml @@ -9,7 +9,7 @@ condition: | as base { nextDir <- path (inR 3) (inR "flower"); - return $ case nextDir (\_. false) (\_. true); + pure $ case nextDir (\_. false) (\_. true); }; solution: | move; diff --git a/data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-unreachable.yaml b/data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-unreachable.yaml --- a/data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-unreachable.yaml +++ b/data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-unreachable.yaml @@ -9,7 +9,7 @@ condition: | as base { nextDir <- path (inR 3) (inR "flower"); - return $ case nextDir (\_. true) (\_. false); + pure $ case nextDir (\_. true) (\_. false); }; solution: | turn back; diff --git a/data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity-unwalkable.yaml b/data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity-unwalkable.yaml --- a/data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity-unwalkable.yaml +++ b/data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity-unwalkable.yaml @@ -9,7 +9,7 @@ condition: | as base { itemAhead <- scan forward; - return $ case itemAhead (\_. false) (\item. item == "water"); + pure $ case itemAhead (\_. false) (\item. item == "water"); }; solution: | run "scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-unwalkable-solution.sw"; diff --git a/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/gardener.sw b/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/gardener.sw --- a/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/gardener.sw +++ b/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/gardener.sw @@ -6,7 +6,7 @@ } { wait 50; harvest; - return (); + pure (); }; end; diff --git a/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/patrol.sw b/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/patrol.sw --- a/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/patrol.sw +++ b/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/patrol.sw @@ -1,9 +1,11 @@ -def goDir = \f. \r. - let d = fst r in +def λmatch = \f. \p. match p f end +def λcase = \f. \g. \s. case s f g end + +def goDir = \f. λmatch \d. \_. if (d == down) { eggHere <- ishere "egg"; - if eggHere {grab; return ()} {}; - return () + if eggHere {grab; pure ()} {}; + pure () } { turn d; @@ -19,18 +21,24 @@ def followRoute = \loc. nextDir <- path (inL ()) (inL loc); - case nextDir return $ goDir $ followRoute loc; + case nextDir pure $ goDir $ followRoute loc; end; -def visitNextWaypoint = \nextWpIdx. - nextWaypointQuery <- waypoint "wp" nextWpIdx; - followRoute $ snd nextWaypointQuery; - visitNextWaypoint $ nextWpIdx + 1; +def visitNextWaypoint : (rec l. Unit + (Int * Int) * l) -> (rec l. Unit + (Int * Int) * l) -> Cmd Unit = \originalList. \remainingList. + + // Wrap around + let myList = case remainingList (\_. originalList) (\_. remainingList) in + + case myList pure (λmatch \hd. \tl. + followRoute hd; + visitNextWaypoint originalList tl; + ); end; def go = - visitNextWaypoint 0; + let wps = waypoints "wp" in + visitNextWaypoint wps wps; end; go; diff --git a/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/rabbit.sw b/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/rabbit.sw --- a/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/rabbit.sw +++ b/data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/rabbit.sw @@ -1,5 +1,6 @@ -def visitNextWaypoint = \nextWpIdx. +def visitNextWaypoint : (rec l. Unit + (Int * Int) * l) -> (rec l. Unit + (Int * Int) * l) -> Cmd Unit = \originalList. \remainingList. + emptyHere <- isempty; if emptyHere { try { @@ -7,10 +8,20 @@ } {}; } {}; watch down; - nextWaypointQuery <- waypoint "wp" nextWpIdx; - teleport self $ snd nextWaypointQuery; - wait 1000; - visitNextWaypoint $ nextWpIdx + 1; + + // Wrap around + let myList = case remainingList (\_. originalList) (\_. remainingList) in + + case myList pure (\cons. + match cons \wp. \tl. + teleport self wp; + wait 1000; + + visitNextWaypoint originalList tl; + ); + + end; -visitNextWaypoint 0; +let wps = waypoints "wp" in +visitNextWaypoint wps wps; diff --git a/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-solution.sw b/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-solution.sw --- a/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-solution.sw +++ b/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-solution.sw @@ -1,7 +1,7 @@ def goDir = \f. \r. - let d = fst r in + match r \d. \_. if (d == down) { - grab; return () + grab; pure () } { turn d; move; f; } @@ -9,7 +9,7 @@ def followRoute = nextDir <- path (inL ()) (inR "flower"); - case nextDir return $ goDir followRoute; + case nextDir pure $ goDir followRoute; end; followRoute; diff --git a/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-unwalkable-solution.sw b/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-unwalkable-solution.sw --- a/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-unwalkable-solution.sw +++ b/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-unwalkable-solution.sw @@ -1,13 +1,13 @@ def goDir = \goalItem. \f. \r. - let d = fst r in + match r \d. \_. if (d == down) { - grab; return () + grab; pure () } { turn d; itemAhead <- scan forward; let isGoalAhead = case itemAhead (\_. false) (\item. item == goalItem) in if isGoalAhead { - return (); + pure (); } { move; f; }; @@ -17,7 +17,7 @@ def followRoute = let goalItem = "water" in nextDir <- path (inL ()) (inR goalItem); - case nextDir return $ goDir goalItem followRoute; + case nextDir pure $ goDir goalItem followRoute; end; followRoute; diff --git a/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-location-solution.sw b/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-location-solution.sw --- a/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-location-solution.sw +++ b/data/scenarios/Testing/836-pathfinding/_836-path-exists/find-location-solution.sw @@ -1,7 +1,7 @@ def goDir = \f. \r. - let d = fst r in + match r \d. \_. if (d == down) { - grab; return () + grab; pure () } { turn d; move; f; } @@ -9,7 +9,7 @@ def followRoute = nextDir <- path (inL ()) (inL (4, 0)); - case nextDir return $ goDir followRoute; + case nextDir pure $ goDir followRoute; end; followRoute; diff --git a/data/scenarios/Testing/858-inventory/858-counting-objective.yaml b/data/scenarios/Testing/858-inventory/858-counting-objective.yaml --- a/data/scenarios/Testing/858-inventory/858-counting-objective.yaml +++ b/data/scenarios/Testing/858-inventory/858-counting-objective.yaml @@ -12,7 +12,7 @@ condition: |- as base { itemCount <- count "tree"; - return $ itemCount > 0; + pure $ itemCount > 0; }; robots: - name: base diff --git a/data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml b/data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml --- a/data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml +++ b/data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml @@ -10,7 +10,7 @@ condition: |- as base { x <- has "tree"; - return $ not x; + pure $ not x; }; robots: - name: base diff --git a/data/scenarios/Testing/920-meet.yaml b/data/scenarios/Testing/920-meet.yaml --- a/data/scenarios/Testing/920-meet.yaml +++ b/data/scenarios/Testing/920-meet.yaml @@ -10,20 +10,20 @@ teleport self (0,0); def all : (rec l. Unit + a * l) -> (a -> Cmd Bool) -> Cmd Bool = \xs. \f. case xs - (\_. return true) - (\cons. b <- f (fst cons); if b {all (snd cons) f} {return false}) + (\_. pure true) + (\cons. match cons \hd. \tl. b <- f hd; if b {all tl f} {pure false}) end; rs <- meetAll; b1 <- all rs (\r. as r {has "boat"}); n2 <- as r0 { count "boat" }; - return (b0 && b1 && (n2 == 2)) + pure (b0 && b1 && (n2 == 2)) solution: | mr0 <- meet; - case mr0 (\_. return ()) (\r0. give r0 "boat"); + case mr0 (\_. pure ()) (\r0. give r0 "boat"); def forM_ : (rec l. Unit + a * l) -> (a -> Cmd b) -> Cmd Unit = \xs. \f. case xs - (\_. return ()) - (\cons. f (fst cons); forM_ (snd cons) f) + (\_. pure ()) + (\cons. match cons \hd. \tl. f hd; forM_ tl f) end; rs <- meetAll; forM_ rs (\r. give r "boat") @@ -48,16 +48,11 @@ '.': [grass] 'Ω': [grass, null] 'o': [grass, null, other] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-2, 2] map: | - ┌───┐ - │.o.│ - │oΩo│ - │.o.│ - └───┘ + +++++ + +.o.+ + +oΩo+ + +.o.+ + +++++ diff --git a/data/scenarios/Testing/955-heading.yaml b/data/scenarios/Testing/955-heading.yaml --- a/data/scenarios/Testing/955-heading.yaml +++ b/data/scenarios/Testing/955-heading.yaml @@ -7,7 +7,7 @@ - condition: | loc <- as base {whereami}; h <- as base {heading}; - return $ loc == (1,-1) && h == north + pure $ loc == (1,-1) && h == north solution: | h <- heading; turn east; move; move; turn right; move; move; turn h robots: diff --git a/data/scenarios/Testing/956-GPS.yaml b/data/scenarios/Testing/956-GPS.yaml --- a/data/scenarios/Testing/956-GPS.yaml +++ b/data/scenarios/Testing/956-GPS.yaml @@ -6,7 +6,7 @@ objectives: - condition: | loc <- as base {whereami}; - return $ loc == (0,0) + pure $ loc == (0,0) goal: - | The goal is to move back to the origin after being @@ -18,8 +18,9 @@ def abs = \n. if (n<0) {-n} {n} end; wait 2; loc <- whereami; - turn (if (fst loc < 0) {east} {west}); x (abs (fst loc)) move; - turn (if (snd loc < 0) {north} {south}); x (abs (snd loc)) move; + match loc \locx. \locy. + turn (if (locx < 0) {east} {west}); x (abs locx) move; + turn (if (locy < 0) {north} {south}); x (abs locy) move; robots: - name: base dir: north diff --git a/data/scenarios/Testing/961-custom-capabilities.yaml b/data/scenarios/Testing/961-custom-capabilities.yaml --- a/data/scenarios/Testing/961-custom-capabilities.yaml +++ b/data/scenarios/Testing/961-custom-capabilities.yaml @@ -7,7 +7,7 @@ objectives: - condition: | mover <- robotNumbered 1; - as mover { loc <- whereami; return $ loc == (0,1) } + as mover { loc <- whereami; pure $ loc == (0,1) } goal: - | Get a robot to (0,1)! diff --git a/data/scenarios/Testing/Achievements/RobotIntoWater.yaml b/data/scenarios/Testing/Achievements/RobotIntoWater.yaml --- a/data/scenarios/Testing/Achievements/RobotIntoWater.yaml +++ b/data/scenarios/Testing/Achievements/RobotIntoWater.yaml @@ -6,14 +6,14 @@ goal: - Build a robot condition: | - try {robotNumbered 1; return True} {return False} + try {robotNumbered 1; pure True} {pure False} - goal: - Drown it prerequisite: build condition: | - try {robotNumbered 1; return False} {return True} + try {robotNumbered 1; pure False} {pure True} solution: | - build { turn right; move; move; move } + build { turn left; move; move; move; move; move; move } robots: - name: base loc: [0, 0] @@ -43,6 +43,5 @@ - [5, toolkit] seed: 0 world: - offset: true dsl: | "classic" diff --git a/data/scenarios/Testing/_Validation/2077-mask-char.yaml b/data/scenarios/Testing/_Validation/2077-mask-char.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/2077-mask-char.yaml @@ -0,0 +1,14 @@ +version: 1 +name: Mask char palette overlap +description: | + Ensure mask char is not used as a palette key +robots: [] +world: + mask: q + palette: + '.': [grass] + 'q': [dirt] + upperleft: [0, 0] + map: | + .. + .. diff --git a/data/scenarios/Testing/_Validation/2077-palette-chars.yaml b/data/scenarios/Testing/_Validation/2077-palette-chars.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/2077-palette-chars.yaml @@ -0,0 +1,14 @@ +version: 1 +name: Enforce single-char palette keys +description: | + No multiple-char or zero-length entries allowed. +robots: [] +world: + palette: + '.': [grass] + '': [stone] + 'foo': [dirt] + upperleft: [0, 0] + map: | + .. + .. diff --git a/data/scenarios/Testing/_Validation/2164-recursive-structure.yaml b/data/scenarios/Testing/_Validation/2164-recursive-structure.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/2164-recursive-structure.yaml @@ -0,0 +1,43 @@ +version: 1 +name: Structure placement (recursive references) +description: | + Recursive structure references are not allowed. +robots: + - name: base + loc: [2, 2] + dir: east +known: [] +world: + structures: + - name: bigbox + structure: + structures: + - name: bitpair + structure: + palette: + '.': [stone, tree] + placements: + - src: minibox + map: | + . + - name: minibox + structure: + palette: + '.': [stone] + placements: + - src: bitpair + map: | + . + placements: + - src: smallbox + - src: bitpair + map: "" + - name: smallbox + structure: + palette: + '.': [grass] + map: | + . + placements: + - src: bigbox + map: "" diff --git a/data/scenarios/Testing/_Validation/2198-prerequisite-SCC.yaml b/data/scenarios/Testing/_Validation/2198-prerequisite-SCC.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/2198-prerequisite-SCC.yaml @@ -0,0 +1,38 @@ +version: 1 +name: | + Prerequisite objectives: dependency cycles in a larger SCC +author: Brent Yorgey +description: | + This should be rejected by the parser due to cyclic dependencies. + The dependency graph is strongly connected, but not all four + dependencies are in a single cycle together. +robots: + - name: base +objectives: + - id: a + condition: 'true' + prerequisite: + logic: + and: + - b + - c + - d + - id: b + condition: 'true' + prerequisite: a + - id: c + condition: 'true' + prerequisite: + logic: + and: + - a + - d + - id: d + condition: 'true' + prerequisite: + logic: + and: + - a + - c +world: + dsl: '{stone}' diff --git a/data/scenarios/Testing/_Validation/2236-unparseable-attr-color.yaml b/data/scenarios/Testing/_Validation/2236-unparseable-attr-color.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/2236-unparseable-attr-color.yaml @@ -0,0 +1,25 @@ +version: 1 +name: Custom attribute - invalid color +description: | + Invalid color in custom attribute +creative: false +attrs: + - name: bogus + bg: "this is not a color" +terrains: + - name: whatzit + attr: bogus + description: | + A thingy +robots: + - name: base + dir: east +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + '.': [whatzit] + upperleft: [0, 0] + map: | + B. diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml --- a/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml +++ b/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml @@ -7,7 +7,7 @@ - goal: - Achieve one of two other objectives condition: | - return true; + pure true; prerequisite: shave_furnace - id: have_furnace goal: diff --git a/data/scenarios/Tutorials/00-ORDER.txt b/data/scenarios/Tutorials/00-ORDER.txt --- a/data/scenarios/Tutorials/00-ORDER.txt +++ b/data/scenarios/Tutorials/00-ORDER.txt @@ -8,13 +8,13 @@ equip.yaml build.yaml bind2.yaml -crash.yaml +debug.yaml scan.yaml give.yaml def.yaml lambda.yaml require.yaml -requireinv.yaml +stock.yaml conditionals.yaml world101.yaml farming.yaml 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 @@ -18,7 +18,7 @@ try { l <- robotNamed "listener"; as l {has "READY"} - } { return false } + } { pure false } solution: | say "Ready!" entities: @@ -38,7 +38,6 @@ properties: [known, pickable] robots: - name: base - system: true display: char: 'Ω' attr: robot @@ -72,8 +71,8 @@ } {log "Something bad happened!"} } seed: 0 +creative: true world: - offset: true scrollable: false dsl: | "classic" diff --git a/data/scenarios/Tutorials/bind2.yaml b/data/scenarios/Tutorials/bind2.yaml --- a/data/scenarios/Tutorials/bind2.yaml +++ b/data/scenarios/Tutorials/bind2.yaml @@ -11,67 +11,57 @@ A pedestal stands conspicuously empty in the center of the room. Perhaps its intended contents lie nearby? - | - Build a robot to retrieve and restore the mystery artifact to its proper place! - - | - **NOTE:** If you find yourself stuck, you can select "Start over" from - the "Quit" (**Ctrl+Q**) dialog. - condition: | - try { - p <- robotnamed "floorspot"; - w <- as p {ishere "Hastur"}; - return (not w); - } { return false } - - goal: - - | - Your robot obtained the misplaced artifact! Next you need to put it back - on the pedestal. But neither you nor your robot knows the - artifact's name. How can it be placed? - - | - Every command returns a value. However, some simple commands, like - `move`, do not have any meaningful - value to return. Swarm has a special type, `Unit`{=type}, with only one value, - called `()`. Since there is only one possible value of type - `Unit`{=type}, returning it does not convey any information. - Thus, the type of `move` is `Cmd Unit`{=type}. + Build a robot to retrieve and restore the mystery artifact to its proper place + in the center of the pedestal! - | - Other commands do return a nontrivial value after executing. - For example, `grab` has type `Cmd Text`{=type}, and returns the name of the - grabbed entity as a text value. + The robot will need to `place "ARTIFACT NAME"`{=snippet}, but you do not know the name yet! + Fortunatelly, the `grab` command has type `Cmd Text`{=type}, and returns + the name of the grabbed entity as a text value. - | To use the result of a command later, you need _bind notation_, which consists of a variable name and a leftwards-pointing arrow - before the command. For example: - - | - ``` - move; t <- grab; place t - ``` + before the command. Like this: - | - In the above example, the result returned by `grab` is assigned - to the variable name `t`{=snippet}, which can then be used later. - This is useful, for example, if you do not care what you - grabbed and just want to move it to another cell, or if you - are not sure of the name of the thing being grabbed. + `move; art <- grab; place art` - | - Reminder: if you need to start over, your previous commands are - accessible in the REPL history (up-arrow). + **NOTE:** If you find yourself stuck, you can select "Start over" from + the "Quit" (**Ctrl+Q**) dialog. + prerequisite: + not: fail_to_grab condition: | try { - p <- robotnamed "pedestal"; - w <- as p {ishere "Hastur"}; - return w; - } { return false } - prerequisite: grab_artifact + teleport self (0,3); + ishere "Hastur" + } { pure false } + - id: fail_to_grab + teaser: Robot stopped + hidden: true + optional: true + goal: + - | + You sent a robot, but it failed to put the artifact in its rightful place. + - | + Try again by selecting "Start over" from the "Quit" (**Ctrl+Q**) dialog. + condition: | + as base { + try { + r <- robotnumbered 1; + reprogram r {}; + teleport self (0,3); + h <- ishere "Hastur"; + pure (not h) + } { + pure false + } + } solution: | build { move; move; - turn right; - move; move; move; move; move; move; - x <- grab; - turn left; - move; - turn left; - move; move; - place x; + turn right; move; move; + f <- grab; + turn back; move; move; + turn right; move; + place f } entities: - name: Hastur @@ -81,6 +71,14 @@ description: - The Unspeakable One properties: [pickable] + - name: pedestal + display: + attr: gold + char: '+' + description: + - A stone pedestal. + properties: + - boundary robots: - name: base dir: north @@ -95,30 +93,21 @@ - [1, treads] - [1, grabber] - [1, compass] - - name: floorspot - system: true - - name: pedestal - system: true world: palette: + 'Ω': [stone, null, base] '.': [blank, null] - 'Ω': [blank, null, base] - 'x': [dirt, null] - 'H': [blank, Hastur, floorspot] - 's': [stone, null, pedestal] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] - upperleft: [-1, -3] + 'x': [stone, pedestal] + 's': [stone, null] + 'H': [blank, Hastur] + '+': [stone, wall] + upperleft: [-5, 6] map: | - ┌─────────┐ - │.........│ - │...xxx...│ - │...xsx...│ - │...xxxH..│ - │.........│ - │Ω┌───────┘ - └─┘........ + +++++++++++ + +.........+ + +...xxx...+ + +...xsx...+ + +...xxxH..+ + +.........+ + +++++Ω+++++ + ....+++.... 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 @@ -25,8 +25,8 @@ b <- ishere "flower"; move; c <- ishere "flower"; - return (a || b || c); - } { return false } + pure (a || b || c); + } { pure false } solution: | build {turn right; move; move; harvest; turn right; move; place "flower"} robots: @@ -52,16 +52,11 @@ '.': [grass] '~': [ice, water] '*': [grass, flower] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │Ω.*│ - │...│ - │~~~│ - └───┘ + +++++ + +Ω.*+ + +...+ + +~~~+ + +++++ diff --git a/data/scenarios/Tutorials/conditionals.yaml b/data/scenarios/Tutorials/conditionals.yaml --- a/data/scenarios/Tutorials/conditionals.yaml +++ b/data/scenarios/Tutorials/conditionals.yaml @@ -51,19 +51,19 @@ **TIP:** the two branches of an `if` must have the same type. In particular, `if ... {grab} {}`{=snippet} is not allowed, because `{grab}` has type `{Cmd Text}`{=type} whereas `{}`{=snippet} has type `{Cmd Unit}`{=type}. - In this case `{grab; return ()}` has the right type. + In this case `{grab; pure ()}` has the right type. condition: | try { n <- as base {count "very small rock"}; - return (n == 4) - } { return false} + pure (n == 4) + } { pure false} solution: | def tL = turn left end; def tB = turn back end; def x4 = \c. c;c;c;c end; def VSR = "very small rock" end; def ifC = \c.\t.\e. b <- c; if b t e end; - def pick = move; ifC (ishere VSR) {grab; return ()} {} end; + def pick = move; ifC (ishere VSR) {grab; pure ()} {} end; def pickrow = x4 pick; turn back; x4 move end; build { turn south; x4 (move; tL; pickrow; tL); tB; x4 move; x4 (give base VSR) @@ -103,18 +103,13 @@ '.': [grass] '_': [stone] 'o': [stone, very small rock] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌─────┐ - │Ω....│ - │.o___│ - │._o__│ - │.___o│ - │.__o_│ - └─────┘ + +++++++ + +Ω....+ + +.o___+ + +._o__+ + +.___o+ + +.__o_+ + +++++++ diff --git a/data/scenarios/Tutorials/craft.yaml b/data/scenarios/Tutorials/craft.yaml --- a/data/scenarios/Tutorials/craft.yaml +++ b/data/scenarios/Tutorials/craft.yaml @@ -19,7 +19,7 @@ condition: | try { as base {has "branch predictor"} - } { return false } + } { pure false } solution: | make "branch"; make "branch predictor" robots: @@ -36,14 +36,9 @@ world: palette: 'Ω': [grass, null, base] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌─┐ - │Ω│ - └─┘ + +++ + +Ω+ + +++ diff --git a/data/scenarios/Tutorials/crash-secret.sw b/data/scenarios/Tutorials/crash-secret.sw deleted file mode 100644 --- a/data/scenarios/Tutorials/crash-secret.sw +++ /dev/null @@ -1,72 +0,0 @@ -// A for cycle from start to end (excluded) that carries a state. -def foreachF = \s.\e.\com.\state. - if (s >= e) { - return state - } { - n <- com state s; - foreachF (s+1) e com n - } -end; - -// An infinite while cycle that carries a state. -def iterate = \state.\com. - n <- com state; - iterate n com; -end; - -// At the beginning all robots can be given Win. -def allOK: Actor -> Bool = \rob. - true -end; - -myLoc <- whereami; - -def foldM : (rec l. Unit + a * l) -> b -> (b -> a -> Cmd b) -> Cmd b = - \xs. \b. \f. case xs - (\_. return b) - (\cons. b' <- f b (fst cons); foldM (snd cons) b' f) -end - -// Try to give a robot a Win, filtering out those that were already given a Win. -// The robot will also receive instructions, so it **must have a logger!** -def tryGive: Text -> (Actor -> Bool) -> Cmd (Actor -> Bool) = \msg. \ok. - rs <- meetAll; - foldM rs ok $ \f.\rob. - if (not $ f rob) { - log $ "skipping the robot " ++ format rob ++ "because it already has a Win"; - return f - } { - robLoc <- as rob {whereami}; - if (robLoc != myLoc) { - log $ "the robot" ++ format rob ++ "is not in my cell"; - return f; - } { - try { - reprogram rob { log msg; }; - log $ "successfully reprogrammed robot " ++ format rob; - give rob "Win"; - log $ "successfully gave Win to robot " ++ format rob; - return (\r. (rob != r && f rob)); - } { - log $ "the robot " ++ format rob ++ "is missing a logger!"; - return f; - }; - } - } -end; - -// ------------------------------------------------------------------------- -// RUN -// ------------------------------------------------------------------------- - -log "Hi, I am secret"; -iterate allOK (tryGive - $ "Send a robot to `salvage` me and come back to\n" - ++ "`give base \"Win\". When the rescue robot stands\n" - ++ "where I am and executes `salvage`, all my inventory\n" - ++ "and logs will go to it, including the \"Win\". Once you\n" - ++ "have brought the \"Win\" to your base, you will win!\n\n" - ++ "NOTE: if you are still viewing me when I am salvaged,\n" - ++ "you will be in for a surprise! If this happens just\n" - ++ "type `view base` to return to viewing your base." -) diff --git a/data/scenarios/Tutorials/crash.yaml b/data/scenarios/Tutorials/crash.yaml deleted file mode 100644 --- a/data/scenarios/Tutorials/crash.yaml +++ /dev/null @@ -1,101 +0,0 @@ -version: 1 -name: Debug -description: | - Learn how to view built robots and debug them. -objectives: - - goal: - - Before you send your robots far away from the `base` you need to learn how to figure out what went wrong with them if they crash. - - | - In this challenge, you should start by - sending a robot to walk four steps straight east into the mountain, - crashing deliberately. However, you must make sure it has a `logger`{=entity}, - 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: - - | - ``` - build {log "Hi!"; turn east; move; move; move; log "3"; move; log "OK"} - ``` - - | - `wait` for the robot to crash, then execute `view it0`{=snippet} (or whichever - `itN`{=snippet} 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 and `give` you an opportunity to `salvage` - the situation... - condition: | - try { - as base {has "Win"} - } { return false } -entities: - - name: Win - display: - attr: device - char: 'W' - description: - - If you have this, you win! - properties: [known, pickable] -solution: | - crasher <- build { - turn east; move; move; move; log "bye"; move - }; - wait 32; - salvager <- build { - log "I will bring home the Win!"; - turn east; move; move; move; salvage; turn back; move; move; give base "Win" - }; -robots: - - name: base - dir: north - heavy: true - display: - char: Ω - attr: robot - devices: - - logger - - 3D printer - - clock - inventory: - - [10, logger] - - [10, compass] - - [10, scanner] - - [10, toolkit] - - [10, solar panel] - - [10, treads] - - [10, grabber] - - name: secret - dir: [0, 0] - devices: - - logger - - flash memory - - dictionary - - 3D printer - inventory: - - [100000, Win] - display: - invisible: true - system: true - program: | - run "scenarios/Tutorials/crash-secret.sw" -known: [water, tree, mountain] -world: - palette: - 'Ω': [grass, null, base] - '!': [grass, null, secret] - '.': [grass] - '~': [ice, water] - 'T': [grass, tree] - 'A': [stone, mountain] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] - upperleft: [-1, 3] - map: | - ┌─────┐ - │AAAT~│ - │..A.~│ - │Ω..!A│ - └─────┘ diff --git a/data/scenarios/Tutorials/debug-hint.sw b/data/scenarios/Tutorials/debug-hint.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/debug-hint.sw @@ -0,0 +1,114 @@ +def λcase = \f. \g. \s. case s f g end +def λmatch = \f. \p. match p f end + +def elif = \p.\t.\f. {if p t f} end; + +// A for cycle from start to end (excluded) that carries a state. +def foreachF = \s.\e.\com.\state. + if (s >= e) { + pure state + } { + n <- com state s; + foreachF (s+1) e com n + } +end; + +// An infinite while cycle that carries a state. +def iterate = \state.\com. + n <- com state; + iterate n com; +end; + +tydef RobotState = [gave_win: Bool, said_log_missing: Bool, said_loc: (Int * Int)] end; + +// setters +def set_gave_win : Bool -> RobotState -> RobotState = \v.\s. [gave_win=v, said_log_missing=s.said_log_missing, said_loc=s.said_loc] end; +def set_said_log_missing : Bool -> RobotState -> RobotState = \v.\s. [gave_win=s.gave_win, said_log_missing=v, said_loc=s.said_loc] end; +def set_said_loc : (Int * Int) -> RobotState -> RobotState = \v.\s. [gave_win=s.gave_win, said_log_missing=s.said_log_missing, said_loc=v ]end; + +tydef RobotsStateList = rec l. Unit + (Actor * RobotState * l) end; + +def emptyList = inl () end; + +// At the beginning all robots can be given Win. +def defaultState: RobotState = + [gave_win=False, said_log_missing=False, said_loc=(-100,-100)] +end; + +def query : Actor -> RobotsStateList -> RobotState = \rob.\l. + case l (\_. defaultState) (λmatch \r. λmatch \s.\tail. + if (r == rob) {s} {query rob tail} + ) +end; + +def update : Actor -> RobotState -> RobotsStateList -> RobotsStateList = \rob.\s.\l. + case l (\_. inr (rob, s, emptyList)) (λmatch \nr. λmatch \ns. \tail. + if (nr == rob) { + inr (rob, s, tail) + } { + inr (nr, ns, update rob s tail) + } + ) +end; + +myLoc <- whereami; + +def foldM : (rec l. Unit + a * l) -> b -> (b -> a -> Cmd b) -> Cmd b = + \xs. \b. \f. case xs + (\_. pure b) + (λmatch \h.\t. b2 <- f b h; foldM t b2 f) +end + +// Try to give a robot a Win, filtering out those that were already given a Win. +// The robot will also receive instructions, so it **must have a logger!** +def tryGive: Text -> RobotsStateList -> Cmd RobotsStateList = \msg. \ok. + instant ( + rs <- meetAll; + foldM rs ok (\stateList.\rob. + let state = query rob stateList in + robLoc <- as rob {whereami}; + hasLog <- as rob {try {log "test"; pure true} {pure false}}; + if (state.gave_win) { + // log $ "skipping the robot " ++ format rob ++ "because it already has a Win"; + pure stateList + } + $elif (robLoc != myLoc && state.said_loc != robLoc) { + log $ "the robot " ++ format rob ++ " is not in my cell"; + pure (update rob (set_said_loc robLoc state) stateList); + } + $elif (not hasLog && state.said_log_missing) + { + say $ "the robot " ++ format rob ++ " is missing a logger!"; + pure (update rob (set_said_log_missing true state) stateList) + } + { // else + try { + reprogram rob { log msg; }; + log $ "successfully reprogrammed robot " ++ format rob; + give rob "Win"; + log $ "successfully gave Win to robot " ++ format rob; + pure (update rob (set_gave_win true state) stateList) + } { + log $ "the robot " ++ format rob ++ " is probably still active!"; + pure stateList + }; + } + ) + ) +end; + +// ------------------------------------------------------------------------- +// RUN +// ------------------------------------------------------------------------- + +log "Hi, I am the system hint robot"; +iterate emptyList (tryGive + $ "Send a robot to `salvage` me and come back to" + ++ " `give base \"Win\"`. When the rescue robot stands" + ++ " where I am and executes `salvage`, all my inventory" + ++ " and logs will go to it, including the \"Win\". Once you" + ++ " have brought the \"Win\" to your base, you will win!\n\n" + ++ "NOTE: if you are still viewing me when I am salvaged," + ++ " you will be in for a surprise! If this happens just" + ++ " type `view base` to return to viewing your base." +) diff --git a/data/scenarios/Tutorials/debug.yaml b/data/scenarios/Tutorials/debug.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/debug.yaml @@ -0,0 +1,103 @@ +version: 1 +name: Debug +description: | + Learn how to view built robots and debug them. +objectives: + - goal: + - | + Before you send your robots far away from the `base` you need to learn how + to figure out what went wrong with them if they crash. + - | + In this challenge, you should start by sending a robot to walk four steps + straight east into the closest mountain, crashing deliberately. + - | + However, you must make sure it has a `logger`{=entity}, + so we can see the failure in its logs. 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: + - | + ``` + build { turn east; move; move; move; log "brace for impact"; move; } + ``` + - | + `wait` for the robot to crash, then execute `view it0`{=snippet} (or whichever + `itN`{=snippet} variable corresponds to the result of the `build` + command) to see how far it got. Further instructions will + appear in the crashed robot's log and `give` you an opportunity to `salvage` + the situation... + condition: | + try { + as base {has "Win"} + } { pure false } +entities: + - name: Win + display: + attr: device + char: 'W' + description: + - Once the base has this, you win! + properties: [known, pickable] +solution: | + crasher <- build { + turn east; move; move; move; log "brace for impact"; move + }; + salvager <- build { + log "I will bring home the Win!"; // This allows log messages to transfer over + turn right; turn right; turn right; turn right; + turn east; move; move; move; salvage; turn back; move; move; give base "Win" + }; +robots: + - name: base + dir: north + heavy: true + display: + char: Ω + attr: robot + devices: + - logger + - 3D printer + - clock + inventory: + - [10, logger] + - [10, compass] + - [10, scanner] + - [10, toolkit] + - [10, solar panel] + - [10, treads] + - [10, grabber] + - name: hint + dir: [0, 0] + devices: + - logger + - hearing aid + - flash memory + - dictionary + - 3D printer + inventory: + - [100000, Win] + display: + invisible: true + system: true + program: | + run "scenarios/Tutorials/debug-hint.sw" +known: [water, wavy water, tree, mountain] +world: + palette: + 'Ω': [grass, null, base] + '!': [dirt, null, hint] + '.': [grass] + '_': [ice, water] + '~': [ice, wavy water] + 'T': [grass, tree] + 'A': [stone, mountain] + '+': [stone, wall] + upperleft: [-1, 3] + map: | + +++++++++ + +...AAT_+ + +.....A~+ + +Ω..!AAA+ + +.~_...A+ + +~__~...+ + +++++++++ diff --git a/data/scenarios/Tutorials/def.yaml b/data/scenarios/Tutorials/def.yaml --- a/data/scenarios/Tutorials/def.yaml +++ b/data/scenarios/Tutorials/def.yaml @@ -32,7 +32,7 @@ condition: | try { as base {has "flower"} - } { return false } + } { pure false } solution: | def m2 = move; move end; def m4 = m2; m2 end; @@ -71,18 +71,13 @@ '.': [grass] '*': [grass, flower] '@': [grass, boulder] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 5] map: | - ┌─────────────────┐ - │................*│ - │.@@@@@@@@@@@@@@@@│ - │.................│ - │@@@@@@@@@@@@@@@@.│ - │Ω................│ - └─────────────────┘ + +++++++++++++++++++ + +................*+ + +.@@@@@@@@@@@@@@@@+ + +.................+ + +@@@@@@@@@@@@@@@@.+ + +Ω................+ + +++++++++++++++++++ diff --git a/data/scenarios/Tutorials/equip.yaml b/data/scenarios/Tutorials/equip.yaml --- a/data/scenarios/Tutorials/equip.yaml +++ b/data/scenarios/Tutorials/equip.yaml @@ -18,8 +18,8 @@ condition: | try { _ <- robotNumbered 1; - return true; - } { return false } + pure true; + } { pure false } solution: | turn south; move; grab; equip "3D printer"; build {}; robots: @@ -41,16 +41,11 @@ '.': [grass] '~': [ice, water] '3': [grass, 3D printer] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │>..│ - │3..│ - │~~~│ - └───┘ + +++++ + +>..+ + +3..+ + +~~~+ + +++++ diff --git a/data/scenarios/Tutorials/farming.sw b/data/scenarios/Tutorials/farming.sw --- a/data/scenarios/Tutorials/farming.sw +++ b/data/scenarios/Tutorials/farming.sw @@ -27,7 +27,7 @@ end; def harvest_field : Text -> Cmd Unit = \thing. x4 ( - x12 (move; ifC (ishere thing) {harvest; return ()} {}); + x12 (move; ifC (ishere thing) {harvest; pure ()} {}); next_row ); tL; m4; tR @@ -38,7 +38,7 @@ ) end; build { - require 1 "lambda"; + stock 1 "lambda"; tB; move; tR; plant_field "lambda"; }; build { diff --git a/data/scenarios/Tutorials/farming.yaml b/data/scenarios/Tutorials/farming.yaml --- a/data/scenarios/Tutorials/farming.yaml +++ b/data/scenarios/Tutorials/farming.yaml @@ -34,9 +34,9 @@ try { as base { n <- count "lambda"; - return (n >= 256) + pure (n >= 256) } - } { return false } + } { pure false } - goal: - Congratulations! You have completed the most difficult simulated exercise and are ready to begin exploring the new planet in earnest. Of course there is much more remaining to explore in the world, and many additional programming language features to unlock. - | @@ -45,7 +45,7 @@ - Afterwards, you will return to the menu where you can select "Classic game" for the complete game experience. Or, play a "Creative game" if you just want to play around with programming robots, without any constraints or need to collect resources. You could also choose to redo some tutorial scenarios, or explore the other challenge scenarios listed in the menu. - Now go forth and build your swarm! condition: | - try {as base {has "curry"}} {return false} + try {as base {has "curry"}} {pure false} prerequisite: get_many_lambdas solution: | run "scenarios/Tutorials/farming.sw"; @@ -81,9 +81,8 @@ - [10, tree] - [10, harvester] - [10, logger] -seed: 0 +seed: 2 world: - offset: true scrollable: false dsl: | "classic" diff --git a/data/scenarios/Tutorials/give.yaml b/data/scenarios/Tutorials/give.yaml --- a/data/scenarios/Tutorials/give.yaml +++ b/data/scenarios/Tutorials/give.yaml @@ -3,32 +3,59 @@ description: | Learn how to give items to other robots. objectives: - - goal: + - id: give_bit + teaser: Give base bit + goal: - | Robots can transfer items between them using the `give` command. This command takes two arguments: the target robot, and the name of the item to give. The target robot is often the special `base` robot, but could be any robot. - - In this scenario, you will need to collect the items scattered around your `base`, by `build`ing one or more robots to collect them and then `give` them to you. + - | + In this scenario, you will need to collect the items scattered + around your `base`, by `build`ing one or more robots to collect + them and then `give` them to you. + - | + This is a training simulation, so the items will reappear after a while. + - | + Start with `build`ing a robot to `grab` the `bit (0)`{=entity} east of the base, then return to `give` it to the `base`. condition: | + as base { has "bit (0)" } + - id: give_rest + teaser: Fetch the rest + goal: + - | + Good job. Now send robots to grab the rest! + - | + Where will you find the item names, so you can `give base "item name"`? + That's the neat part, you won't! + - | + You will get the name from the `grab` command result, for example: + ``` + build { move; w <- grab; log w; turn back; move; give base w } + ``` + - | + **TIP:** Instead of trial and error, you can get the distance to items + by clicking on them in the world map, which will show the coordinates. + prerequisite: give_bit + condition: | as base { - bd <- has "board"; - b0 <- has "bit (0)"; - lx <- has "LaTeX"; - co <- has "copper ore"; - return $ bd && b0 && lx && co; + b <- has "board"; + l <- has "LaTeX"; + c <- has "copper ore"; + pure $ b && l && c; }; solution: | build { - turn back; move; turn right; move; move; move; grab; - turn right; move; move; turn right; move; grab; - move; move; move; move; turn right; move; grab; - turn left; move; move; turn right; move; move; grab; + turn back; move; turn right; move; move; move; latex <- grab; + turn right; move; move; turn right; move; board <- grab; + move; move; move; move; turn right; move; copper <- grab; + turn left; move; move; turn right; move; move; bit <- grab; turn right; move; move; move; move; turn right; move; move; - give base "LaTeX"; - give base "board"; - give base "copper ore"; - give base "bit (0)"; + give base latex; + give base board; + give base copper; + give base bit; } robots: - name: base @@ -47,27 +74,32 @@ - [10, scanner] - [10, treads] - [10, solar panel] + - name: replacer + system: true + program: | + def replace: Cmd Unit = + i <- scan down; + watch down; wait 2024; wait 32; + case i (\_. noop) (\i. create i; try { place i } {} ); + replace; + end; + replace known: [board, LaTeX, bit (0), copper ore] world: palette: 'Ω': [grass, null, base] '.': [grass] - 'w': [grass, board] - '$': [grass, LaTeX] - '0': [grass, bit (0)] - 'C': [grass, copper ore] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] - upperleft: [-1, 3] + 'w': [dirt, board, replacer] + '$': [grass, LaTeX, replacer] + '0': [grass, bit (0), replacer] + 'C': [grass, copper ore, replacer] + '+': [stone, wall] + upperleft: [-5, 3] map: | - ┌─────────┐ - │.........│ - │..w......│ - │....Ω.0..│ - │.$.......│ - │........C│ - └─────────┘ + +++++++++++ + +.........+ + +..w......+ + +....Ω.0..+ + +.$.......+ + +........C+ + +++++++++++ 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 @@ -10,8 +10,8 @@ condition: | try { t <- as base {count "tree"}; - return (t >= 6); - } { return false } + pure (t >= 6); + } { pure false } solution: | move; move; grab; @@ -35,14 +35,9 @@ '>': [grass, null, base] '.': [grass] 'T': [grass, tree] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌────────┐ - │>.TTTTTT│ - └────────┘ + ++++++++++ + +>.TTTTTT+ + ++++++++++ diff --git a/data/scenarios/Tutorials/lambda.yaml b/data/scenarios/Tutorials/lambda.yaml --- a/data/scenarios/Tutorials/lambda.yaml +++ b/data/scenarios/Tutorials/lambda.yaml @@ -23,8 +23,8 @@ try { teleport self (32,-16); b <- ishere "flower"; - return (not b) - } { return false } + pure (not b) + } { pure false } solution: | def x4 = \c. c; c; c; c end; def m2 = move; move end; @@ -60,32 +60,27 @@ palette: 'Ω': [grass, null, base] '.': [grass] + '_': [dirt] '*': [grass, flower] - '@': [grass, boulder] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '#': [stone, wall] upperleft: [-1, 1] map: | - ┌─────────────────────────────────┐ - │.......@.......@.......@.......@@│ - │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│ - │.....@.@.....@.@.....@.@.....@.@@│ - │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ - │.....@.@.....@.@.....@.@.....@.@@│ - │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│ - │.....@.@.....@.@.....@.@.....@.@@│ - │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ - │.....@.@.....@.@.....@.@.....@.@@│ - │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│ - │.....@.@.....@.@.....@.@.....@.@@│ - │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ - │.....@.@.....@.@.....@.@.....@.@@│ - │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│ - │.....@.@.....@.@.....@.@.....@.@@│ - │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ - │Ω....@.......@.......@.......@..*│ - └─────────────────────────────────┘ + ################################### + #_......#.......#_......#.......#_# + #_#####.#.#####.#_#####.#.#####.#_# + #_____#.#.....#.#_____#.#.....#.#_# + #####_#.#####.#.#####_#.#####.#.#_# + #.____#.#_....#.#.____#.#_....#.#_# + #.#####.#_#####.#.#####.#_#####.#_# + #.....#.#_____#.#.....#.#_____#.#_# + #####.#.#####_#.#####.#.#####_#.#_# + #_....#.#.____#.#_....#.#.____#.#_# + #_#####.#.#####.#_#####.#.#####.#_# + #_____#.#.....#.#_____#.#.....#.#_# + #####_#.#####.#.#####_#.#####.#.#_# + #.____#.#_....#.#.____#.#_....#.#_# + #.#####.#_#####.#.#####.#_#####.#_# + #.....#.#_____#.#.....#.#_____#.#_# + #####.#.#####_#.#####.#.#####_#.### + #Ω....#...____#.......#...____#..*# + ################################### diff --git a/data/scenarios/Tutorials/make_curry.sw b/data/scenarios/Tutorials/make_curry.sw --- a/data/scenarios/Tutorials/make_curry.sw +++ b/data/scenarios/Tutorials/make_curry.sw @@ -3,8 +3,9 @@ make "log"; make "log"; make "board"; make "board"; make "boat"; build { require "boat"; - turn right; move; move; move; grab; turn back; move; move; move; + move; move; move; turn right; move; move; move; grab; + turn back; move; move; move; turn left; move; move; move; give base "water"; }; -wait 16; +wait 24; make "curry" 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 @@ -6,46 +6,64 @@ - id: move_to_first_flower teaser: Get the flower goal: - - Robots can use the `move` command to move forward one unit in the direction they are currently facing. - - To complete this challenge, move your robot two spaces to the right, to the coordinates `(2,0)` marked with the purple `flower`{=entity}. - - Note that you can chain commands with semicolon, `;`{=snippet}. - - You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. + - | + Robots can use the `move` command to move forward one unit in the direction they are currently facing. + + To complete this challenge, move your robot two spaces to the right, to the coordinates `(2,0)` + marked with the purple `flower`{=entity}. + + Note that you can chain commands with semicolon, `;`{=snippet}. + + You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. condition: | - r <- robotNamed "check1"; - loc <- as r {has "Win"}; + as base {l <- whereami; pure (l == (2,0))} - id: move_along_corridor teaser: Down the corridor goal: - - Good! Now you need to learn how to effectively repeat actions. - | + Good! Now you need to learn how to effectively repeat actions. + Previously you could move twice by chaining the move command: - - | - ``` - move; move - ``` - - To reuse that command without having to retype it press the upward arrow on your keyboard. This will allow you to select previous commands. - - Ahead of you is a six steps long corridor. Move to its end, i.e. the coordinates `(8,0)` marked with the second purple `flower`{=entity}. - - You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. + + `move; move` + + To reuse that command without having to retype it, press the up arrow on your keyboard. + This will allow you to select previously entered commands. + + Ahead of you is a six steps long corridor. Move to its end, i.e. the coordinates `(8,0)` marked + with the second purple `flower`{=entity}. + + Note that you do not need to type everything in one go; you + can enter multiple commands, as long as they eventually get + you to the flower. + + You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. condition: | - r <- robotNamed "check2"; - loc <- as r {has "Win"}; + as base {l <- whereami; pure (l == (8,0))} prerequisite: move_to_first_flower - id: move_northeast_corner teaser: To northeast corner 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 in the upper left (by clicking on it or typing **Alt+E**) and select the `treads`{=entity} 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`{=entity} 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. - | + Well done! In addition to `move`, you can use the `turn` command to turn your robot, for example, + `turn right` or (if you have a `compass`{=entity}) `turn east`. + + Switch to the inventory view in the upper left (by clicking on it or typing **Alt+E**) and select + the `treads`{=entity} 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`{=entity} 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 another flower. + Remember, you can chain commands with `;`{=snippet}, for example: - - | - ``` - move;move;move;move - ``` - - You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. + + `move; move; move; move` + + You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. condition: | - r <- robotNamed "check3"; - loc <- as r {has "Win"}; + as base {l <- whereami; pure (l == (8,4))} prerequisite: move_along_corridor - goal: - Good job! You are now ready to move and turn on your own. @@ -53,8 +71,7 @@ - Remember you can press the upward arrow on your keyboard to select previous commands. - You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. condition: | - r <- robotNamed "check4"; - loc <- as r {has "Win"}; + as base {l <- whereami; pure (l == (8,8))} prerequisite: move_northeast_corner solution: | // 0 @@ -79,52 +96,31 @@ world: palette: '.': [blank] - '*': [blank, flower] - 'X': [blank, null, 1P flower] - 'Y': [blank, null, 2P flower] - 'Z': [blank, null, 3P flower] # FIRST ROOM - '┌': [blank, upper left corner] - '┐': [blank, upper right corner, 1S down and horizontal wall] - '└': [blank, lower left corner] - '┘': [blank, lower right corner, 1S up and horizontal wall] - '─': [blank, horizontal wall] - '│': [blank, vertical wall] + '0': [blank, wall] + 'A': [blank, flower, check] # SECOND ROOM - '1': [blank, vertical wall, 1G] - '-': [blank, null, 1P horizontal wall] - '|': [blank, null, 1P vertical wall] - 'c': [blank, null, 1P upper right corner, 2S left and vertical wall] - 'b': [blank, null, 1P lower right corner] - 'd': [blank, null, 1P horizontal wall, 2S up and horizontal wall] + '1': [blank, null, 1P wall] + 'B': [blank, null, 1P flower] # THIRD ROOM - '2': [blank, null, 1P horizontal wall, 2G] - '~': [blank, null, 2P horizontal wall] - '/': [blank, null, 2P vertical wall] - 'R': [blank, null, 2P upper right corner] - 'L': [blank, null, 2P upper left corner, 3S down and horizontal wall] - 'K': [blank, null, 2P vertical wall, 3S left and vertical wall] + '2': [blank, null, 2P wall] + 'C': [blank, null, 2P flower] # FOURTH ROOM - '3': [blank, null, 2P vertical wall, 3G] - '_': [blank, null, 3P horizontal wall] - '\': [blank, null, 3P vertical wall] - 'A': [blank, null, 3P lower left corner] - 'B': [blank, null, 3P lower right corner] - 'C': [blank, null, 3P upper right corner] - 'D': [blank, null, 3P upper left corner] + '3': [blank, null, 3P wall] + 'D': [blank, null, 3P flower] upperleft: [-1, 9] map: | - D_________C - \........Z\ - \..D______B - \..\....... - \..A___L~~R - \......3YY/ - A______K../ - ......./../ - ┌───┐--d22c - │..*1....X| - └───┘-----b + 33333333333 + 3........D3 + 3..33333333 + 3..3....... + 3..33332222 + 3......2.C2 + 33333332..2 + .......2..2 + 00000111111 + 0..A0....B1 + 00000111111 # Font inspiration and a nicely visible separator: # # ███████ ██ ██ █████ ██████ ███ ███ @@ -132,6 +128,7 @@ # ███████ ██ █ ██ ███████ ██████ ██ ████ ██ # ██ ██ ███ ██ ██ ██ ██ ██ ██ ██ ██ # ███████ ███ ███ ██ ██ ██ ██ ██ ██ +stepsPerTick: 300 robots: - name: base dir: east @@ -143,196 +140,69 @@ ################# ## OBJECTIVES ## ################# - - name: check1 - loc: [2, 0] - system: true - program: | - def until = \c. b <- c; if b {} {until c} end; - l <- whereami; - until ( - try { - loc <- as base {whereami}; - return (loc == l) - } { return false } - ); - create "Win" - - name: check2 - loc: [8, 0] - system: true - program: | - def until = \c. b <- c; if b {} {until c} end; - l <- whereami; - until ( - try { - loc <- as base {whereami}; - return (loc == l) - } { return false } - ); - create "Win" - - name: check3 - loc: [8, 4] - system: true - program: | - def until = \c. b <- c; if b {} {until c} end; - l <- whereami; - until ( - try { - loc <- as base {whereami}; - return (loc == l || loc == (fst l - 1, snd l)) - } { return false } - ); - create "Win" - - name: check4 - loc: [8, 8] - system: true - program: | - def until = \c. b <- c; if b {} {until c} end; - l <- whereami; - until ( - try { - loc <- as base {whereami}; - return (loc == l) - } { return false } - ); - create "Win" - ################# - ## HORIZONTAL ## - ################# - - name: 1P horizontal wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 2P horizontal wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 3P horizontal wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - ################# - ## VERTICAL ## - ################# - - name: 1P vertical wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 2P vertical wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 3P vertical wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - ################# - ## CORNERS ## - ################# - # the order is: - # upleft upright - # D+----+C - # | | - # | | - # A+----+B - # lowleft lowright - ######### - ## A ## - ######### - - name: 1P lower left corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 2P lower left corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 3P lower left corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - ######### - ## B ## - ######### - - name: 1P lower right corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 2P lower right corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 3P lower right corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - ######### - ## C ## - ######### - - name: 1P upper right corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 2P upper right corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 3P upper right corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - ######### - ## D ## - ######### - - name: 1P upper left corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 2P upper left corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 3P upper left corner - system: true - program: run "scenarios/Tutorials/move_system.sw" - ################# - ## SEPARATORS ## - ################# - # 1 - - name: 1S down and horizontal wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 1S up and horizontal wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - # 2 - - name: 2S left and vertical wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 2S up and horizontal wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - # 3 - - name: 3S left and vertical wall - system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 3S down and horizontal wall + - name: check system: true - program: run "scenarios/Tutorials/move_system.sw" + program: instant (run "scenarios/Tutorials/move_check.sw") ################# - ## GATES ## + ## WALLS ## ################# - - name: 1G + - name: 1P wall system: true program: | - def until = \c. b <- c; if b {} {until c} end; - c1 <- robotNamed "check1"; - until (as c1 {has "Win"}); - grab - - name: 2G + def main = \a. pure noop end + instant ( + run "scenarios/Tutorials/move_surveil.sw"; + main [entity="wall", room=1] + ) + - name: 2P wall system: true - program: run "scenarios/Tutorials/move_system.sw" - - name: 3G + program: | + def main = \a. noop end + instant ( + run "scenarios/Tutorials/move_surveil.sw"; + main [entity="wall", room=2] + ) + - name: 3P wall system: true - program: run "scenarios/Tutorials/move_system.sw" + program: | + def main = \a. noop end + instant ( + run "scenarios/Tutorials/move_surveil.sw"; + main [entity="wall", room=3] + ) ################# ## GARDENERS ## ################# - name: 1P flower system: true - program: run "scenarios/Tutorials/move_system.sw" + program: | + def main = \a. noop end + instant ( + run "scenarios/Tutorials/move_surveil.sw"; + main [entity="flower", room=1] + ) - name: 2P flower system: true - program: run "scenarios/Tutorials/move_system.sw" + program: | + def main = \a. noop end + instant ( + run "scenarios/Tutorials/move_surveil.sw"; + main [entity="flower", room=2] + ) - name: 3P flower system: true - program: run "scenarios/Tutorials/move_system.sw" + program: | + def main = \a. noop end + instant ( + run "scenarios/Tutorials/move_surveil.sw"; + main [entity="flower", room=3] + ) entities: - - name: Win + - name: door display: - char: W - attr: gold + char: 'D' + attr: entity + invisible: true description: - - This entity signals that the objective has been met. + - A wall + properties: [boundary] diff --git a/data/scenarios/Tutorials/move_check.sw b/data/scenarios/Tutorials/move_check.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/move_check.sw @@ -0,0 +1,59 @@ +def until = \cond. \c. b <- cond; if b {} {c; until cond c} end +def abs = \x. if (x >= 0) {x} {-x} end + +def open_door = create "door"; swap "door" end + +def λmatch = \f. \p. match p f end + +// TRICK: +// we only check for base at this location +// so we can sleep for as long as base will take to get here +def get_dist = λmatch \l1. \l2. λmatch \bl1. \bl2. + abs (l1 - bl1) + abs (l2 - bl2) +end + +def waitForBaseAt = \l. \get_timeout. + loc <- as base {whereami}; + if (loc == l) { + pure true + } { + wait (get_timeout l loc); + waitForBaseAt l get_timeout + } +end + +def room1 = + // l <- whereami; + let l = (2, 0) in + waitForBaseAt l (\_. \_. 1); + log "room 1 done"; + // open door + turn east; move; open_door; +end + +def room2 = + let l = (8, 0) in + teleport self l; + waitForBaseAt l get_dist; + log "room 2 done"; + // open doors + turn north; move; open_door; + turn west; move; open_door; +end + +def room3 = + let l = (8, 4) in + teleport self l; + waitForBaseAt l get_dist; + log "room 3 done"; + // open door + turn west; move; move; open_door; +end + +def main = + room1; + room2; + room3; +end + +main diff --git a/data/scenarios/Tutorials/move_surveil.sw b/data/scenarios/Tutorials/move_surveil.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/move_surveil.sw @@ -0,0 +1,45 @@ +def elif = \b.\t.\e. {if b t e} end +def else = \e. e end + +def position: Int -> (Int * Int) = \room. + if (room == 1) { + (3,0) + } $elif (room == 2) { + (7,1) + } $elif (room == 3) { + (6,4) + } $else { + fail $ "unknown room: " ++ format room + } +end + +def wait_until_change = \pos. \original. \cont. + surveil pos; + timeout <- random 10000; + wait timeout; + current <- as self {teleport self pos; scan down}; + if (current != original) { + cont current; + } { + log $ "no change after " ++ format timeout ++ " ticks - continue"; + wait_until_change pos original cont + } +end + +def main: [entity: Text, room: Int] -> Cmd Unit = \args. + let pos = position args.room in + log $ format args; + original <- as self {teleport self pos; scan down}; + log $ "surveil position" ++ format pos ++ ": " ++ format original; + create args.entity; + log $ "sleeping until " ++ format pos ++ " changes"; + wait_until_change pos original ( \changed. + if (args.room == 1) { + place args.entity + } { + // for later rooms a wall appears and then a door is opened + log $ "sleeping until " ++ format pos ++ " changes again"; + wait_until_change pos changed (\_. place args.entity) + } + ) +end diff --git a/data/scenarios/Tutorials/move_system.sw b/data/scenarios/Tutorials/move_system.sw deleted file mode 100644 --- a/data/scenarios/Tutorials/move_system.sw +++ /dev/null @@ -1,28 +0,0 @@ -def until = \c. b <- c; if b {} {until c} end; - -// name format: NA Entity -// N - one digit room number -// A one letter action -nameCheck <- atomic ( - name <- whoami; - check <- robotNamed ("check" ++ fst (split 1 name)); - return (name, check) -); -let a = fst $ split 1 $ snd $ split 1 $ fst nameCheck in -let e = snd $ split 3 $ fst nameCheck in - -until (as (snd nameCheck) {has "Win"}); - -if (a == "S") { - if (e != "") { create e } {}; - swap e; - return () -} { if (a == "G") { - grab; - return () -} { if (a == "P") { - if (e != "") { create e } {}; - place e -} { - say $ "Finished waiting for check but I don't know what to do: '" ++ a ++ "'" -}}} diff --git a/data/scenarios/Tutorials/place.yaml b/data/scenarios/Tutorials/place.yaml --- a/data/scenarios/Tutorials/place.yaml +++ b/data/scenarios/Tutorials/place.yaml @@ -30,8 +30,8 @@ condition: | try { t <- as base {count "spruce"}; - return (t >= 6); - } { return false } + pure (t >= 6); + } { pure false } entities: # faster tree (the normal one grows 500-600 ticks) - name: spruce @@ -76,14 +76,9 @@ '>': [grass, null, base] '.': [grass] 'T': [grass, spruce] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌────────┐ - │>.T.....│ - └────────┘ + ++++++++++ + +>.T.....+ + ++++++++++ diff --git a/data/scenarios/Tutorials/require.yaml b/data/scenarios/Tutorials/require.yaml --- a/data/scenarios/Tutorials/require.yaml +++ b/data/scenarios/Tutorials/require.yaml @@ -4,14 +4,31 @@ Learn how to require additional devices that would otherwise not be equipped. objectives: - goal: - - The `build` command automatically equips devices on the newly built robot that it knows will be required. For example, if you `build {move}`, some `treads`{=entity} will automatically be equipped on the new robot since it needs them to `move`. (To see what the `build` command will equip, you can type `requirements `{=snippet} where ``{=snippet} is any expression.) - - However, sometimes you need a device but `build` can't tell that you need it. In this case, you can use the special `require`{=snippet} command to require a particular device. For example, if you `build {require "3D printer"; move}`, a `3D printer`{=entity} will be equipped on the new robot (in addition to `treads`{=entity}) even though it does not execute any commands that use one. - - Your goal is to pick a flower on the other side of the river and bring it back to your base. You win when the base has a `periwinkle`{=entity} flower in its inventory. - - "Hint: robots will drown in the `water`{=entity} unless they have a `boat`{=entity} device equipped!" + - | + The `build` command automatically equips devices on the newly built robot that it knows will be required. + For example, if you `build {move}`, some `treads`{=entity} will automatically be equipped on the new robot + since it needs them to `move`. + - | + However, sometimes you need a device but `build` can't tell that you need it. + In this case, you can use the special `require`{=snippet} command to require a particular device. + For example, if you run: + ``` + build {require "boat"; move} + ``` + Then a `boat`{=entity} will be equipped on the new robot in addition to `treads`{=entity}. + - | + Unlike other devices used so far in the tutorial, `boat`{=entity} does not provide any commands, + but robots that have it equipped will not drown in the `water`{=entity}. + - | + Your goal is to pick a flower on the other side of the river and bring it back to your base. + You win when the base has a `periwinkle`{=entity} flower in its inventory. + - | + **TIP:** To see what the `build` command will equip, you can type `requirements `{=snippet} + where ``{=snippet} is any expression. condition: | try { as base {has "periwinkle"} - } { return false } + } { pure false } entities: - name: periwinkle display: @@ -20,11 +37,13 @@ description: - A flower. properties: [known, infinite, pickable] +# The player has just done the lambda tutorial, so this neat version is available: solution: | - def m5 = move; move; move; move; move end; + def x5 = \c. c;c;c;c;c end; build { - require "boat"; turn right; - m5; f <- grab; turn back; m5; give base f + require "boat"; + turn right; x5 move; f <- grab; + turn back; x5 move; give base f } robots: - name: base @@ -45,25 +64,22 @@ - [10, grabber] - [10, scanner] - [10, compass] -known: [water] + - [10, lambda] +known: [water, wavy water] world: palette: 'Ω': [grass, null, base] '.': [grass] - '~': [ice, water] + '_': [ice, water] + '~': [ice, wavy water] '*': [grass, periwinkle] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 3] map: | - ┌──────┐ - │..~~..│ - │..~~..│ - │Ω.~~.*│ - │..~~..│ - │..~~..│ - └──────┘ + ++++++++ + +..~_..+ + +.._~..+ + +Ω.__.*+ + +..~_..+ + +.._~..+ + ++++++++ diff --git a/data/scenarios/Tutorials/requireinv.yaml b/data/scenarios/Tutorials/requireinv.yaml deleted file mode 100644 --- a/data/scenarios/Tutorials/requireinv.yaml +++ /dev/null @@ -1,77 +0,0 @@ -version: 1 -name: Require inventory -description: | - Learn how to require inventory when building robots. -objectives: - - goal: - - In the previous tutorial challenge, you learned how to use `require`{=snippet} to require specific devices to be equipped. Sometimes, instead of requiring equipped devices, you require supplies in your inventory. In this case, you can write `require `{=snippet} to require a certain number of copies of a certain entity to be placed in your inventory. - - For example, `build {require 10 "flower"; move; move}` would build a robot with 10 `flower`{=entity}s in its inventory. - - Your goal in this challenge is to cover the entire 4x4 gray area with `rock`{=entity}s! - - | - Remember that you can define commands to simplify your task, for example: - ``` - def PR = move; place "rock" end - ``` - condition: | - def repeat = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} end; - def ifC = \test. \then. \else. b <- test; if b then else end; - try { - teleport self (0,0); turn south; - repeat 4 ( - move; turn east; - repeat 4 ( - move; - ifC (ishere "rock") {} {create "tree"}; - ); - turn back; move; move; move; move; turn left - ); - ifC (has "tree") {return false} {return true} - } { return false } -solution: | - def x4 = \c. c;c;c;c end; - def mp = move; place "rock" end; - def rr = turn right; move; turn right; x4 mp; turn back; x4 move end; - build { - require 16 "rock"; - x4 rr - }; -robots: - - name: base - heavy: true - dir: north - display: - char: Ω - attr: robot - devices: - - logger - - 3D printer - - dictionary - inventory: - - [16, compass] - - [16, solar panel] - - [16, logger] - - [16, treads] - - [16, grabber] - - [16, scanner] - - [16, lambda] - - [100, rock] -world: - palette: - 'Ω': [grass, null, base] - '.': [grass] - '_': [stone] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] - upperleft: [-1, 1] - map: | - ┌─────┐ - │Ω....│ - │.____│ - │.____│ - │.____│ - │.____│ - └─────┘ 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 @@ -4,16 +4,23 @@ Learn how to send robots to safely scan your surroundings. objectives: - goal: - - When you land on an alien planet, all the entities in the world will be unfamiliar to you, but you can learn what they are using the `scan` command, enabled by a `scanner`{=entity} device. - - Send one or more robots to move next to some of the unknown entities (marked as "?"), scan them (with something like `scan forward` or `scan north`), and then return to the base and execute `upload base`. - - For more information about the `scan` and `upload` commands, read the description of the `scanner`{=entity} in your inventory. + - | + When you land on an alien planet, all the entities in the world will be unfamiliar to you, + but you can learn what they are using the `scan` command, enabled by a `scanner`{=entity} device. + - | + Send one or more robots to move next to some unknown entity (marked as "?"), + scan it (with something like `scan forward` or `scan north`), and then return to the base + and execute `upload base`. + - | + For more information about the `scan` and `upload` commands, read the description + of the `scanner`{=entity} in your inventory. Hit Enter to open the description in a larger window. condition: | try { bm <- as base {knows "mountain"}; bt <- as base {knows "tree"}; bw <- as base {knows "wavy water"}; - return (bm || bt || bw) - } { return false } + pure (bm || bt || bw) + } { pure false } solution: | build { turn east; move; move; move; @@ -46,16 +53,11 @@ '~': [ice, wavy water] 'T': [grass, tree] 'A': [stone, mountain] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 3] map: | - ┌─────┐ - │AAAT~│ - │..A.~│ - │Ω...A│ - └─────┘ + +++++++ + +AAAT~+ + +..A.~+ + +Ω...A+ + +++++++ diff --git a/data/scenarios/Tutorials/stock.yaml b/data/scenarios/Tutorials/stock.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/stock.yaml @@ -0,0 +1,78 @@ +version: 1 +name: Stock +description: | + Learn how to stock inventory when building robots. +objectives: + - goal: + - | + In the previous tutorial challenge, you learned how to use `require`{=snippet} + to require specific devices to be equipped. + Sometimes, instead of requiring entities to be equiped as devices, you need them to be stocked in your inventory. + - | + In this case, you can write `stock `{=snippet} to ensure that a certain number + of copies of a certain entity are placed in your inventory. For example: + ``` + build {stock 2 "flower"; move; place "flower"; move; place "flower"} + ``` + This would build a robot with two `flower`{=entity}s in its inventory which the robot can then place. + - Your goal in this challenge is to cover the entire 4x4 gray area with `rock`{=entity}s! + - | + **TIP:** You can define commands to simplify your task, for example: + `def r = move; place "rock"; end` + condition: | + def forM = \i.\e. \c. if (i >= e) {} {c i; forM (i+1) e c} end; + def ifC = \test. \then. \else. b <- test; if b then else end; + + try { + turn east; + forM 1 5 (\y. + forM 1 5 (\x. + teleport self (x,-y); + ifC (ishere "rock") {} {grab; noop}; + ); + ); + pure true + } { pure false } +solution: | + def x4 = \c. c;c;c;c end; + def mp = move; place "rock" end; + def rr = turn right; move; turn right; x4 mp; turn back; x4 move end; + build { + stock 16 "rock"; + x4 rr + }; +robots: + - name: base + heavy: true + dir: north + display: + char: Ω + attr: robot + devices: + - logger + - 3D printer + - dictionary + inventory: + - [16, compass] + - [16, solar panel] + - [16, logger] + - [16, treads] + - [16, grabber] + - [16, scanner] + - [16, lambda] + - [100, rock] +world: + palette: + "Ω": [grass, null, base] + ".": [grass] + "_": [stone] + "+": [stone, wall] + upperleft: [-1, 1] + map: | + +++++++ + +Ω....+ + +.____+ + +.____+ + +.____+ + +.____+ + +++++++ diff --git a/data/scenarios/Tutorials/type-errors.yaml b/data/scenarios/Tutorials/type-errors.yaml --- a/data/scenarios/Tutorials/type-errors.yaml +++ b/data/scenarios/Tutorials/type-errors.yaml @@ -21,8 +21,8 @@ condition: | try { w <- as base {has "Win"}; - return (not w); - } { return false } + pure (not w); + } { pure false } entities: - name: Win display: @@ -47,15 +47,10 @@ palette: '>': [grass, null, base] '.': [grass] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │>..│ - │...│ - └───┘ + +++++ + +>..+ + +...+ + +++++ 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 @@ -25,8 +25,8 @@ condition: | try { w <- as base {has "Win"}; - return (not w); - } { return false } + pure (not w); + } { pure false } entities: - name: Win display: @@ -51,15 +51,10 @@ palette: '>': [grass, null, base] '.': [grass] - '┌': [stone, upper left corner] - '┐': [stone, upper right corner] - '└': [stone, lower left corner] - '┘': [stone, lower right corner] - '─': [stone, horizontal wall] - '│': [stone, vertical wall] + '+': [stone, wall] upperleft: [-1, 1] map: | - ┌───┐ - │>..│ - │...│ - └───┘ + +++++ + +>..+ + +...+ + +++++ diff --git a/data/scenarios/Tutorials/world101.sw b/data/scenarios/Tutorials/world101.sw --- a/data/scenarios/Tutorials/world101.sw +++ b/data/scenarios/Tutorials/world101.sw @@ -4,15 +4,17 @@ def m = move end def m2 = m;m end +def m3 = m;m;m end def m4 = m2;m2 end +def m5 = m4;m end def m8 = m4;m4 end -def m9 = m8;m end -def m10 = m8;m2 end +def m12 = m4;m8 end +def m26 = m12;m12;m2 end def mg = m; grab end def get_3_trees : Cmd Unit = - tB; m; mg; mg; mg; tB; m4 + tL; m; tL; m3; grab; tR; m; tL; mg; mg; tB; m5; tR; m2 end def make_harvester : Cmd Unit = @@ -24,13 +26,13 @@ end def get_lambda : Cmd Unit = - m10; tR; m9; harvest; tB; m9; tL; m10 + m12; tL; m26; harvest; tB; m26; tR; m12 end def solution : Cmd Unit = - build {get_3_trees}; wait 16; salvage; + build {get_3_trees}; wait 24; salvage; make_harvester; - build {get_lambda}; wait 50; salvage + build {get_lambda}; wait 100; salvage end; solution diff --git a/data/scenarios/Tutorials/world101.yaml b/data/scenarios/Tutorials/world101.yaml --- a/data/scenarios/Tutorials/world101.yaml +++ b/data/scenarios/Tutorials/world101.yaml @@ -10,17 +10,18 @@ - You can see that your base starts out with some key devices equipped and some basic supplies for building robots. To build more advanced devices and produce more robots, you'll need to explore, gather resources, and set up some automated production pipelines. - At this point you may want to create an external `.sw`{=path} file with useful definitions you create. You can then load it via the `run` command. See https://github.com/swarm-game/swarm/tree/main/editors for help configuring your editor with support for swarm-lang. - Your first task is to collect three or more `tree`{=entity}s. You can remind yourself of the available commands using **F4**. + - Since you don't yet have a `compass`{=entity} device, you won't be able to refer to cardinal directions like `north` or `east`, only relative directions like `left`, `right`, or `back`. condition: | try { n <- as base {count "tree"}; - return (n >= 3) - } { return false } + pure (n >= 3) + } { pure false } - id: get_harvester teaser: Make a harvester goal: - Nice work! Now, use the `tree`{=entity}s to make a `harvester`{=entity} device. This will require several intermediate products; try making various things, and take a look at your available recipes (**F3**) and at the recipes listed for items in your inventory. Of course, you may end up needing some additional trees. condition: | - try { as base {has "harvester"} } {return false} + try { as base {has "harvester"} } {pure false} prerequisite: get_trees - goal: - Now that you have a `harvester`{=entity}, you can use `harvest` instead of `grab` whenever you pick up a growing item (check for the word "growing" at the top of the item description), to leave behind a seed that will regrow. @@ -28,7 +29,7 @@ - One of the next things you will probably want is a `lambda`{=entity}, so you can define and use parameterized commands. Scan some things and use the process of elimination to find one. Since lambdas regrow, once you find one, try getting it with `harvest`. - "**TIP:** remember that you can click on cells in the world to see their coordinates." condition: | - try { as base {has "lambda"} } {return false} + try { as base {has "lambda"} } {pure false} prerequisite: get_harvester solution: | run "scenarios/Tutorials/world101.sw" @@ -57,9 +58,8 @@ - [100, solar panel] - [50, scanner] - [5, toolkit] -seed: 0 +seed: 2 world: - offset: true scrollable: false dsl: | "classic" diff --git a/data/scenarios/Vignettes/00-ORDER.txt b/data/scenarios/Vignettes/00-ORDER.txt --- a/data/scenarios/Vignettes/00-ORDER.txt +++ b/data/scenarios/Vignettes/00-ORDER.txt @@ -1,1 +1,2 @@ roadway.yaml +progress-bar.yaml diff --git a/data/scenarios/Vignettes/_roadway/coordinator.sw b/data/scenarios/Vignettes/_roadway/coordinator.sw --- a/data/scenarios/Vignettes/_roadway/coordinator.sw +++ b/data/scenarios/Vignettes/_roadway/coordinator.sw @@ -9,13 +9,13 @@ teleport self newLoc; retval <- f; teleport self prevLoc; - return retval; + pure retval; end; def swapItem = \ent. create ent; emptyHere <- isempty; - if emptyHere {} {grab; return ()}; + if emptyHere {} {grab; pure ()}; place ent; end; diff --git a/data/scenarios/Vignettes/_roadway/drone.sw b/data/scenarios/Vignettes/_roadway/drone.sw --- a/data/scenarios/Vignettes/_roadway/drone.sw +++ b/data/scenarios/Vignettes/_roadway/drone.sw @@ -1,17 +1,17 @@ def elif = \t. \then. \else. {if t then else} end def else = \t. t end -def sumTuples = \t1. \t2. - (fst t1 + fst t2, snd t1 + snd t2); +def λmatch = \f. \p. match p f end + +def sumTuples = λmatch \t11. \t12. λmatch \t21. \t22. + (t11 + t21, t12 + t22); end; def max = \a. \b. if (a > b) {a} {b}; end; -def mapTuple = \f. \t. - (f $ fst t, f $ snd t) - end; +def mapTuple = \f. λmatch \x. \y. (f x, f y) end; // modulus function (%) def mod : Int -> Int -> Int = \i.\m. @@ -34,11 +34,11 @@ let topCorner = (-18, 30) in absloc <- whereami; let loc = sumTuples absloc $ mapTuple (\x. -x) topCorner in - let xloc = abs $ fst loc in + match loc \x. \y. + let xloc = abs x in let idx = xloc / 2 in + let yloc = abs y in - let yloc = abs (snd loc) in - randoffset <- random 5; let baseoffset = 10 * idx in let offset = randoffset + baseoffset in @@ -56,15 +56,16 @@ (west, (extents.xMax - offset, lanes.yWest)) } } in - turn $ fst locdir; - teleport self $ snd locdir; - return (isLongitudinal, idx); + match locdir \dir. \loc. + turn dir; + teleport self loc; + pure (isLongitudinal, idx); end; def isGreenLight = \isLongitudinal. r <- robotnamed "stoplight"; isGreen <- as r {has "bit (1)"}; - return $ isLongitudinal != isGreen; + pure $ isLongitudinal != isGreen; end; def getCanMove : @@ -75,44 +76,46 @@ d <- heading; loc <- whereami; + match loc \x. \y. let atStopLine = if (d == north) { - snd loc == stoplines.yNorth; + y == stoplines.yNorth; } $ elif (d == south) { - snd loc == stoplines.ySouth; + y == stoplines.ySouth; } $ elif (d == east) { - fst loc == stoplines.xEast; + x == stoplines.xEast; } $ else { // west - fst loc == stoplines.xWest; + x == stoplines.xWest; } in eitherNeighbor <- meet; // TODO: Make sure we only consider the neighbor directly in front of us. neighborIsStopped <- case eitherNeighbor - (\_. return false) + (\_. pure false) (\r. as r {has "bit (0)"}); // zero-bit means stopped - return $ hasGreenLight || not (atStopLine || neighborIsStopped); + pure $ hasGreenLight || not (atStopLine || neighborIsStopped); end; def doTunnelWrap : [xMin : Int, xMax : Int, yMin : Int, yMax : Int] -> Cmd Bool = \extents. myloc <- whereami; - didWrap <- if (fst myloc < extents.xMin) { - teleport self (extents.xMax, snd myloc); - return true; - } $ elif (fst myloc > extents.xMax) { - teleport self (extents.xMin, snd myloc); - return true; - } $ elif (snd myloc < extents.yMin) { - teleport self (fst myloc, extents.yMax); - return true; - } $ elif (snd myloc > extents.yMax) { - teleport self (fst myloc, extents.yMin); - return true; + match myloc \myx. \myy. + didWrap <- if (myx < extents.xMin) { + teleport self (extents.xMax, myy); + pure true; + } $ elif (myx > extents.xMax) { + teleport self (extents.xMin, myy); + pure true; + } $ elif (myy < extents.yMin) { + teleport self (myx, extents.yMax); + pure true; + } $ elif (myy > extents.yMax) { + teleport self (myx, extents.yMin); + pure true; } $ else { - return false; + pure false; }; - return didWrap; + pure didWrap; end; def moveWithWrap : @@ -129,7 +132,7 @@ move; doTunnelWrap extents; } { - return false; + pure false; }; try { @@ -137,7 +140,7 @@ if canMove {make "bit (1)"} {make "bit (0)"} } {}; - return (canMove, wentThroughTunnel); + pure (canMove, wentThroughTunnel); end; def getNewDelayState : @@ -176,8 +179,7 @@ wait delayState.moveDelay; result <- instant $ moveWithWrap stoplines extents isLongitudinal; - let canGo = fst result in - let wentThroughTunnel = snd result in + match result \canGo. \wentThroughTunnel. if wentThroughTunnel { r <- random 50; wait $ idx * 10 + r; @@ -192,8 +194,7 @@ let lanes = [yWest = 7, yEast = 5, xSouth = 20, xNorth = 22] in let stoplines = [xWest = 24, xEast = 17, ySouth = 9, yNorth = 2] in result <- instant $ init extents lanes; - let isLongitudinal = fst result in - let idx = snd result in + match result \isLongitudinal. \idx. advance idx isLongitudinal stoplines extents [moveDelay=5, transitionCountdown=2]; end; diff --git a/data/scenarios/Vignettes/progress-bar.yaml b/data/scenarios/Vignettes/progress-bar.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Vignettes/progress-bar.yaml @@ -0,0 +1,179 @@ +version: 1 +name: Progress bar +description: | + A progress bar example that gradually fills up. +seed: 0 +objectives: + - goal: + - Wait for all progress bars to fill up. + condition: | + turn east; + let c = e <- scan down; if (e != inr "tree") {fail "not done"} {} in + teleport self (1,-1); c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; + teleport self (1,-5); c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; + teleport self (1,-9); c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; move; c; + pure true +solution: | + wait 100; +robots: + - name: base + dir: east + devices: + - treads + - logger + - grabber + - name: fill + system: true + dir: east + devices: + - logger + inventory: + - [10, tree] + program: | + let repeat = \n.\c. if (n == 0) {} {c; repeat (n-1) c} in + p <- whereami; + match p \_. \y. + repeat 10 (place "tree"; wait (-y); move) +known: [tree] +entities: + - {name: Letter A, display: {char: "A"}, description: ["The letter A"], properties: [known]} + - {name: Letter B, display: {char: "B"}, description: ["The letter B"], properties: [known]} + - {name: Letter C, display: {char: "C"}, description: ["The letter C"], properties: [known]} + - {name: Letter D, display: {char: "D"}, description: ["The letter D"], properties: [known]} + - {name: Letter E, display: {char: "E"}, description: ["The letter E"], properties: [known]} + - {name: Letter F, display: {char: "F"}, description: ["The letter F"], properties: [known]} + - {name: Letter G, display: {char: "G"}, description: ["The letter G"], properties: [known]} + - {name: Letter H, display: {char: "H"}, description: ["The letter H"], properties: [known]} + - {name: Letter I, display: {char: "I"}, description: ["The letter I"], properties: [known]} + - {name: Letter J, display: {char: "J"}, description: ["The letter J"], properties: [known]} + - {name: Letter K, display: {char: "K"}, description: ["The letter K"], properties: [known]} + - {name: Letter L, display: {char: "L"}, description: ["The letter L"], properties: [known]} + - {name: Letter M, display: {char: "M"}, description: ["The letter M"], properties: [known]} + - {name: Letter N, display: {char: "N"}, description: ["The letter N"], properties: [known]} + - {name: Letter O, display: {char: "O"}, description: ["The letter O"], properties: [known]} + - {name: Letter P, display: {char: "P"}, description: ["The letter P"], properties: [known]} + - {name: Letter Q, display: {char: "Q"}, description: ["The letter Q"], properties: [known]} + - {name: Letter R, display: {char: "R"}, description: ["The letter R"], properties: [known]} + - {name: Letter S, display: {char: "S"}, description: ["The letter S"], properties: [known]} + - {name: Letter T, display: {char: "T"}, description: ["The letter T"], properties: [known]} + - {name: Letter U, display: {char: "U"}, description: ["The letter U"], properties: [known]} + - {name: Letter V, display: {char: "V"}, description: ["The letter V"], properties: [known]} + - {name: Letter W, display: {char: "W"}, description: ["The letter W"], properties: [known]} + - {name: Letter X, display: {char: "X"}, description: ["The letter X"], properties: [known]} + - {name: Letter Y, display: {char: "Y"}, description: ["The letter Y"], properties: [known]} + - {name: Letter Z, display: {char: "Z"}, description: ["The letter Z"], properties: [known]} + - {name: Letter a, display: {char: "a"}, description: ["The letter a"], properties: [known]} + - {name: Letter b, display: {char: "b"}, description: ["The letter b"], properties: [known]} + - {name: Letter c, display: {char: "c"}, description: ["The letter c"], properties: [known]} + - {name: Letter d, display: {char: "d"}, description: ["The letter d"], properties: [known]} + - {name: Letter e, display: {char: "e"}, description: ["The letter e"], properties: [known]} + - {name: Letter f, display: {char: "f"}, description: ["The letter f"], properties: [known]} + - {name: Letter g, display: {char: "g"}, description: ["The letter g"], properties: [known]} + - {name: Letter h, display: {char: "h"}, description: ["The letter h"], properties: [known]} + - {name: Letter i, display: {char: "i"}, description: ["The letter i"], properties: [known]} + - {name: Letter j, display: {char: "j"}, description: ["The letter j"], properties: [known]} + - {name: Letter k, display: {char: "k"}, description: ["The letter k"], properties: [known]} + - {name: Letter l, display: {char: "l"}, description: ["The letter l"], properties: [known]} + - {name: Letter m, display: {char: "m"}, description: ["The letter m"], properties: [known]} + - {name: Letter n, display: {char: "n"}, description: ["The letter n"], properties: [known]} + - {name: Letter o, display: {char: "o"}, description: ["The letter o"], properties: [known]} + - {name: Letter p, display: {char: "p"}, description: ["The letter p"], properties: [known]} + - {name: Letter q, display: {char: "q"}, description: ["The letter q"], properties: [known]} + - {name: Letter r, display: {char: "r"}, description: ["The letter r"], properties: [known]} + - {name: Letter s, display: {char: "s"}, description: ["The letter s"], properties: [known]} + - {name: Letter t, display: {char: "t"}, description: ["The letter t"], properties: [known]} + - {name: Letter u, display: {char: "u"}, description: ["The letter u"], properties: [known]} + - {name: Letter v, display: {char: "v"}, description: ["The letter v"], properties: [known]} + - {name: Letter w, display: {char: "w"}, description: ["The letter w"], properties: [known]} + - {name: Letter x, display: {char: "x"}, description: ["The letter x"], properties: [known]} + - {name: Letter y, display: {char: "y"}, description: ["The letter y"], properties: [known]} + - {name: Letter z, display: {char: "z"}, description: ["The letter z"], properties: [known]} +structures: + - name: progress + structure: + palette: + '+': [stone, wall] + '.': [stone] + '-': [stone, null, fill] + map: | + ++++++++++++ + +-.........+ + ++++++++++++ +world: + dsl: | + {grass} + palette: + '~': [grass, null, base] + '.': [grass] + ' ': [grass] + '$': + structure: + name: progress + cell: [stone] + 'A': [grass, Letter A] + 'B': [grass, Letter B] + 'C': [grass, Letter C] + 'D': [grass, Letter D] + 'E': [grass, Letter E] + 'F': [grass, Letter F] + 'G': [grass, Letter G] + 'H': [grass, Letter H] + 'I': [grass, Letter I] + 'J': [grass, Letter J] + 'K': [grass, Letter K] + 'L': [grass, Letter L] + 'M': [grass, Letter M] + 'N': [grass, Letter N] + 'O': [grass, Letter O] + 'P': [grass, Letter P] + 'Q': [grass, Letter Q] + 'R': [grass, Letter R] + 'S': [grass, Letter S] + 'T': [grass, Letter T] + 'U': [grass, Letter U] + 'V': [grass, Letter V] + 'W': [grass, Letter W] + 'X': [grass, Letter X] + 'Y': [grass, Letter Y] + 'Z': [grass, Letter Z] + 'a': [grass, Letter a] + 'b': [grass, Letter b] + 'c': [grass, Letter c] + 'd': [grass, Letter d] + 'e': [grass, Letter e] + 'f': [grass, Letter f] + 'g': [grass, Letter g] + 'h': [grass, Letter h] + 'i': [grass, Letter i] + 'j': [grass, Letter j] + 'k': [grass, Letter k] + 'l': [grass, Letter l] + 'm': [grass, Letter m] + 'n': [grass, Letter n] + 'o': [grass, Letter o] + 'p': [grass, Letter p] + 'q': [grass, Letter q] + 'r': [grass, Letter r] + 's': [grass, Letter s] + 't': [grass, Letter t] + 'u': [grass, Letter u] + 'v': [grass, Letter v] + 'w': [grass, Letter w] + 'x': [grass, Letter x] + 'y': [grass, Letter y] + 'z': [grass, Letter z] + map: |- + $............................... + .............First progress bar. + ................................ + ......................~......... + $............................... + .............Second progress bar + ................................ + ................................ + $............................... + .............Third progress bar. + ................................ + ................................ + abcdefghijklmnopqrstuvwxyz...... + ABCDEFGHIJKLMNOPQRSTUVWXYZ...... diff --git a/data/scenarios/World Examples/clearing.yaml b/data/scenarios/World Examples/clearing.yaml --- a/data/scenarios/World Examples/clearing.yaml +++ b/data/scenarios/World Examples/clearing.yaml @@ -14,9 +14,16 @@ dir: north world: dsl: | - overlay + let // Weight the y coordinates used for the radius calculation + // by 2. This will result in an ellipse of half the height, + // which will look circular thanks to the non-square display. + radiussq = x*x + (2*y)*(2*y), + inner = radiussq < 6*6, + outer = radiussq > 30*30, + middle = not inner && not outer + in overlay [ {dirt} - , mask ((x*x + 4*y*y) >= (6*6) && (x*x + 4*y*y) <= (30*30)) - (let h = hash % 24 in if (36 + h*h) <= (x*x + 4*y*y) then {tree,dirt} else {dirt} ) - , mask ((x*x + 4*y*y) > (30*30)) {tree, dirt} + , mask middle + (let h = hash % 24 in if (36 + h*h) <= radiussq then {tree,dirt} else {dirt}) + , mask outer {tree, dirt} ] diff --git a/data/scenarios/classic.yaml b/data/scenarios/classic.yaml --- a/data/scenarios/classic.yaml +++ b/data/scenarios/classic.yaml @@ -29,7 +29,135 @@ - [50, clock] - [5, toolkit] world: - offset: true scrollable: false dsl: | "classic" +objectives: + - id: trees + teaser: Trees + goal: + - | + Some goals will be shown here, to gently nudge you towards + some useful accomplishments if you'd like some guidance. + However, these goals are optional! Feel free to ignore them + and choose your own path. + - | + One of the first things you will probably want is a few `tree`{=entity}s. + Collect at least 10. + optional: true + condition: | + as base { n <- count "tree"; pure (n >= 10) } + - id: lambda + teaser: Lambda + goal: + - | + It's useful to be able to give names to sequences of commands, + *i.e.* procedures, via `def`{=snippet}. But what's *really* + useful is the ability to define parameterized *functions*! + For that, you'll need to find a `lambda`{=entity}. + optional: true + condition: | + as base { has "lambda" } + - id: harvester + teaser: Harvester + goal: + - | + Construct a `harvester`{=entity}, so you can grow things like + trees and lambdas in a sustainable way. + optional: true + prerequisite: trees + condition: | + as base { has "harvester" } + - id: boat + teaser: Boat + goal: + - | + Construct a `boat`{=entity}, which can be used by robots to + float across `water`{=entity}. + optional: true + prerequisite: trees + condition: | + as base { has "boat" } + - id: logs + teaser: Tree farm + goal: + - | + What you really need is a steady *supply* of wood. Collect + at least 256 `log`{=entity}s. + optional: true + prerequisite: trees + condition: | + as base { n <- count "log"; pure (n >= 256) } + - id: furnace + teaser: Furnace + goal: + - | + Collect at least five `rock`{=entity}s and make a `furnace`{=entity}. + optional: true + condition: | + as base { h <- has "furnace"; e <- equipped "furnace"; pure (h || e) } + - id: bits + teaser: Bits + goal: + - | + Collect some bits: at least eight 0 bits and eight 1 bits. + optional: true + condition: | + as base { + zs <- count "bit (0)"; + os <- count "bit (1)"; + pure (zs >= 8 && os >= 8) + } + - id: wire + teaser: Wire + goal: + - | + Now that you have a furnace, you can use it to craft a few + different items requiring heat. Collect some `copper + ore`{=entity} and make some `copper wire`{=entity}. + optional: true + prerequisite: furnace + condition: | + as base { has "copper wire" } + - id: drill + teaser: Drill + goal: + - | + Now make a `drill`{=entity}, which can be used to clear + `boulder`{=entity}s out of the way and mine for resources in + the mountains. Making a `drill`{=entity} requires first + making several intermediate components, but you're well on + your way. Try exploring the available recipes for each item + in your inventory. + optional: true + prerequisite: + logic: + and: + - wire + - bits + - trees + condition: | + as base { has "drill" } + - id: ore + teaser: Ore + goal: + - | + Now that you have a `drill`{=entity}, you can use it to search + for mines: `drill forward` while next to a + `mountain`{=entity}, which will yield either a `mountain + tunnel`{=entity} that no longer blocks your way, or some kind + of mine. `drill down` in a mine to extract ore. + - | + Establish some mines and collect both `copper ore`{=entity} + and `iron ore`{=entity}. + optional: true + prerequisite: drill + condition: | + as base { i <- has "iron ore"; c <- has "copper ore"; pure (i && c) } + - id: unwinnable + goal: + - | + The classic scenario is not actually winnable (yet). + hidden: true + condition: | + pure false diff --git a/data/scenarios/creative.yaml b/data/scenarios/creative.yaml --- a/data/scenarios/creative.yaml +++ b/data/scenarios/creative.yaml @@ -11,6 +11,5 @@ char: Ω attr: robot world: - offset: true dsl: | "classic" diff --git a/data/terrains.yaml b/data/terrains.yaml --- a/data/terrains.yaml +++ b/data/terrains.yaml @@ -14,3 +14,7 @@ attr: ice description: | Cold, solid, and slippery. +- name: burnt + attr: burnt + description: | + Scorched ground diff --git a/data/test/language-snippets/format/2105.sw b/data/test/language-snippets/format/2105.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/2105.sw @@ -0,0 +1,1 @@ +if true {(1, 2)} /* comment */ {(3, 4)} diff --git a/data/test/language-snippets/format/def.sw b/data/test/language-snippets/format/def.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/def.sw @@ -0,0 +1,1 @@ +def f = \n. 2 /* comment */ end // post diff --git a/data/test/language-snippets/format/defs.sw b/data/test/language-snippets/format/defs.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/defs.sw @@ -0,0 +1,8 @@ +// Comment about this definition +def f: Int -> Int = \n. n + 2 /* after lambda */ end + +// Comment about another definition +// More comments +/* block + comment */ +def g: Text = "hello" end diff --git a/data/test/language-snippets/format/infix.sw b/data/test/language-snippets/format/infix.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/infix.sw @@ -0,0 +1,1 @@ +1 + /* infix comment */ 2 diff --git a/data/test/language-snippets/format/infix2.sw b/data/test/language-snippets/format/infix2.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/infix2.sw @@ -0,0 +1,1 @@ +1 /* infix comment */ + 2 diff --git a/data/test/language-snippets/format/infix3.sw b/data/test/language-snippets/format/infix3.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/infix3.sw @@ -0,0 +1,1 @@ +1 + (2 + 3 /* infix comment */) diff --git a/data/test/language-snippets/format/lambda.sw b/data/test/language-snippets/format/lambda.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/lambda.sw @@ -0,0 +1,2 @@ +// pre +\n. n + 1 /* comment */ diff --git a/data/test/language-snippets/format/lambda2.sw b/data/test/language-snippets/format/lambda2.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/lambda2.sw @@ -0,0 +1,2 @@ +// pre +(\n. n + 1) /* comment */ diff --git a/data/test/language-snippets/format/list.sw b/data/test/language-snippets/format/list.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/list.sw @@ -0,0 +1,287 @@ +/*******************************************************************/ +/* LIST ENCODING IN INT */ +/* */ +/* This file defines functions that allow storing arbitrary list */ +/* of values in one integer. It is possible because an integer can */ +/* have unlimited length and can be split into chunks of smaller */ +/* integers. See Haskell docs for Integer (used by swarm for int). */ +/* */ +/* For examples of usage see the unit tests in testLIST function. */ +/* */ +/* NOTE THAT THIS IS NOT EFFICIENT OR ERGONIMIC!!! YOU SHOULD USE: */ +tydef NormalListType a = rec l. Unit + (a * l) end + +/* */ +/* This code was written before swarm had 'format' or 'rec', but */ +/* it still serves as an example of pure swarm code with tests. */ +/*******************************************************************/ +// +// Definitions: +// - MAIN: nil (Haskell []), cons (Haskell (:)), head, tail +// - BONUS: headTail, index, for, for_each, for_each_i +// - ARITH: len, mod, shiftL, shiftR, shiftLH, shiftRH +// - HELPERS: consP, getLenPart, setLenPart, to1numA, getLenA +// - TESTS: assert, testLIST, testLIST_BIG, testLIST_ALL +// +/*******************************************************************/ +/* TYPE */ +/*******************************************************************/ +// Type of list of ints - the inner ints can themselves be lists, +// so *any* type can be encoded inside. +// +// It is the callers responsibility to make sure a program using this +// "type" is type safe. Notably 2 == [0] != [] == 0 but [] !! x == 0. +tydef ListI = Int end + +/*******************************************************************/ +/* LAYOUT */ +/*******************************************************************/ +// The length of a number is kept in the header and split into 7bit +// chunks each prefixed by 1bit that marks if the byte is last in +// the header (0=YES). +/* EXAMPLE - [short_x,long_y] - concretly e.g. [42, 2^(2^7)] + +0 < len short_x < 2^7 +2^7 < len long_y < 2^14 + +cons short_x $ cons long_y $ nil +vvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvv vvv + 0|len x|x | 1|len y%2^7|0|len y/2^7|y | 0 +^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + head tail +*/ +/*******************************************************************/ +/* ARITH PRIMITIVES */ +/*******************************************************************/ +// bitlength of a number (shifting by one) +def naive_len: Int -> Int -> Int + = \acc. \i. + if (i == 0) {acc} {naive_len (1 + acc) (i / 2)} +end + +// modulus function (%) +def mod: Int -> Int -> Int = \i. \m. i - m * (i / m) end + +// f X Y = Y * 2^(-X) +def shiftL: Int -> Int -> Int = \s. \i. i / 2 ^ s end + +// f X Y = Y * 2^(X) +def shiftR: Int -> Int -> Int = \s. \i. i * 2 ^ s end + +// shift by (8bit) bytes +def shiftLH: Int -> Int -> Int = \s. shiftL (s * 8) end + +def shiftRH: Int -> Int -> Int = \s. shiftR (s * 8) end + +// bitlength of a number using an accumulator (shifting by 64) +def len_accum: Int -> Int -> Int + = \acc. \i. + let next = i / 2 ^ 64 in + if (next == 0) {naive_len acc i} {len_accum (acc + 64) next} +end + +// bitlength of a number (uses an accumulator and shifts by 64 bits) +def len: Int -> Int = len_accum 0 end + +/*******************************************************************/ +/* helper functions */ +/*******************************************************************/ +def getLenPart: Int -> Int = \i. mod (i / 2) (2 ^ 7) end + +def setLenPart: Int -> Int = \i. 2 * mod i (2 ^ 7) end + +// Split length into 7-bit parts and prefix all but last with 1 +def to1numA: Int -> (Int * Int) + = \i. + let nextPart = shiftL 7 i in + if (nextPart == 0) { + // last part + (2 * i, 1) + } { + let p = to1numA nextPart in + (1 /* header isEnd bit */ + setLenPart i + shiftRH 1 (fst p), 1 + snd p) + } +end + +// Get bitlength of the first number in the list +// and also the list starting at the number itself +def getLenA: ListI -> (Int * Int) + = \xs. + let isEnd = 0 == mod xs 2 in + let l = getLenPart xs in + let nextPart = shiftLH 1 xs in + if isEnd {(l, nextPart)} { + let p = getLenA nextPart in (l + shiftR 7 (fst p), snd p) + } +end + +/*******************************************************************/ +/* LIST FUNCTIONS */ +/*******************************************************************/ +def headTail: ListI -> (Int * ListI) + = \xs. + let sign = mod xs 2 in + let ns = xs / 2 in + let p = getLenA ns in + ( let x = mod (snd p) $ 2 ^ fst p in if (sign == 0) {x} {-x} + , shiftL (fst p) (snd p) ) +end + +def head: ListI -> Int + = \xs. + let sign = mod xs 2 in + let ns = xs / 2 in + let p = getLenA ns in + let x = mod (snd p) $ 2 ^ fst p in if (sign == 0) {x} {-x} +end + +def tail: ListI -> ListI + = \xs. + let sign = mod xs 2 in + let ns = xs / 2 in let p = getLenA ns in shiftL (fst p) (snd p) +end + +def nil: ListI = 0 end + +// Add non-negative number to beginning of list (cons adds the sign) +def consP: Int -> ListI -> Int + = \x. \xs. + if (x == 0) {2 /* header says one bit length */ + shiftR (8 + 1) xs} { + let l = len x in + let pl = to1numA l in fst pl + shiftRH (snd pl) (x + shiftR l xs) + } +end + +// Add integer to the beginning of the list +def cons: Int -> ListI -> ListI + = \x. \xs. + if (x >= 0) {2 * consP x xs} {1 + 2 * consP (-x) xs} +end + +/*******************************************************************/ +/* MORE LIST FUNCTIONS */ +/*******************************************************************/ +def index: Int -> ListI -> Int + = \i. \xs. + if (i <= 0) {head xs} {index (i - 1) (tail xs)} +end + +def for: ∀ a. Int -> Int -> (Int -> Cmd a) -> Cmd Unit + = \s. \e. \act. + if (s == e) {} {act s; for (s + 1) e act} +end + +def for_each_i: Int -> ListI -> (Int -> Int -> Cmd Unit) -> Cmd Unit + = \i. \xs. \act. + if (xs == nil) {} { + let ht = headTail xs in act i (fst ht); for_each_i (i + 1) (snd ht) act + } +end + +def for_each: ListI -> (Int -> Cmd Unit) -> Cmd Unit + = \xs. \act. + for_each_i 0 xs (\i. act) +end + +/*******************************************************************/ +/* UNIT TESTS */ +/*******************************************************************/ +def assert = \b. \m. if b {} {log "FAIL:"; fail m} end + +def assert_eq + = \exp. \act. \m. + if (exp == act) {} { + log ("FAIL: expected " ++ format exp ++ " actual " ++ format act); + fail m + } +end + +def testLIST = + log "STARTING TESTS OF LIST:"; + log "check [0]"; + let l0 = cons 0 nil in + assert_eq l0 4 "[0] ~ 4"; + assert_eq (head l0) 0 "head [0] == 0"; + assert_eq (tail l0) nil "tail [0] == []"; + log "check [1]"; + let l1 = cons 1 nil in + assert_eq l1 516 "[1] ~ 516"; + assert_eq (head l1) 1 "head [1] == 1"; + assert_eq (tail l1) nil "tail [1] == []"; + log "check [-1]"; + let ln1 = cons (-1) nil in + assert_eq ln1 517 "[-1] ~ 517"; + assert_eq (head ln1) (-1) "head [-1] == -1"; + assert_eq (tail ln1) nil "tail [-1] == []"; + log "check [42]"; + let l42 = cons 42 nil in + assert_eq l42 21528 "[42] ~ 21528"; + assert_eq (head l42) 42 "head [42] == 42"; + assert_eq (tail l42) nil "tail [42] == []"; + log "check [499672]"; + let l499672 = cons 499672 nil in + assert_eq l499672 255832140 "[499672] ~ 255832140"; + assert_eq (head l499672) 499672 "head [499672] == 499672"; + assert_eq (tail l499672) nil "tail [499672] == []"; + log "check [1,0]"; + let l1_0 = cons 1 l0 in + assert_eq l1_0 4612 "[1,0] ~ 4612"; + assert_eq (head l1_0) 1 "head [1,0] == 1"; + assert_eq (tail l1_0) l0 "tail [1,0] == [0]"; + log "check [11,1,0]"; + let l11_1_0 = cons 11 l1_0 in + assert_eq (head l11_1_0) 11 "head [11,1,0] == 11"; + assert_eq (tail l11_1_0) l1_0 "tail [11,1,0] == [1,0]"; + log "check [0..9]"; + let l0__9 = + cons 0 $ cons 1 $ cons 2 $ cons 3 $ cons 4 $ cons 5 $ cons 6 $ cons 7 $ cons 8 $ cons 9 nil in + assert_eq (head l0__9) 0 "head [0..9] == 0"; + log "- check indices"; + assert_eq (index 0 l0__9) 0 "[0..9] !! 0 == 0"; + assert_eq (index 9 l0__9) 9 "[0..9] !! 9 == 9"; + log "check for + index"; + for 0 9 ( + \i. log ("- at index " ++ format i); + assert_eq (index i l0__9) i "[0..9] - every index I has value I" + ); + log "check for_each"; + for_each l0__9 ( + \x. log ("- at value " ++ format x); + assert (x < 10) "[0..9] - every value X < 10" + ); + log "check for_each_i"; + for_each_i 0 l0__9 ( + \i. \x. log ("- at index " ++ format i); + assert_eq i x "[0..9] - I == X for every value X at index I" + ); + log "OK - ALL TEST PASSED\a" +end + +// This tests uses VERY LONG lists of size up to 2097332 bits. +// TIP: increase the game speed (ticks/s) when you run this test. +def testLIST_BIG = + log "STARTING TESTS OF BIG LISTS:"; + log "check [2^(2^7)] aka [big]"; + let big = 2 ^ 2 ^ 7 in + assert_eq (len big) 129 "len (2^2^7) == 2^7+1"; + assert_eq (to1numA 129) ( 515 + , 2 ) "to1numA: 129 == 1000_0001 --> 515 == [0000 001 0] [0000 001 1]"; + assert_eq (getLenA 515) (129, nil) "getLenA: 515 --> 129"; + let ibig = 2 * (shiftR 16 big + 515) in + let lbig = cons big nil in + assert_eq lbig ibig "[big] ~ 2 * ((big * 2^(2*8)) + 515)"; + assert_eq (head lbig) big "head [big] == big"; + assert_eq (tail lbig) nil "tail [big] == []"; + log "check [2^(2^21)] aka [bigger]"; + let bigger = 2 ^ 2 ^ 21 in + let lbigger = cons bigger nil in + assert_eq (head lbigger) bigger "head [bigger] == bigger"; + assert_eq (tail lbigger) nil "tail [bigger] == []"; + log "check [2^(2^21),2^(2^7)] aka [bigger,big]"; + let lbiggest = cons bigger lbig in + assert_eq (head lbiggest) bigger "head [bigger,big] == bigger"; + assert_eq (tail lbiggest) lbig "tail [bigger,big] == [big]"; + log "OK - ALL TEST PASSED" +end + +def testLIST_ALL = testLIST; testLIST_BIG end diff --git a/data/test/language-snippets/format/parens.sw b/data/test/language-snippets/format/parens.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/parens.sw @@ -0,0 +1,1 @@ +(1 /* hi */) diff --git a/data/test/language-snippets/format/prefix.sw b/data/test/language-snippets/format/prefix.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/prefix.sw @@ -0,0 +1,2 @@ +// prefix comment +1 + 2 diff --git a/data/test/language-snippets/format/record.sw b/data/test/language-snippets/format/record.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/record.sw @@ -0,0 +1,2 @@ +// pre +[x = 3 /* three */, y = "hi"] // post diff --git a/data/test/language-snippets/format/suffix.sw b/data/test/language-snippets/format/suffix.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/format/suffix.sw @@ -0,0 +1,1 @@ +1 + 2 /* suffix comment*/ diff --git a/data/test/language-snippets/warnings/unused-vars/lambda-with-annot.sw b/data/test/language-snippets/warnings/unused-vars/lambda-with-annot.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/warnings/unused-vars/lambda-with-annot.sw @@ -0,0 +1,1 @@ +def put = \y. place (y : Text); end; diff --git a/data/test/language-snippets/warnings/unused-vars/lambda-with-record-unused.sw b/data/test/language-snippets/warnings/unused-vars/lambda-with-record-unused.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/warnings/unused-vars/lambda-with-record-unused.sw @@ -0,0 +1,1 @@ +def put = \y. [x = 3, z = 7]; end; diff --git a/data/test/language-snippets/warnings/unused-vars/lambda-with-record-used-abbrev.sw b/data/test/language-snippets/warnings/unused-vars/lambda-with-record-used-abbrev.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/warnings/unused-vars/lambda-with-record-used-abbrev.sw @@ -0,0 +1,1 @@ +def put = \y. [x = 3, y]; end; diff --git a/data/test/language-snippets/warnings/unused-vars/lambda-with-record-used.sw b/data/test/language-snippets/warnings/unused-vars/lambda-with-record-used.sw new file mode 100644 --- /dev/null +++ b/data/test/language-snippets/warnings/unused-vars/lambda-with-record-used.sw @@ -0,0 +1,1 @@ +def put = \y. [x = 3, z = y + 2]; end; diff --git a/data/test/saves/backstory-0.6.0.0.yaml b/data/test/saves/backstory-0.6.0.0.yaml new file mode 100644 --- /dev/null +++ b/data/test/saves/backstory-0.6.0.0.yaml @@ -0,0 +1,58 @@ +# obtained by: +# git checkout 0.6.0.0 +# cabal run swarm -- --scenario Tutorials/Backstory --run <(echo 'say "Ready!"') +path: Tutorials/backstory.yaml +status: + contents: + - initialCode: /dev/fd/15 + seedVal: null + - - Completed + - attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 1.696629 + elapsedticks: 5 + started: 2025-02-12T16:05:31.987851+01:00 + - bestbyastsize: + - Completed + - attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.337978 + elapsedticks: 5 + started: 2025-02-12T16:05:31.987851+01:00 + bestbycharcount: + - Completed + - attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.337978 + elapsedticks: 5 + started: 2025-02-12T16:05:31.987851+01:00 + bestbyticks: + - Completed + - attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.337978 + elapsedticks: 5 + started: 2025-02-12T16:05:31.987851+01:00 + bestbytime: + - Completed + - attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.337978 + elapsedticks: 5 + started: 2025-02-12T16:05:31.987851+01:00 + tag: Played diff --git a/data/test/saves/backstory-latest.yaml b/data/test/saves/backstory-latest.yaml new file mode 100644 --- /dev/null +++ b/data/test/saves/backstory-latest.yaml @@ -0,0 +1,63 @@ +# obtained by: +# git checkout main +# cabal run swarm -- --scenario Tutorials/Backstory --run <(echo 'say "Ready!"') +path: Tutorials/backstory.yaml +status: + contents: + - initialCode: /dev/fd/15 + seedVal: null + - data: + attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.351809 + elapsedticks: 5 + started: 2025-02-12T22:40:26.141009+01:00 + progress: Completed + - bestbyastsize: + data: + attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.351809 + elapsedticks: 5 + started: 2025-02-12T22:40:26.141009+01:00 + progress: Completed + bestbycharcount: + data: + attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.351809 + elapsedticks: 5 + started: 2025-02-12T22:40:26.141009+01:00 + progress: Completed + bestbyticks: + data: + attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.351809 + elapsedticks: 5 + started: 2025-02-12T22:40:26.141009+01:00 + progress: Completed + bestbytime: + data: + attemptmetrics: + codemetrics: + astSize: 3 + sourceTextLength: 13 + durationmetrics: + elapsed: 0.351809 + elapsedticks: 5 + started: 2025-02-12T22:40:26.141009+01:00 + progress: Completed + tag: Played diff --git a/data/test/standalone-topography/circle-and-crosses.yaml b/data/test/standalone-topography/circle-and-crosses.yaml --- a/data/test/standalone-topography/circle-and-crosses.yaml +++ b/data/test/standalone-topography/circle-and-crosses.yaml @@ -19,7 +19,7 @@ fff placements: - src: beam - offset: [0, 3] + offset: [0, 0] - src: beam offset: [-3, -3] orient: @@ -55,5 +55,5 @@ orient: up: west - src: disc - offset: [8, -8] + offset: [5, -8] map: "" diff --git a/data/test/standalone-topography/rainbow.png b/data/test/standalone-topography/rainbow.png new file mode 100644 Binary files /dev/null and b/data/test/standalone-topography/rainbow.png differ diff --git a/data/test/standalone-topography/rainbow.yaml b/data/test/standalone-topography/rainbow.yaml new file mode 100644 --- /dev/null +++ b/data/test/standalone-topography/rainbow.yaml @@ -0,0 +1,28 @@ +structures: + - name: stripe + structure: + palette: + 'r': "#ff0000" + 'o': "#ff8800" + 'y': "#ffff00" + 'g': "#00ff00" + 'b': "#00ffff" + 'i': "#0000ff" + 'v': "#ff00ff" + map: | + roygbiv +mask: '.' +palette: + 'r': + structure: + name: stripe + orientation: + up: east + cell: "#ffffff" +map: | + ........rrrrr........ + .....rrr.....rrr..... + ...rr...........rr... + ..r...............r.. + .r.................r. + r...................r diff --git a/data/worlds/classic.world b/data/worlds/classic.world --- a/data/worlds/classic.world +++ b/data/worlds/classic.world @@ -31,11 +31,11 @@ Boolean value associated to each coordinate. */ big = pn0 > 0.0, // 'big' is true for coordinates where pn0 > 0.0, and false otherwise - hard = pn1 > 0.0, // etc. - artificial = pn2 > 0.0, + soft = pn1 > 0.0, // etc. + natural = pn2 > 0.0, small = not big, - soft = not hard, - natural = not artificial + hard = not soft, + artificial = not natural in /* The world is built up by a series of layers, with each layer thought of as a function from coordinates to cell values. The first layer is bottommost. @@ -75,6 +75,7 @@ [ {stone} , mask (hash % 10 == 0) {stone, rock} , mask (hash % 100 == 0) {stone, lodestone} + , mask (hash % 300 == 0) {grass, parsley} ] ) , mask (big && soft && natural) @@ -88,6 +89,7 @@ ( overlay [ {grass} , mask (hash % 20 == 10) {grass, cotton} + , mask (hash % 20 == 11) {grass, wheat} , mask (hash % 20 == 0) {grass, flower} , mask (hash % 1000 == 1) {grass, tea plant} ] @@ -97,6 +99,11 @@ [ {grass} , mask (hash % 10 == 0) (if (x + y) % 2 == 0 then {grass, bit (0)} else {grass, bit (1)}) + , mask (hash % 50 == 0) + let i = (x - y) % 3 in + if (i == 0) then {stone, pixel (R)} + else if (i == 1) then {stone, pixel (G)} + else {stone, pixel (B)} ] ) , mask (big && soft && artificial) @@ -109,12 +116,12 @@ , mask (small && hard && artificial) ( overlay [ {stone} - , mask (hash % 50 == 0) - let i = (x - y) % 3 in - if (i == 0) then {stone, pixel (R)} - else if (i == 1) then {stone, pixel (G)} - else {stone, pixel (B)} - , mask (hash % 120 == 1) {stone, lambda} + , mask (hash % 2 == 0) {grass} + , mask (hash % 120 == 1) {grass, lambda} + , mask (hash % 80 == 2) {stone, copper ore} + , mask (hash % 80 == 3) {grass, tree} + , mask (hash % 80 == 4) {grass, rock} ] ) +, mask (x*x + 4*y*y <= 25) {burnt, erase} ] 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 @@ -91,11 +91,9 @@ "time" "scout" "whereami" - "waypoint" - "structure" + "locateme" + "structures" "floorplan" - "hastag" - "tagmembers" "detect" "resonate" "density" @@ -115,13 +113,16 @@ "setname" "random" "run" - "return" + "pure" "try" + "print" + "erase" "swap" "atomic" "instant" "installkeyhandler" "teleport" + "warp" "as" "robotnamed" "robotnumbered" @@ -145,6 +146,10 @@ "\\b" (regexp-opt '( + "waypoint" + "waypoints" + "hastag" + "tagmembers" "self" "parent" "base" @@ -152,13 +157,13 @@ "inl" "inr" "case" - "fst" - "snd" + "match" "force" "undefined" "fail" "not" "format" + "read" "chars" "split" "charat" @@ -170,11 +175,11 @@ "Regexp that recognizes builtin for swarm language.") (defvar swarm-mode-types-regexp - "\\b[A-Z][a-zA-Z_]*\\b" + "\\b[A-Z][a-zA-Z_]*\\b" "Regexp that recognizes types (all uppercase strings are supposed to be types) in swarm language.") (defvar swarm-mode-keywords-regexp - (concat "\\b" (regexp-opt '("def" "tydef" "rec" "end" "let" "in" "require") t) "\\b") + (concat "\\b" (regexp-opt '("def" "tydef" "rec" "end" "let" "in" "require" "stock") t) "\\b") "Regexp that recognizes keywords in swarm language.") (defvar swarm-font-lock-keywords @@ -195,12 +200,12 @@ (with-eval-after-load 'lsp-mode (add-to-list 'lsp-language-id-configuration - '(swarm-mode . "swarm")) + '(swarm-mode . "swarm")) (lsp-register-client - (make-lsp-client :new-connection (lsp-stdio-connection (list "swarm" "lsp")) - :activation-fn (lsp-activate-on "swarm") - :server-id 'swarm-check))) + (make-lsp-client :new-connection (lsp-stdio-connection (list "swarm" "lsp")) + :activation-fn (lsp-activate-on "swarm") + :server-id 'swarm-check))) (provide 'swarm-mode) ;;; swarm-mode.el ends here diff --git a/editors/vim/swarm.vim b/editors/vim/swarm.vim --- a/editors/vim/swarm.vim +++ b/editors/vim/swarm.vim @@ -1,6 +1,6 @@ -syn keyword Keyword def tydef rec end let in require -syn keyword Builtins self parent base if inl inr case fst snd force undefined fail not format chars split charat tochar key -syn keyword Command noop wait selfdestruct move backup volume path push stride turn grab harvest sow ignite place ping give equip unequip make has equipped count drill use build salvage reprogram say listen log view appear create halt time scout whereami waypoint structure floorplan hastag tagmembers detect resonate density sniff chirp watch surveil heading blocked scan upload ishere isempty meet meetall whoami setname random run return try swap atomic instant installkeyhandler teleport as robotnamed robotnumbered knows +syn keyword Keyword def tydef rec end let in require stock +syn keyword Builtins waypoint waypoints hastag tagmembers self parent base if inl inr case match force undefined fail not format read chars split charat tochar key +syn keyword Command noop wait selfdestruct move backup volume path push stride turn grab harvest sow ignite place ping give equip unequip make has equipped count drill use build salvage reprogram say listen log view appear create halt time scout whereami locateme structures floorplan detect resonate density sniff chirp watch surveil heading blocked scan upload ishere isempty meet meetall whoami setname random run pure try print erase swap atomic instant installkeyhandler teleport warp as robotnamed robotnumbered knows syn keyword Direction east north west south down forward left back right syn match Type "\<[A-Z][a-zA-Z_]*\>" syn match Operators "[-=!<>|&+*/^$:]" @@ -9,7 +9,7 @@ syn match Comment "//.*$" syn region MultilineComment start="/\*" end="\*/" syn match Brackets "[\[\]\(\)\{\}]" -syn match String "\".*\"" +syn match String "\"\(\\\(['\"bfnrtav0-9]\|x[0-9a-fA-F]\)\|[^\\\"]\)*\"" syn match Number "\<[-]\=\d\+\>" hi def link Keyword Statement diff --git a/editors/vscode/syntaxes/swarm.tmLanguage.yaml b/editors/vscode/syntaxes/swarm.tmLanguage.yaml --- a/editors/vscode/syntaxes/swarm.tmLanguage.yaml +++ b/editors/vscode/syntaxes/swarm.tmLanguage.yaml @@ -32,6 +32,7 @@ patterns: - include: '#keyword' - include: '#require' + - include: '#stock' - include: '#operator' - include: '#lambda' - include: '#chain' @@ -46,10 +47,13 @@ keyword: name: keyword.other match: >- - \b(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|backup|volume|path|push|stride|turn|grab|harvest|sow|ignite|place|ping|give|equip|unequip|make|has|equipped|count|drill|use|build|salvage|reprogram|say|listen|log|view|appear|create|halt|time|scout|whereami|waypoint|structure|floorplan|hastag|tagmembers|detect|resonate|density|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\b + \b(waypoint|waypoints|hastag|tagmembers|self|parent|base|if|inl|inr|case|match|force|undefined|fail|not|format|read|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|backup|volume|path|push|stride|turn|grab|harvest|sow|ignite|place|ping|give|equip|unequip|make|has|equipped|count|drill|use|build|salvage|reprogram|say|listen|log|view|appear|create|halt|time|scout|whereami|locateme|structures|floorplan|detect|resonate|density|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|pure|try|print|erase|swap|atomic|instant|installkeyhandler|teleport|warp|as|robotnamed|robotnumbered|knows)\b require: name: keyword.control.require match: \b(require)\b + stock: + name: keyword.control.stock + match: \b(stock)\b lambda: name: keyword.operator.lambda match: \\(\w+)\. diff --git a/example/BFS-clear.sw b/example/BFS-clear.sw --- a/example/BFS-clear.sw +++ b/example/BFS-clear.sw @@ -13,11 +13,11 @@ end; def getX : Cmd Int = pos <- whereami; - return (fst pos); + pure (match pos \x. \_. x); end; def getY : Cmd Int = pos <- whereami; - return (snd pos); + pure (match pos \_. \y. y); end; def gotoX : Int -> Cmd Unit = \tgt. cur <- getX; @@ -47,7 +47,7 @@ move; b <- isHere "tree"; if b - { build c; return () } + { build c; pure () } {}; turn back; move diff --git a/example/cat.sw b/example/cat.sw --- a/example/cat.sw +++ b/example/cat.sw @@ -6,7 +6,7 @@ \n. \c. if (n == 0) {} {c ; repeat (n-1) c} in let randdir : Cmd Dir = d <- random 4; - return ( + pure ( if (d == 0) {north} {if (d == 1) {east} {if (d == 2) {south} {west}}}) diff --git a/example/list.sw b/example/list.sw --- a/example/list.sw +++ b/example/list.sw @@ -1,3 +1,4 @@ + /*******************************************************************/ /* LIST ENCODING IN INT */ /* */ @@ -8,37 +9,39 @@ /* */ /* For examples of usage see the unit tests in testLIST function. */ /* */ -/*******************************************************************/ +/* NOTE THAT THIS IS NOT EFFICIENT OR ERGONIMIC!!! YOU SHOULD USE: */ +tydef NormalListType a = rec l. Unit + (a * l) end + +/* */ +/* This code was written before swarm had 'format' or 'rec', but */ +/* it still serves as an example of pure swarm code with tests. */ +/*******************************************************************/ +// // Definitions: // - MAIN: nil (Haskell []), cons (Haskell (:)), head, tail // - BONUS: headTail, index, for, for_each, for_each_i // - ARITH: len, mod, shiftL, shiftR, shiftLH, shiftRH // - HELPERS: consP, getLenPart, setLenPart, to1numA, getLenA // - TESTS: assert, testLIST, testLIST_BIG, testLIST_ALL - +// /*******************************************************************/ /* TYPE */ /*******************************************************************/ - // Type of list of ints - the inner ints can themselves be lists, // so *any* type can be encoded inside. // // It is the callers responsibility to make sure a program using this // "type" is type safe. Notably 2 == [0] != [] == 0 but [] !! x == 0. -// -// TODO: once #153 is resolved, add types to definitions -// -// type ListI = Int +tydef ListI = Int end + /*******************************************************************/ /* LAYOUT */ /*******************************************************************/ - // The length of a number is kept in the header and split into 7bit // chunks each prefixed by 1bit that marks if the byte is last in // the header (0=YES). - /* EXAMPLE - [short_x,long_y] - concretly e.g. [42, 2^(2^7)] 0 < len short_x < 2^7 @@ -50,265 +53,266 @@ ^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ head tail */ - /*******************************************************************/ /* ARITH PRIMITIVES */ /*******************************************************************/ - // bitlength of a number (shifting by one) -def naive_len : Int -> Int = \i. - if (i == 0) {0} {1 + naive_len (i/2)} +def naive_len: Int -> Int -> Int + = \acc. \i. + if (i == 0) {acc} {naive_len (1 + acc) (i / 2)} end + // modulus function (%) -def mod : Int -> Int -> Int = \i.\m. - i - m * (i / m) -end +def mod: Int -> Int -> Int = \i. \m. i - m * (i / m) end + // f X Y = Y * 2^(-X) -def shiftL : Int -> Int -> Int = \s.\i. - i / 2^s -end +def shiftL: Int -> Int -> Int = \s. \i. i / 2 ^ s end + // f X Y = Y * 2^(X) -def shiftR : Int -> Int -> Int = \s.\i. - i * 2^s -end +def shiftR: Int -> Int -> Int = \s. \i. i * 2 ^ s end + // shift by (8bit) bytes -def shiftLH : Int -> Int -> Int = \s. shiftL (s*8) end -def shiftRH : Int -> Int -> Int = \s. shiftR (s*8) end +def shiftLH: Int -> Int -> Int = \s. shiftL (s * 8) end -// bitlength of a number (shifting by 64) -def len : Int -> Int = \i. - let next = i / 2^64 in - if (next == 0) {naive_len i} {64 + len next} +def shiftRH: Int -> Int -> Int = \s. shiftR (s * 8) end + + +// bitlength of a number using an accumulator (shifting by 64) +def len_accum: Int -> Int -> Int + = \acc. \i. + let next = i / 2 ^ 64 in + if (next == 0) {naive_len acc i} {len_accum (acc + 64) next} end + +// bitlength of a number (uses an accumulator and shifts by 64 bits) +def len: Int -> Int = len_accum 0 end + + /*******************************************************************/ /* helper functions */ /*******************************************************************/ +def getLenPart: Int -> Int = \i. mod (i / 2) (2 ^ 7) end -def getLenPart : Int -> Int = \i. mod (i/2) (2^7) end -def setLenPart : Int -> Int = \i. 2 * (mod i (2^7)) end +def setLenPart: Int -> Int = \i. 2 * mod i (2 ^ 7) end + // Split length into 7-bit parts and prefix all but last with 1 -def to1numA : Int -> Int * Int = \i. +def to1numA: Int -> (Int * Int) + = \i. let nextPart = shiftL 7 i in - if (nextPart == 0) - { ((2 * i), 1) } /* last part */ - { let p = to1numA nextPart in - ( 1 /* header isEnd bit */ + setLenPart i + shiftRH 1 (fst p) - , 1 + snd p - ) - } + if (nextPart == 0) { + + // last part + (2 * i, 1) + } { + let p = to1numA nextPart in + match p \a. \b. + (1 /* header isEnd bit */ + setLenPart i + shiftRH 1 a, 1 + b) + } end + // Get bitlength of the first number in the list // and also the list starting at the number itself -// -// getLenA : ListI -> Int * Int -def getLenA = \xs. +def getLenA: ListI -> (Int * Int) + = \xs. let isEnd = 0 == mod xs 2 in let l = getLenPart xs in let nextPart = shiftLH 1 xs in - if isEnd - { (l, nextPart) } - { let p = getLenA nextPart in - (l + shiftR 7 (fst p), snd p) - } + if isEnd {(l, nextPart)} { + let p = getLenA nextPart in + match p \bits. \lst. + (l + shiftR 7 bits, lst) + } end + /*******************************************************************/ /* LIST FUNCTIONS */ /*******************************************************************/ - -// headTail : ListI -> {Int} * {ListI} -def headTail = \xs. +def headTail: ListI -> (Int * ListI) + = \xs. let sign = mod xs 2 in let ns = xs / 2 in let p = getLenA ns in - ( { let x = mod (snd p) $ 2 ^ fst p in - if (sign == 0) {x} {-x} - } - , { shiftL (fst p) (snd p) } - ) + match p \bits. \lst. + ( let x = mod lst $ 2 ^ bits in if (sign == 0) {x} {-x} + , shiftL bits lst ) end -// head : ListI -> Int -def head : Int -> Int = \xs. - force $ fst $ headTail xs +def head: ListI -> Int + = \xs. + let sign = mod xs 2 in + let ns = xs / 2 in + let p = getLenA ns in + match p \bits. \lst. + let x = mod lst $ 2 ^ bits in if (sign == 0) {x} {-x} end -// tail : ListI -> ListI -def tail = \xs. - force $ snd $ headTail xs +def tail: ListI -> ListI + = \xs. + let sign = mod xs 2 in + let ns = xs / 2 in + let p = getLenA ns in + match p \bits. \lst. + shiftL bits lst end -// nil : ListI -def nil = 0 end +def nil: ListI = 0 end + // Add non-negative number to beginning of list (cons adds the sign) -// consP : nat -> ListI -> Int -def consP = \x.\xs. - if (x == 0) - { 2 /* header says one bit length */ + shiftR (8+1) xs} - { let l = len x in - let pl = to1numA l in - (fst pl + shiftRH (snd pl) (x + shiftR l xs)) - } +def consP: Int -> ListI -> Int + = \x. \xs. + if (x == 0) {2 /* header says one bit length */ + shiftR (8 + 1) xs} { + let l = len x in + let pl = to1numA l in + match pl \a. \b. + a + shiftRH b (x + shiftR l xs) + } end + // Add integer to the beginning of the list -// consP : Int -> ListI -> ListI -def cons = \x.\xs. - if (x >= 0) - { 2 * consP x xs } - { 1 + 2 * consP (-x) xs } +def cons: Int -> ListI -> ListI + = \x. \xs. + if (x >= 0) {2 * consP x xs} {1 + 2 * consP (-x) xs} end /*******************************************************************/ /* MORE LIST FUNCTIONS */ /*******************************************************************/ - -// index : Int -> ListI -> Int -def index = \i.\xs. - if (i <= 0) - {head xs} - {index (i-1) (tail xs)} +def index: Int -> ListI -> Int + = \i. \xs. + if (i <= 0) {head xs} {index (i - 1) (tail xs)} end -def for : Int -> Int -> (Int -> Cmd a) -> Cmd Unit = \s.\e.\act. - if (s == e) {} - {act s; for (s+1) e act} +def for: ∀ a. Int -> Int -> (Int -> Cmd a) -> Cmd Unit + = \s. \e. \act. + if (s == e) {} {act s; for (s + 1) e act} end -// for_each_i : Int -> ListI Int -> (Int * Int -> Cmd a) -> Cmd Unit -def for_each_i = \i.\xs.\act. - if (xs == nil) {} - { let ht = headTail xs - in act i (force $ fst ht); for_each_i (i+1) (force $ snd ht) act +def for_each_i: Int -> ListI -> (Int -> Int -> Cmd Unit) -> Cmd Unit + = \i. \xs. \act. + if (xs == nil) {} { + let ht = headTail xs in + match ht \hd. \tl. + act i hd; for_each_i (i + 1) tl act } end -// for_each : ListI Int -> (Int -> Cmd a) -> Cmd Unit -def for_each = \xs.\act. +def for_each: ListI -> (Int -> Cmd Unit) -> Cmd Unit + = \xs. \act. for_each_i 0 xs (\i. act) end + /*******************************************************************/ /* UNIT TESTS */ /*******************************************************************/ +def assert = \b. \m. if b {} {log "FAIL:"; fail m} end -// TODO: show values when #248 is implemented -def assert = \b.\m. - if b {} {log "FAIL:"; fail m} +def assert_eq + = \exp. \act. \m. + if (exp == act) {} { + log ("FAIL: expected " ++ format exp ++ " actual " ++ format act); + fail m + } end def testLIST = log "STARTING TESTS OF LIST:"; - log "check [0]"; let l0 = cons 0 nil in - assert (l0 == 4) "[0] ~ 4"; - assert (head l0 == 0) "head [0] == 0"; - assert (tail l0 == nil) "tail [0] == []"; - + assert_eq l0 4 "[0] ~ 4"; + assert_eq (head l0) 0 "head [0] == 0"; + assert_eq (tail l0) nil "tail [0] == []"; log "check [1]"; let l1 = cons 1 nil in - assert (l1 == 516) "[1] ~ 516"; - assert (head l1 == 1) "head [1] == 1"; - assert (tail l1 == nil) "tail [1] == []"; - + assert_eq l1 516 "[1] ~ 516"; + assert_eq (head l1) 1 "head [1] == 1"; + assert_eq (tail l1) nil "tail [1] == []"; log "check [-1]"; let ln1 = cons (-1) nil in - assert (ln1 == 517) "[-1] ~ 517"; - assert (head ln1 == -1) "head [-1] == -1"; - assert (tail ln1 == nil) "tail [-1] == []"; - + assert_eq ln1 517 "[-1] ~ 517"; + assert_eq (head ln1) (-1) "head [-1] == -1"; + assert_eq (tail ln1) nil "tail [-1] == []"; log "check [42]"; let l42 = cons 42 nil in - assert (l42 == 21528) "[42] ~ 21528"; - assert (head l42 == 42) "head [42] == 42"; - assert (tail l42 == nil) "tail [42] == []"; - + assert_eq l42 21528 "[42] ~ 21528"; + assert_eq (head l42) 42 "head [42] == 42"; + assert_eq (tail l42) nil "tail [42] == []"; log "check [499672]"; let l499672 = cons 499672 nil in - assert (l499672 == 255832140) "[499672] ~ 255832140"; - assert (head l499672 == 499672) "head [499672] == 499672"; - assert (tail l499672 == nil) "tail [499672] == []"; - + assert_eq l499672 255832140 "[499672] ~ 255832140"; + assert_eq (head l499672) 499672 "head [499672] == 499672"; + assert_eq (tail l499672) nil "tail [499672] == []"; log "check [1,0]"; let l1_0 = cons 1 l0 in - assert (l1_0 == 4612) "[1,0] ~ 4612"; - assert (head l1_0 == 1) "head [1,0] == 1"; - assert (tail l1_0 == l0) "tail [1,0] == [0]"; - + assert_eq l1_0 4612 "[1,0] ~ 4612"; + assert_eq (head l1_0) 1 "head [1,0] == 1"; + assert_eq (tail l1_0) l0 "tail [1,0] == [0]"; log "check [11,1,0]"; let l11_1_0 = cons 11 l1_0 in - assert (head l11_1_0 == 11) "head [11,1,0] == 11"; - assert (tail l11_1_0 == l1_0) "tail [11,1,0] == [1,0]"; - + assert_eq (head l11_1_0) 11 "head [11,1,0] == 11"; + assert_eq (tail l11_1_0) l1_0 "tail [11,1,0] == [1,0]"; log "check [0..9]"; - let l0__9 = cons 0 $ cons 1 $ cons 2 $ cons 3 $ cons 4 $ cons 5 $ cons 6 $ cons 7 $ cons 8 $ cons 9 nil in - assert (head l0__9 == 0) "head [0..9] == 0"; - - log "check indices"; - assert (index 0 l0__9 == 0) "[0..9] !! 0 == 0"; - assert (index 9 l0__9 == 9) "[0..9] !! 9 == 9"; - - // TODO: log the number of iteration once #248 is implemented - - log "check for"; - for 0 9 (\i. - assert (index i l0__9 == i) "[0..9] - every index I has value I" + let l0__9 = + cons 0 $ cons 1 $ cons 2 $ cons 3 $ cons 4 $ cons 5 $ cons 6 $ cons 7 $ cons 8 $ cons 9 nil in + assert_eq (head l0__9) 0 "head [0..9] == 0"; + log "- check indices"; + assert_eq (index 0 l0__9) 0 "[0..9] !! 0 == 0"; + assert_eq (index 9 l0__9) 9 "[0..9] !! 9 == 9"; + log "check for + index"; + for 0 9 ( + \i. log ("- at index " ++ format i); + assert_eq (index i l0__9) i "[0..9] - every index I has value I" ); - log "check for_each"; - for_each l0__9 (\x. - assert (x < 10) "[0..9] - every value X < 10" + for_each l0__9 ( + \x. log ("- at value " ++ format x); + assert (x < 10) "[0..9] - every value X < 10" ); - log "check for_each_i"; - for_each_i 0 l0__9 (\i.\x. - assert (i == x) "[0..9] - I == X for every value X at index I" + for_each_i 0 l0__9 ( + \i. \x. log ("- at index " ++ format i); + assert_eq i x "[0..9] - I == X for every value X at index I" ); - log "OK - ALL TEST PASSED\a" end + // This tests uses VERY LONG lists of size up to 2097332 bits. // TIP: increase the game speed (ticks/s) when you run this test. def testLIST_BIG = log "STARTING TESTS OF BIG LISTS:"; - log "check [2^(2^7)] aka [big]"; - let big = 2^2^7 in - assert (len big == 129) "len (2^2^7) == 2^7+1"; - assert (to1numA 129 == (515,2)) "to1numA: 129 == 1000_0001 --> 515 == [0000 001 0] [0000 001 1]"; - assert (getLenA 515 == (129,nil)) "getLenA: 515 --> 129"; + let big = 2 ^ 2 ^ 7 in + assert_eq (len big) 129 "len (2^2^7) == 2^7+1"; + assert_eq (to1numA 129) ( 515 + , 2 ) "to1numA: 129 == 1000_0001 --> 515 == [0000 001 0] [0000 001 1]"; + assert_eq (getLenA 515) (129, nil) "getLenA: 515 --> 129"; let ibig = 2 * (shiftR 16 big + 515) in let lbig = cons big nil in - assert (lbig == ibig) "[big] ~ 2 * ((big * 2^(2*8)) + 515)"; - assert (head lbig == big) "head [big] == big"; - assert (tail lbig == nil) "tail [big] == []"; - + assert_eq lbig ibig "[big] ~ 2 * ((big * 2^(2*8)) + 515)"; + assert_eq (head lbig) big "head [big] == big"; + assert_eq (tail lbig) nil "tail [big] == []"; log "check [2^(2^21)] aka [bigger]"; - let bigger = 2^(2^21) in + let bigger = 2 ^ 2 ^ 21 in let lbigger = cons bigger nil in - assert (head lbigger == bigger) "head [bigger] == bigger"; - assert (tail lbigger == nil) "tail [bigger] == []"; - + assert_eq (head lbigger) bigger "head [bigger] == bigger"; + assert_eq (tail lbigger) nil "tail [bigger] == []"; log "check [2^(2^21),2^(2^7)] aka [bigger,big]"; let lbiggest = cons bigger lbig in - assert (head lbiggest == bigger) "head [bigger,big] == bigger"; - assert (tail lbiggest == lbig) "tail [bigger,big] == [big]"; - - log "OK - ALL TEST PASSED"; + assert_eq (head lbiggest) bigger "head [bigger,big] == bigger"; + assert_eq (tail lbiggest) lbig "tail [bigger,big] == [big]"; + log "OK - ALL TEST PASSED" end -def testLIST_ALL = - testLIST; - testLIST_BIG; -end +def testLIST_ALL = testLIST; testLIST_BIG end diff --git a/example/multi-key-handler.sw b/example/multi-key-handler.sw --- a/example/multi-key-handler.sw +++ b/example/multi-key-handler.sw @@ -2,10 +2,10 @@ // handlers that process multi-key sequences. def cons : a * b -> (a -> b) -> (a -> b) = \p. \k. \a. - if (a == fst p) {snd p} {k a} + match p \x. \y. if (a == x) {y} {k a} end -def nil : a -> Cmd Unit = \a. return () end +def nil : a -> Cmd Unit = \a. pure () end // The delay around the first argument is necessary to prevent // infinite recursion diff --git a/example/pilotmode.sw b/example/pilotmode.sw --- a/example/pilotmode.sw +++ b/example/pilotmode.sw @@ -1,8 +1,8 @@ def cons : a * b -> (a -> b) -> (a -> b) = \p. \k. \a. - if (a == fst p) {snd p} {k a} + match p \x. \y. if (a == x) {y} {k a} end -def nil : a -> Cmd Unit = \a. return () end +def nil : a -> Cmd Unit = \a. pure () end // Suitable to use as e.g. // installKeyHandler "(S-)←↓↑→ [Del] [g]rab [h]arvest [d]rill [s]can [b]locked [u]pload" pilot @@ -18,8 +18,8 @@ cons (key "Del", selfdestruct) $ cons (key "g", res <- grab; log res) $ cons (key "h", res <- harvest; log res) $ - cons (key "d", res <- drill forward; case res (\_. return ()) log) $ - cons (key "s", res <- scan forward; case res (\_. return ()) log) $ + cons (key "d", res <- drill forward; case res (\_. pure ()) log) $ + cons (key "s", res <- scan forward; case res (\_. pure ()) log) $ cons (key "b", b <- blocked; if b {log "blocked"} {log "not blocked"}) $ cons (key "u", upload base) $ nil diff --git a/example/rectypes.sw b/example/rectypes.sw --- a/example/rectypes.sw +++ b/example/rectypes.sw @@ -6,6 +6,23 @@ // (rec l. Unit + Int * l) = (rec q. Unit + Int * q) //////////////////////////////////////////////////////////// +// Utilities +//////////////////////////////////////////////////////////// + +// Flipped versions of match and case come in handy for +// writing functions where we want to immediately match or case on +// the argument. e.g. instead of `\p. match p \x. \y. ...` we can +// write `λmatch \x. \y. ...` + +def λmatch : (a -> b -> c) -> (a * b) -> c = + \f. \p. match p f +end + +def λcase : (a -> c) -> (b -> c) -> (a + b) -> c = + \f. \g. \s. case s f g +end + +//////////////////////////////////////////////////////////// // Lists //////////////////////////////////////////////////////////// @@ -14,10 +31,9 @@ def nil : List a = inl () end def cons : a -> List a -> List a = \x. \l. inr (x, l) end -def foldr : (a -> b -> b) -> b -> List a -> b = \f. \z. \xs. - case xs - (\_. z) - (\c. f (fst c) (foldr f z (snd c))) +def foldr : (a -> b -> b) -> b -> List a -> b = \f. \z. λcase + (\_. z) + (λmatch \x. \xs. f x (foldr f z xs)) end def map : (a -> b) -> List a -> List b = \f. @@ -59,11 +75,11 @@ end def foldBTree : (b -> c) -> (c -> a -> c -> c) -> BTree a b -> c = - \lf. \br. \t. - case t - lf - // fst p, fst (snd p), snd (snd p) is annoying; see #1893 - (\p. br (foldBTree lf br (fst p)) (fst (snd p)) (foldBTree lf br (snd (snd p)))) + \lf. \br. λcase + lf + (λmatch \l. λmatch \x. \r. + br (foldBTree lf br l) x (foldBTree lf br r) + ) end def max : Int -> Int -> Int = \a. \b. if (a > b) {a} {b} end @@ -81,8 +97,8 @@ // but we do it this way just to show off nested rec tydef Rose a = rec r. a * (rec l. Unit + r * l) end -def foldRose : (a -> List b -> b) -> Rose a -> b = \f. \r. - f (fst r) (map (foldRose f) (snd r)) +def foldRose : (a -> List b -> b) -> Rose a -> b = \f. λmatch \a. \ts. + f a (map (foldRose f) ts) end def flatten : Rose a -> List a = diff --git a/example/recursive-containers.sw b/example/recursive-containers.sw new file mode 100644 --- /dev/null +++ b/example/recursive-containers.sw @@ -0,0 +1,801 @@ +/*******************************************************************/ +/* CONTAINERS */ +/*******************************************************************/ +// This file has an example implementation of lists, sets and maps +// (a.k.a dictionaries) using recursive types. +// +// The implementation uses a Red-Black tree balanced binary tree +// with projection (k -> a) to get sets and dictionaries (compare +// only first element of tuple). It is based on Haskell code in: +// https://abhiroop.github.io/Haskell-Red-Black-Tree/ + +// Flipped versions of match and case come in handy for +// writing functions where we want to immediately match or case on +// the argument. e.g. instead of `\p. match p \x. \y. ...` we can +// write `λmatch \x. \y. ...` + +def λmatch : (a -> b -> c) -> (a * b) -> c = + \f. \p. match p f +end + +def λcase : (a -> c) -> (b -> c) -> (a + b) -> c = + \f. \g. \s. case s f g +end + +/*******************************************************************/ +/* (TYPE) DECLARATIONS */ +/*******************************************************************/ + +tydef Maybe a = Unit + a end + +tydef List a = rec l. Maybe (a * l) end + +tydef RBTree k = rec b. Maybe [red: Bool, k: k, l: b, r: b] end + +tydef ISet s a = + [ empty: s + , insert: a -> s -> s + , delete: a -> s -> s + , contains: a -> s -> Bool + , from_list: List a -> s + , pretty: s -> Text + ] +end + +def undefined_set : any -> ISet any s =\empty. + [empty=empty, insert=\x.undefined, delete=\x.undefined, contains=\x.undefined, from_list=\x.undefined, pretty=\x.undefined] +end + +tydef IDict d k v = + [ empty: d + , insert: k -> v -> d -> d + , delete: k -> d -> d + , get: k -> d -> Maybe v + , contains: k -> d -> Bool + , pretty: d -> Text + ] +end + +def undefined_dict : any -> IDict any k v =\empty. + [empty=empty, insert=\x.undefined, delete=\x.undefined, get=\x.undefined, contains=\x.undefined, pretty=\x.undefined] +end + +tydef FlatSet a = List a end +def flat_set : ISet (FlatSet a) a = undefined_set (inl ()) end + +tydef FlatDict k v = List (k * v) end +def flat_dict : IDict (FlatDict k v) k v = undefined_dict (inl ()) end + +tydef Set k = RBTree k end +def tree_set : ISet (Set a) a = undefined_set (inl ()) end + +tydef Dict k v = RBTree (k * v) end +def tree_dict : IDict (Dict k v) k v = undefined_dict (inl ()) end + +/*******************************************************************/ +/* MAYBE */ +/*******************************************************************/ + +def mmap : (a -> b) -> Maybe a -> Maybe b = \f. λcase (\_. inl ()) (\a. inr (f a)) end + +/*******************************************************************/ +/* LISTS */ +/*******************************************************************/ + +def emptyL : List a = inl () end +def cons : a -> List a -> List a = \a.\l. inr (a, l) end +def pureL : a -> List a = \a. cons a emptyL end + +def foldr : (a -> b -> b) -> b -> List a -> b = \f. \z. λcase + (\_. z) + (λmatch \hd. \tl. f hd (foldr f z tl)) +end + +def foldl : (b -> a -> b) -> b -> List a -> b = \f. \z. λcase + (\_. z) + (λmatch \hd. \tl. (foldl f (f z hd) tl)) +end + +def flip : (a -> b -> c) -> (b -> a -> c) = \f. (\b.\a.f a b) end + +def map : (a -> b) -> List a -> List b = \f. + foldr (\y. cons (f y)) emptyL +end + +def appendL : List a -> List a -> List a = \xs. \ys. + foldr cons ys xs +end + +def lengthL : List a -> Int = foldl (\acc.\_. acc + 1) 0 end + +def safeGetL : Int -> List a -> Maybe a = \i. λcase + (\_. inl ()) + (λmatch \hd. \tl. if (i <= 0) {inr hd} {safeGetL (i - 1) tl}) +end + +def getL : Int -> List a -> a = \i.\l. + case (safeGetL i l) (\_. fail $ "INDEX " ++ format i ++ " OUT OF BOUNDS!") (\a. a) +end + +def formatL : List a -> Text = \l. + let f : List a -> Text = λcase (\_. "]") (λmatch \hd. \tl. ", " ++ format hd ++ f tl) + in case l (\_. "[]") (λmatch \hd. \tl. "[" ++ format hd ++ f tl) +end + +/*******************************************************************/ +/* ORDERED LISTS */ +/*******************************************************************/ + +// get from ordered list +def getKeyL : (a -> k) -> k -> List a -> Maybe a = \p. \x. λcase + (\_. inl ()) + (λmatch \hd. \tl. + let nx = p hd in + if (nx < x) { + getKeyL p x tl + } { + if (nx > x) { + inl () + } { + inr hd + } + } + ) +end + +def containsKeyL : (a -> k) -> k -> List a -> Bool = \p.\x.\l. + case (getKeyL p x l) (\_. false) (\_. true) +end + +// insert into ordered list - replaces elements, like set +def insertKeyL : (a -> k) -> a -> List a -> List a = \p.\y.\l. case l + (\_. pureL y) + (λmatch \hd. \tl. + let nx = p hd in + let x = p y in + if (nx == x) { + inr (y, tl) + } { + if (nx > x) { + cons y l + } { + cons hd (insertKeyL p y tl) + } + } + ) +end + +// delete in ordered list +def deleteKeyL : (a -> k) -> k -> List a -> List a = \p.\x. \l. case l + (\_. emptyL) + (λmatch \hd. \tl. + let nx = p hd in + if (nx == x) { + tl + } { + if (nx > x) { + l + } { + cons hd (deleteKeyL p x tl) + } + } + ) +end + +tydef FlatSet a = List a end + +def flat_set : ISet (FlatSet a) a = + [ empty=emptyL + , insert=insertKeyL (\x.x) + , delete=deleteKeyL (\x.x) + , contains=containsKeyL (\x.x) + , from_list=foldl (flip $ insertKeyL (\x.x)) emptyL + , pretty=formatL + ] +end + +tydef FlatDict k v = List (k * v) end + +def fst = λmatch \a. \_. a end +def snd = λmatch \_. \b. b end + +def flat_dict : IDict (FlatDict k v) k v = + [ empty=emptyL + , insert=\k.\v. insertKeyL fst (k,v) + , delete=deleteKeyL fst + , get=\k.\d. mmap snd (getKeyL fst k d) + , contains=containsKeyL fst + , pretty=\d. + let p : (k * v) -> Text = λmatch \k. \v. format k ++ ": " ++ format v in + let f : List (k * v) -> Text = λcase (\_. "}") (λmatch \hd. \tl. ", " ++ p hd ++ f tl) + in case d (\_. "{}") (λmatch \hd. \tl. "{" ++ p hd ++ f tl) + ] +end + +/*******************************************************************/ +/* RED BLACK TREE */ +/*******************************************************************/ + + +// equirecursive types allow us to get the node type without mutual recursion +tydef RBNode k = rec n. [red: Bool, k: k, l: Maybe n, r: Maybe n] end + +def emptyT : RBTree k = inl () end + +def getT : (k -> a) -> a -> RBTree k -> Maybe k = \p. \x. \t. case t + (\_. inl ()) + (\n . + let nx = p n.k in + if (x < nx) { + getT p x n.l + } { + if (x > nx) { + getT p x n.r + } { + inr n.k + } + } + ) +end + +def containsT : (k -> a) -> a -> RBTree k -> Bool = \p.\x.\t. getT p x t != inl () end + +def inorder : RBTree k -> List k = \t. case t + (\_. inl ()) + (\n. appendL (inorder n.l) (appendL (pureL n.k) $ inorder n.r)) +end + +def formatT : RBTree k -> Text = \t. case t + (\_. "N") + (\n. + "(T " + ++ if n.red {"R "} {"B "} + ++ formatT n.l ++ " " ++ format n.k ++ " " ++ formatT n.r ++ ")" + ) +end + +def indent_ = \c.\i. if (i <= 0) {" "} {c ++ indent_ c (i - 1)} end +def indent = indent_ " " end + +def debugT : RBTree k -> Cmd Unit = + let d : Text -> Text -> Text -> RBTree k -> Cmd Unit = \i.\li.\ri.\t. case t + (\_. log $ i ++ "+ N") + (\n. + d (i ++ li) " " "| " n.l; + log $ i ++ "+ " ++ if n.red {"R "} {"B "} ++ format n.k; + d (i ++ ri) "| " " " n.r; + ) + in d "" "" "" +end + +/* +balance B (T R (T R a x0 b) x1 c) x2 d = T R (T B a x0 b) x1 (T B c x2 d) -- case 1: LL red +balance B (T R a x0 (T R b x1 c)) x2 d = T R (T B a x0 b) x1 (T B c x2 d) -- case 2: LR red +balance B a x0 (T R (T R b x1 c) x2 d) = T R (T B a x0 b) x1 (T B c x2 d) -- case 3: RL red +balance B a x0 (T R b x1 (T R c x2 d)) = T R (T B a x0 b) x1 (T B c x2 d) -- case 4: RR red +balance color a x b = T color a x b -- case 5 +*/ +def balanceT : RBNode k -> RBTree k = \t. + let balanced : [ a: RBTree k, x0: k, b: RBTree k, x1: k, c: RBTree k, x2: k, d: RBTree k] -> RBTree k + = \v. + inr [red=true, l=inr [red=false, l=v.a, k=v.x0, r=v.b], k=v.x1, r=inr [red=false, l=v.c, k=v.x2, r=v.d]] + in let case5 : RBNode k -> RBTree k = + inr // just id - TODO: inline? + in let balanceRR : RBNode k -> RBNode k -> RBTree k = \t.\rn. + case rn.r (\_. case5 t) (\rrn. + if rrn.red { + balanced [a=t.l, x0=t.k, b=rn.l, x1=rn.k, c=rrn.l, x2=rrn.k, d=rrn.r] + } { + case5 t + } + ) + in let balanceRL : RBNode k -> RBNode k -> RBTree k = \t.\rn. + case rn.l (\_. balanceRR t rn) (\rln. + if rln.red { + balanced [a=t.l, x0=t.k, b=rln.l, x1=rln.k, c=rln.r, x2=rn.k, d=rn.r] + } { + balanceRR t rn + } + ) + in let balanceR : RBNode k -> RBTree k = \t. + case t.r (\_. + case5 t + ) (\lr. + if lr.red { + balanceRL t lr + } { + case5 t + } + ) + in let balanceLR : RBNode k -> RBNode k -> RBTree k = \t.\ln. + case ln.r (\_. balanceR t) (\lrn. + if lrn.red { + balanced [a=ln.l, x0=ln.k, b=lrn.l, x1=lrn.k, c=lrn.r, x2=t.k, d=t.r] + } { + balanceR t + } + ) + in let balanceLL : RBNode k -> RBNode k -> RBTree k = \t.\ln. + case ln.l (\_. balanceLR t ln) (\lln. + if lln.red { + balanced [a=lln.l, x0=lln.k, b=lln.r, x1=ln.k, c=ln.r, x2=t.k, d=t.r] + } { + balanceLR t ln + } + ) + in let balanceL : RBNode k -> RBTree k = \t. + case t.l (\_. + balanceR t + ) (\ln. + if ln.red { + balanceLL t ln + } { + balanceR t + } + ) + in if t.red { + case5 t + } { + balanceL t + } +end + +def insertT : (k -> a) -> k -> RBTree k -> RBTree k = \p.\x.\t. + let ins : (k -> a) -> k -> RBTree k -> RBTree k =\p.\x.\t. case t + (\_. + inr [red=true, k=x, l=inl (), r=inl ()] + ) + (\n. + if (p x == p n.k) { inr [red=n.red, k=x, l=n.l, r=n.r] } { + if (x < n.k) { + balanceT [red=n.red, k=n.k, l=ins p x n.l, r=n.r] + } { + balanceT [red=n.red, k=n.k, l=n.l, r=ins p x n.r] + } + } + ) + in let makeBlack : RBTree k -> RBTree k = \t. case t + (\_. fail "makeBlack will always be called on nonempty") + (\n. inr [red=false, k=n.k, l=n.l, r=n.r] ) + in makeBlack $ ins p x t +end + +def deleteT : (k -> a) -> a -> RBTree k -> RBTree k = \p.\x.\t. + // ------------------------------------------------------------------------------------------------------------ + tydef Del k a = (k -> a) -> a -> RBTree k -> RBTree k end + // ------------------------------------------------------------------------------------------------------------ + let makeBlack : RBTree k -> RBTree k = \t. + case t (\_. t) (\n. inr [red=false, k=n.k, l=n.l, r=n.r]) + in let makeRed : RBNode k -> RBTree k = \n. + inr [red=true, k=n.k, l=n.l, r=n.r] + // ------------------------------------------------------------------------------------------------------------ + /* + balL (T B (T R t1 x t2) y t3) = T R (T B t1 x t2) y t3 + balL (T B t1 y (T B t2 z t3)) = balance' (T B t1 y (T R t2 z t3)) + balL (T B t1 y (T R (T B t2 u t3) z t4@(T B l value r))) + = T R + (T B t1 y t2) + u + (balance' (T B t3 z + (T R l value r))) + */ + in let balL : RBNode k -> RBTree k = \n. + let balL2 : RBNode k -> RBNode k -> RBTree k = \n.\rn. + case rn.l (\_. inr n) (\rln. + if rln.red {inr n} { + case rn.r (\_. inr n) (\rrn. + if rrn.red {inr n} { + inr [red=true, + l=inr [red=false, l=n.l, k=n.k, r=rln.l], + k=rln.k, + r=balanceT [red=false, l=rln.r, k=rn.k, r=inr [red=true, l=rrn.l, k=rrn.k, r=rrn.r]]] + } + ) + } + ) + in let balL1 : RBNode k -> RBTree k = \n. + case n.r (\_. inr n) (\rn. + if rn.red {balL2 n rn} {balanceT [red=false, k=n.k, l=n.l, r=makeRed rn]} + ) + in case n.l (\_. balL1 n) (\ln. if ln.red {inr [red=true, k=n.k, l=makeBlack n.l, r=n.r]} {balL1 n}) + // ------------------------------------------------------------------------------------------------------------ + /* + balR (T B t1 y (T R t2 x t3)) = T R t1 y (T B t2 x t3) + balR (T B (T B t1 z t2) y t3) = balance' (T B (T R t1 z t2) y t3) + balR (T B + ln@(T R + lln@(T B lll llk llr) + lk + lrn@(T B lrl lrk lrr)) + k + rn) + = + T R + (balance' (T B (T R lll llk llr) lk lrl)) + lrk + (T B lrr k rn) + */ + in let balR : RBNode k -> RBTree k = \n. + let balR2 : RBNode k -> RBNode k -> RBTree k = \n.\ln. + case ln.l (\_. inr n) (\lln. + if lln.red {inr n} { + case ln.r (\_. inr n) (\lrn. + if lrn.red {inr n} { + inr [red=true, + l=balanceT [red=false, l=inr [red=true, l=lln.l, k=lln.k, r=lln.r], k=ln.k, r=lrn.l], + k=lrn.k, + r=inr [red=false, l=lrn.r, k=n.k, r=n.r]] + } + ) + } + ) + in let balR1 : RBNode k -> RBTree k = \n. + case n.l (\_. inr n) (\ln. + if ln.red {balR2 n ln} {balanceT [red=false, k=n.k, l=makeRed ln, r=n.r]} + ) + in case n.r (\_. balR1 n) (\rn. if rn.red {inr [red=true, k=n.k, l=n.l, r=makeBlack n.r]} {balR1 n}) + // ------------------------------------------------------------------------------------------------------------ + in let delL : Del k a -> (k -> a) -> a -> RBNode k -> RBTree k = \del.\p.\x.\n. + let dl = [red=n.red, k=n.k, l=del p x n.l, r=n.r] in + if n.red { inr dl } { balL dl } + // ------------------------------------------------------------------------------------------------------------ + in let delR : Del k a -> (k -> a) -> a -> RBNode k -> RBTree k = \del.\p.\x.\n. + let dr = [red=n.red, k=n.k, l=n.l, r=del p x n.r] in + if n.red { inr dr } { balR dr } + // ------------------------------------------------------------------------------------------------------------ + /* + fuse E t = t + fuse t E = t + fuse t1@(T B _ _ _) (T R t3 y t4) = T R (fuse t1 t3) y t4 + fuse (T R t1 x t2) t3@(T B _ _ _) = T R t1 x (fuse t2 t3) + fuse (T R t1 x t2) (T R t3 y t4) = + let s = fuse t2 t3 + in case s of + (T R s1 z s2) -> (T R (T R t1 x s1) z (T R s2 y t4)) + (T B _ _ _) -> (T R t1 x (T R s y t4)) + fuse (T B t1 x t2) (T B t3 y t4) = + let s = fuse t2 t3 + in case s of + (T R s1 z s2) -> (T R (T B t1 x s1) z (T B s2 y t4)) + (T B s1 z s2) -> balL (T B t1 x (T B s y t4)) + */ + in let fuse: RBTree k -> RBTree k -> RBTree k = \l.\r. + case l (\_. r) (\ln. case r (\_. l) (\rn. + if ln.red { + if rn.red { + /* RED RED */ + let s = fuse ln.r rn.l in + let b_case = {inr [red=true, l=ln.l, k=ln.k, r=inr [red=true, l=s, k=rn.k, r=rn.r]]} in + case s (\_. force b_case) (\sn. + if sn.red { + inr [red=true, l=inr [red=true, l=ln.l, k=ln.k, r=sn.l], k=sn.k, r=inr [red=true, l=sn.r, k=rn.k, r=rn.r]] + } { + force b_case + } + ) + } { + /* RED BLACK */ + inr [red=true, l=ln.l, k=ln.k, r=fuse ln.r (inr rn)] + } + } { + if rn.red { + /* BLACK RED */ + inr [red=true, l=fuse (inr ln) rn.l, k=rn.k, r=rn.r] + } { + /* BLACK BLACK */ + let s = fuse ln.r rn.l in + let b_case = {balL [red=false, l=ln.l, k=ln.k, r=inr [red=false, l=s, k=rn.k, r=rn.r]]} in + case s (\_. force b_case) (\sn. + if sn.red { + inr [red=true, l=inr [red=false, l=ln.l, k=ln.k, r=sn.l], k=sn.k, r=inr [red=false, l=sn.r, k=rn.k, r=rn.r]] + } { + force b_case + } + ) + } + } + )) + // ------------------------------------------------------------------------------------------------------------ + in let del : (k -> a) -> a -> RBTree k -> RBTree k = \p.\x.\t. + case t (\_.t) (\n. + if (p n.k == x) {fuse n.l n.r} { + if (x < p n.k) {delL del p x n} {delR del p x n} + } + ) + // ------------------------------------------------------------------------------------------------------------ + in makeBlack $ del p x t +end + +/*******************************************************************/ +/* DICTIONARY */ +/*******************************************************************/ + +tydef Dict k v = RBTree (k * v) end + +def tree_dict : IDict (Dict k v) k v = + [ empty = emptyT + , get = \k.\d. mmap snd (getT fst k d) + , contains = containsT fst + , insert = \k.\v. insertT fst (k, v) + , delete = \k. deleteT fst k + , pretty = \d. flat_dict.pretty (inorder d) + ] +end + +/*******************************************************************/ +/* SET */ +/*******************************************************************/ + +tydef Set k = RBTree k end + +def tree_set : ISet (Set a) a = + [ empty=emptyT + , insert=insertT (\x.x) + , delete=deleteT (\x.x) + , contains=containsT (\x.x) + , from_list=foldl (flip $ insertT (\x.x)) emptyT + , pretty=\s. formatL $ inorder s + ] +end + +/*******************************************************************/ +/* UNIT TESTS */ +/*******************************************************************/ + +def assert = \i. \b. \m. if b {log $ indent i ++ "OK: " ++ m} {log "FAIL:"; fail m} end + +def assert_eq + = \i. \exp. \act. \m. + if (exp == act) {log $ indent i ++ "OK: " ++ m} { + log (indent i ++ "FAIL: expected " ++ format exp ++ " actual " ++ format act); + fail m + } +end + +def group = \i. \m. \tests. + log $ indent i ++ "START " ++ m ++ ":"; + tests $ i + 1; + pure () +end + +def test_empty: Int -> Cmd Unit = \i. + let d = tree_dict in + group i "EMPTY TESTS" (\i. + assert_eq i (inl ()) (d.get 0 $ d.empty) "no element should be present in an empty tree"; + assert i (not $ d.contains 0 $ d.empty) "empty tree should not contain any elements"; + ) +end + +def test_insert_1235: ISet s Int -> Int -> Cmd Unit =\s.\i. + let expected = cons 1 $ cons 2 $ cons 3 $ cons 5 emptyL in + let actual = s.insert 2 $ s.insert 5 $ s.insert 1 $ s.insert 3 s.empty in + assert_eq i (formatL expected) (formatL actual) "insertKeyL should insert in order"; + assert i (not $ s.contains 0 actual) "not contains 0 [1,2,3,5]"; + assert i (s.contains 1 actual) "contains 1 [1,2,3,5]"; + assert i (s.contains 2 actual) "contains 2 [1,2,3,5]"; + assert i (s.contains 3 actual) "contains 3 [1,2,3,5]"; + assert i (not $ s.contains 4 actual) "not contains 4 [1,2,3,5]"; + assert i (s.contains 5 actual) "contains 5 [1,2,3,5]"; + assert i (not $ s.contains 6 actual) "not contains 6 [1,2,3,5]"; +end + +def test_ordered_list : Int -> Cmd Unit = \i. + let s = flat_set in + group i "ORDERED LIST TESTS" (test_insert_1235 flat_set) +end + +def test_insert: Int -> Cmd Unit = \i. + let d = tree_dict in + let s = tree_set in + group i "INSERT TESTS" (\i. + group i "test {0: 1}" (\i. + let tree0 = d.insert 0 1 d.empty in + assert i (d.empty != tree0) "nonempty tree should not be empty"; + assert_eq i (inr 1) (d.get 0 $ tree0) "one element should be present in a one element tree"; + assert i (d.contains 0 $ tree0) "one element tree should contain that elements"; + assert i (not $ d.contains 1 $ tree0) "one element tree should contain only that elements"; + ); + group i "test {0: 1, 2: 3}" (\i. + let tree02 = d.insert 2 3 $ d.insert 0 1 d.empty in + assert_eq i (inr 1) (d.get 0 $ tree02) "get 0 {0: 1, 2: 3} == 1"; + assert_eq i (inr 3) (d.get 2 $ tree02) "get 2 {0: 1, 2: 3} == 3"; + ); + group i "test {1,2,3,5}" (test_insert_1235 tree_set) + ); +end + +def randomTestS: Int -> Set Int -> (Set Int -> Cmd a) -> Cmd (Set Int) = \i.\s.\test. + if (i <= 0) {pure s} { + x <- random 20; + let ns = tree_set.insert x s in + test ns; + randomTestS (i - 1) ns test + } +end + +def delete_insert_prop: Int -> Set Int -> Cmd Unit = \i.\t. + let s = tree_set in + x <- random 20; + let i_t = inorder t in + let f_t = s.pretty t in + if (not $ s.contains x t) { + // log $ format x; + assert_eq i + (formatL i_t) + (s.pretty $ s.delete x $ s.insert x t) + (f_t ++ " == delete " ++ format x ++ " $ insert " ++ format x ++ " " ++ f_t) + } { delete_insert_prop i t /* reroll */} +end + +def delete_delete_prop: Int -> Set a -> Cmd Unit = \i.\t. + let s = tree_set in + let i_t = inorder t in + ix <- random (lengthL i_t); + let x = getL ix i_t in + let ds = s.delete x t in + let dds = s.delete x ds in + let f_t = s.pretty t in + let f_dx = "delete " ++ format x in + assert_eq i (s.pretty ds) (s.pretty dds) + (f_dx ++ f_t ++ " == " ++ f_dx ++ " $ " ++ f_dx ++ " " ++ f_t) +end + +def test_delete: Int -> Cmd Unit = \i. + group i "DELETE TESTS" (\i. + randomTestS 15 tree_set.empty (\s. + group i (tree_set.pretty s) (\i. + delete_insert_prop i s; + delete_delete_prop i s; + ) + ) + ) +end + +def test_tree: Cmd Unit = + group 0 "TREE TESTS" (\i. + test_empty i; + test_ordered_list i; + test_insert i; + test_delete i; + ); + log "ALL TREE TESTS PASSED!" +end + +/*******************************************************************/ +/* BENCHMARKS */ +/*******************************************************************/ + +def benchmark: Int -> s -> (s -> s) -> Cmd (Int * (Int * Int)) = \times.\s.\act. + let min = \x.\y. if (x > y) {y} {x} in + let max = \x.\y. if (x > y) {x} {y} in + let runM: (Int * Maybe (Int * Int)) -> s -> Int -> Cmd (Int * Maybe (Int * Int)) = \acc.\s.\n. + if (n <= 0) { + pure acc + } { + t0 <- time; + //log $ "START " ++ format t0; + let ns = act s in + t1 <- time; + //log $ "END " ++ format t1; + let t = t1 - t0 in + //log $ format s ++ " " ++ format t ++ " ticks"; + match acc \acc1. \acc2. + let lim = case acc2 (\_. (t, t)) (λmatch \l1. \l2. (min t l1, max t l2)) in + runM ((acc1 + t), inr lim) ns (n - 1) + } in + //log "start run"; + res <- runM (0, inl ()) s times; + //log "end run"; + match res \res1. \res2. + let avg = res1 / times in + let lim = case res2 (\_. fail "BENCHMARK NOT RUN") (\l.l) in + pure (avg, lim) +end + +def cmp_bench : Int -> Text -> (Int * (Int * Int)) -> Text -> (Int * (Int * Int)) -> Cmd Unit + = \i.\base_name.\base_res.\new_name.\new_res. + let formatLim = λmatch \a. \b. "(min " ++ format a ++ ", max " ++ format b ++ ")" in + log $ indent i ++ "* " ++ base_name ++ ": " + ++ format (fst base_res) ++ " ticks " ++ formatLim (snd base_res); + + let d = (fst new_res * 100) / fst base_res in + let cmp = if (d > 100) { + format (d - 100) ++ "% slower" + } { + format (100 - d) ++ "% faster" + } in + match new_res \res1. \res2. + log $ indent i ++ "* " ++ new_name ++ ": " + ++ format res1 ++ " ticks " ++ formatLim res2 + ++ " <- " ++ cmp; +end + +// Get a list of random integers of given length and maximum element number +def gen_random_list: Int -> Int -> Cmd (List Int) = + let gen = \acc.\n.\rlim. + if (n <= 0) { pure acc } { + x <- random rlim; + gen (cons x acc) (n - 1) rlim + } + in gen emptyL +end + +// Get a number of lists of random integers of given length and maximum element number +def gen_random_lists: Int -> Int -> Int -> Cmd (List (List Int)) = \m.\n.\rlim. + let gen = \acc.\m. + if (m <= 0) { pure acc } { + l <- gen_random_list n rlim; + gen (cons l acc) (m - 1) + } + in gen emptyL m +end + + +def bench_insert = \i. + // Use the given function to construct (Flat)Set from the head of provided list of lists and return the tail + let set_from_first_list : (List a -> s) -> List (List a) -> List (List a) =\from_list.\lls. + case lls + (\_. lls) + // The 'ns = from_list ls' binding is unused, but intentional: + // we want to benchmark how long it takes. + (λmatch \ls. \nlls. let ns = from_list ls in nlls) + in + + group i "INSERT BENCHMARK" (\i. + group i "INSERT 10" (\i. + let n = 10 in + let m = 5 in + lls10 <- gen_random_lists m n (3 * n); + flat_res <- benchmark m lls10 (set_from_first_list flat_set.from_list); + tree_res <- benchmark m lls10 (set_from_first_list tree_set.from_list); + cmp_bench i "flat set" flat_res "tree set" tree_res + ); + group i "INSERT 100" (\i. + let n = 100 in + let m = 3 in + lls100 <- gen_random_lists m n (3 * n); + flat_res <- benchmark m lls100 (set_from_first_list flat_set.from_list); + tree_res <- benchmark m lls100 (set_from_first_list tree_set.from_list); + cmp_bench i "flat set" flat_res "tree set" tree_res + ) + ) +end + +def bench_contains = \i. + let contains_int : s -> (Int -> s -> Bool) -> Int -> Int = \s.\contains.\n. + let _ = contains n s in n + 1 + in + group i "CONTAINS BENCHMARK" (\i. + group i "CONTAINS 10" (\i. + let n = 10 in + let m = 3 * n in + ls10 <- gen_random_list n m; + let fls = flat_set.from_list ls10 in + flat_res <- benchmark m 0 (contains_int fls flat_set.contains); + let tls = tree_set.from_list ls10 in + tree_res <- benchmark m 0 (contains_int tls tree_set.contains); + cmp_bench i "flat set" flat_res "tree set" tree_res + ); + group i "CONTAINS 100" (\i. + let n = 100 in + let m = 3 * n in + ls100 <- gen_random_list n m; + //log $ formatL ls100; + let fls = flat_set.from_list ls100 in + //log $ formatL fls; + flat_res <- benchmark m 0 (contains_int fls flat_set.contains); + let tls = tree_set.from_list ls100 in + //log $ formatS tls; + tree_res <- benchmark m 0 (contains_int tls tree_set.contains); + cmp_bench i "flat set" flat_res "tree set" tree_res + ) + ) +end + +def benchmark_tree: Cmd Unit = + group 0 "TREE BENCHMARKS" (\i. + bench_insert i; + bench_contains i; + ); + log "ALL BENCHMARKS DONE!" +end diff --git a/src/swarm-doc/Swarm/Doc/Command.hs b/src/swarm-doc/Swarm/Doc/Command.hs --- a/src/swarm-doc/Swarm/Doc/Command.hs +++ b/src/swarm-doc/Swarm/Doc/Command.hs @@ -12,7 +12,6 @@ import GHC.Generics (Generic) import Servant.Docs qualified as SD import Swarm.Doc.Util -import Swarm.Language.Pretty (unchainFun) import Swarm.Language.Syntax import Swarm.Language.Syntax.CommandMetadata import Swarm.Language.Typecheck (inferConst) @@ -63,7 +62,7 @@ cmdInfo = constInfo c cmdEffects = effectInfo $ constDoc cmdInfo - getArgs ((Forall _ t)) = unchainFun t + getArgs = unchainFun . ptBody rawArgs = getArgs $ inferConst c diff --git a/src/swarm-doc/Swarm/Doc/Gen.hs b/src/swarm-doc/Swarm/Doc/Gen.hs --- a/src/swarm-doc/Swarm/Doc/Gen.hs +++ b/src/swarm-doc/Swarm/Doc/Gen.hs @@ -15,41 +15,31 @@ -- ** Wiki pages PageAddress (..), - -- ** Recipe graph data - RecipeGraphData (..), + -- ** Recipe graph drawing EdgeFilter (..), - classicScenarioRecipeGraphData, - ignoredEntities, ) where import Control.Lens (view, (^.)) import Control.Monad (zipWithM, zipWithM_) +import Data.Aeson.Text (encodeToLazyText) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (toList) import Data.List qualified as List import Data.List.Extra (enumerate) -import Data.Map.Lazy (Map, (!)) import Data.Map.Lazy qualified as Map import Data.Maybe (fromMaybe, mapMaybe) 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 Data.Text.Lazy.IO qualified as TL +import Swarm.Doc.Command (getCatalog) import Swarm.Doc.Keyword import Swarm.Doc.Pedagogy -import Swarm.Doc.Util import Swarm.Doc.Wiki.Cheatsheet -import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName, entityYields) -import Swarm.Game.Entity qualified as E -import Swarm.Game.Failure (simpleErrorHandle) -import Swarm.Game.Land -import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs) -import Swarm.Game.Robot (Robot, equippedDevices, robotInventory) -import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..), loadStandaloneScenario, scenarioLandscape) -import Swarm.Game.World.Gen (extractEntities) -import Swarm.Game.World.Typecheck (Some (..)) +import Swarm.Game.Entity (Entity, entityName, entityYields) +import Swarm.Game.Recipe (recipeCatalysts, recipeInputs, recipeOutputs) +import Swarm.Game.Recipe.Graph qualified as RG import Swarm.Language.Key (specialKeyNames) import Swarm.Util (both) import Text.Dot (Dot, NodeId, (.->.)) @@ -73,6 +63,8 @@ SpecialKeyNames :: GenerateDocs -- | Cheat sheets for inclusion on the Swarm wiki. CheatSheet :: PageAddress -> SheetType -> GenerateDocs + -- | JSON representation of commands metadata matrix + CommandsData :: GenerateDocs -- | List command introductions by tutorial TutorialCoverage :: GenerateDocs deriving (Eq, Show) @@ -94,6 +86,7 @@ mapM_ editorGen enumerate SpecialKeyNames -> generateSpecialKeyNames CheatSheet address s -> makeWikiPage address s + CommandsData -> TL.putStrLn $ encodeToLazyText getCatalog TutorialCoverage -> renderTutorialProgression >>= putStrLn . T.unpack -- ---------------------------------------------------------------------------- @@ -143,7 +136,7 @@ generateRecipe :: EdgeFilter -> IO String generateRecipe ef = do - graphData <- classicScenarioRecipeGraphData + graphData <- RG.classicScenarioRecipeGraph return . Dot.showDot $ recipesToDot graphData ef data EdgeFilter = NoFilter | FilterForward | FilterNext @@ -155,30 +148,33 @@ FilterForward -> i <= o FilterNext -> i + 1 == o -recipesToDot :: RecipeGraphData -> EdgeFilter -> Dot () +recipesToDot :: RG.RecipeGraph -> EdgeFilter -> Dot () recipesToDot graphData ef = do Dot.attribute ("rankdir", "LR") Dot.attribute ("ranksep", "2") world <- diamond "World" base <- diamond "Base" -- -------------------------------------------------------------------------- - -- add nodes with for all the known entities - let enames' = map (view entityName) . toList $ rgAllEntities graphData - enames = filter (`Set.notMember` ignoredEntities) enames' - ebmap <- Map.fromList . zip enames <$> mapM (box . unpack) enames + -- add nodes for all the known entities + let enames' = map (view entityName) . toList $ RG.allEntities graphData + enames = filter (`Set.notMember` RG.ignoredEntities) enames' + ebmap <- Map.fromList . zip enames <$> mapM (box . T.unpack) enames -- -------------------------------------------------------------------------- -- getters for the NodeId based on entity name or the whole entity let safeGetEntity m e = fromMaybe (error $ show e <> " is not an entity!?") $ m Map.!? e + -- The above call to `error` (1) should never happen, and (2) + -- even if it does, it will only crash recipe cheatsheet + -- generation, not the game itself. getE = safeGetEntity ebmap nid = getE . view entityName -- -------------------------------------------------------------------------- -- Get the starting inventories, entities present in the world and compute -- how hard each entity is to get - see 'recipeLevels'. - let devs = rgStartingDevices graphData - inv = rgStartingInventory graphData - worldEntities = rgWorldEntities graphData - levels = rgLevels graphData - recipes = rgRecipes graphData + let devs = RG.startingDevices graphData + inv = RG.startingInventory graphData + worldEntities = RG.worldEntities graphData + levels = RG.levels graphData + recipes = RG.recipes graphData -- -------------------------------------------------------------------------- -- Base inventory (_bc, ()) <- Dot.cluster $ do @@ -242,97 +238,8 @@ mapM_ (uncurry (---<>)) (recipesToPairs recipeReqOut recipes) -- -------------------------------------------------------------------------- -- also draw an edge for each entity that "yields" another entity - let yieldPairs = mapMaybe (\e -> (e ^. entityName,) <$> (e ^. entityYields)) . toList $ rgAllEntities graphData + let yieldPairs = mapMaybe (\e -> (e ^. entityName,) <$> (e ^. entityYields)) . toList $ RG.allEntities graphData mapM_ (uncurry (.-<>.)) (both getE <$> yieldPairs) - -data RecipeGraphData = RecipeGraphData - { rgWorldEntities :: Set Entity - , rgStartingDevices :: Set Entity - , rgStartingInventory :: Set Entity - , rgLevels :: [Set Entity] - , rgAllEntities :: Set Entity - , rgRecipes :: [Recipe Entity] - } - -classicScenarioRecipeGraphData :: IO RecipeGraphData -classicScenarioRecipeGraphData = simpleErrorHandle $ do - (classic, GameStateInputs (ScenarioInputs worlds (TerrainEntityMaps _ emap)) recipes) <- - loadStandaloneScenario "data/scenarios/classic.yaml" - baseRobot <- instantiateBaseRobot (classic ^. scenarioLandscape) - let classicTerm = worlds ! "classic" - let devs = startingDevices baseRobot - let inv = Map.keysSet $ startingInventory baseRobot - let worldEntities = case classicTerm of Some _ t -> extractEntities t - return - RecipeGraphData - { rgStartingDevices = devs - , rgStartingInventory = inv - , rgWorldEntities = worldEntities - , rgLevels = recipeLevels emap recipes (Set.unions [worldEntities, devs, inv]) - , rgAllEntities = Set.fromList . Map.elems $ entitiesByName emap - , rgRecipes = recipes - } - --- ---------------------------------------------------------------------------- --- RECIPE LEVELS --- ---------------------------------------------------------------------------- - --- | Order entities in sets depending on how soon it is possible to obtain them. --- --- So: --- * Level 0 - starting entities (for example those obtainable in the world) --- * Level N+1 - everything possible to make (or drill or harvest) from Level N --- --- This is almost a BFS, but the requirement is that the set of entities --- required for recipe is subset of the entities known in Level N. --- --- If we ever depend on some graph library, this could be rewritten --- as some BFS-like algorithm with added recipe nodes, but you would --- need to enforce the condition that recipes need ALL incoming edges. -recipeLevels :: EntityMap -> [Recipe Entity] -> Set Entity -> [Set Entity] -recipeLevels emap recipes start = levels - where - recipeParts r = ((r ^. recipeInputs) <> (r ^. recipeCatalysts), r ^. recipeOutputs) - m :: [(Set Entity, Set Entity)] - m = map (both (Set.fromList . map snd) . recipeParts) recipes - levels :: [Set Entity] - levels = reverse $ go [start] start - where - isKnown known (i, _o) = null $ i Set.\\ known - lookupYield e = case view entityYields e of - Nothing -> e - Just yn -> case E.lookupEntityName yn emap of - Nothing -> error "unknown yielded entity" - Just ye -> ye - yielded = Set.map lookupYield - nextLevel known = Set.unions $ yielded known : map snd (filter (isKnown known) m) - go ls known = - let n = nextLevel known Set.\\ known - in if null n - then ls - else go (n : ls) (Set.union n known) - -startingDevices :: Robot -> Set Entity -startingDevices = Set.fromList . map snd . E.elems . view equippedDevices - -startingInventory :: Robot -> Map Entity Int -startingInventory = Map.fromList . map swap . E.elems . view robotInventory - --- | Ignore utility entities that are just used for tutorials and challenges. -ignoredEntities :: Set Text -ignoredEntities = - Set.fromList - [ "upper left corner" - , "upper right corner" - , "lower left corner" - , "lower right corner" - , "horizontal wall" - , "vertical wall" - , "left and vertical wall" - , "up and horizontal wall" - , "right and vertical wall" - , "down and horizontal wall" - ] -- ---------------------------------------------------------------------------- -- GRAPHVIZ HELPERS diff --git a/src/swarm-doc/Swarm/Doc/Pedagogy.hs b/src/swarm-doc/Swarm/Doc/Pedagogy.hs --- a/src/swarm-doc/Swarm/Doc/Pedagogy.hs +++ b/src/swarm-doc/Swarm/Doc/Pedagogy.hs @@ -20,7 +20,8 @@ import Control.Lens (universe, view, (^.)) import Control.Monad (guard) -import Data.List (foldl', intercalate, sort, sortOn) +import Data.Foldable (Foldable (..)) +import Data.List (intercalate, sort, sortOn) import Data.List.Extra (zipFrom) import Data.Map (Map) import Data.Map qualified as M @@ -31,7 +32,7 @@ import Data.Text (Text) import Data.Text qualified as T import Swarm.Constant -import Swarm.Game.Failure (SystemFailure, simpleErrorHandle) +import Swarm.Failure (SystemFailure, simpleErrorHandle) import Swarm.Game.Land import Swarm.Game.Scenario ( Scenario, @@ -44,20 +45,21 @@ scenarioSolution, ) import Swarm.Game.Scenario.Objective (objectiveGoal) +import Swarm.Game.Scenario.Status import Swarm.Game.ScenarioInfo ( ScenarioCollection, - ScenarioInfoPair, flatten, getTutorials, loadScenarios, + pathifyCollection, scenarioCollectionToList, - scenarioPath, ) import Swarm.Game.World.Load (loadWorlds) import Swarm.Language.Syntax import Swarm.Language.Text.Markdown (docToText, findCode) import Swarm.Language.Types (Polytype) import Swarm.Util.Effect (ignoreWarnings) +import Prelude hiding (Foldable (..)) -- * Constants @@ -79,7 +81,7 @@ -- introduced in their solution and descriptions -- having been extracted data TutorialInfo = TutorialInfo - { scenarioPair :: ScenarioInfoPair + { scenarioPair :: ScenarioWith ScenarioPath , tutIndex :: Int , solutionCommands :: Map Const [SrcLoc] , descriptionCommands :: Set Const @@ -94,8 +96,8 @@ -- * Functions -- | Extract commands from both goal descriptions and solution code. -extractCommandUsages :: Int -> ScenarioInfoPair -> TutorialInfo -extractCommandUsages idx siPair@(s, _si) = +extractCommandUsages :: Int -> ScenarioWith ScenarioPath -> TutorialInfo +extractCommandUsages idx siPair@(ScenarioWith s _si) = TutorialInfo siPair idx solnCommands $ getDescCommands s where solnCommands = getCommands maybeSoln @@ -118,7 +120,7 @@ isConsidered :: Const -> Bool isConsidered c = isUserFunc c && c `S.notMember` ignoredCommands where - ignoredCommands = S.fromList [Run, Return, Noop, Force] + ignoredCommands = S.fromList [Run, Pure, Noop, Force] -- | Extract the command names from the source code of the solution. -- @@ -140,13 +142,13 @@ -- | "fold" over the tutorials in sequence to determine which -- commands are novel to each tutorial's solution. -computeCommandIntroductions :: [(Int, ScenarioInfoPair)] -> [CoverageInfo] +computeCommandIntroductions :: [(Int, ScenarioWith ScenarioPath)] -> [CoverageInfo] computeCommandIntroductions = reverse . tuts . foldl' f initial where initial = CommandAccum mempty mempty - f :: CommandAccum -> (Int, ScenarioInfoPair) -> CommandAccum + f :: CommandAccum -> (Int, ScenarioWith ScenarioPath) -> CommandAccum f (CommandAccum encounteredPreviously xs) (idx, siPair) = CommandAccum updatedEncountered $ CoverageInfo usages novelCommands : xs where @@ -158,9 +160,9 @@ -- | Extract the tutorials from the complete scenario collection -- and derive their command coverage info. -generateIntroductionsSequence :: ScenarioCollection -> [CoverageInfo] +generateIntroductionsSequence :: ScenarioCollection ScenarioInfo -> [CoverageInfo] generateIntroductionsSequence = - computeCommandIntroductions . zipFrom 0 . getTuts + computeCommandIntroductions . zipFrom 0 . getTuts . pathifyCollection where getTuts = concatMap flatten @@ -171,7 +173,7 @@ -- | Helper for standalone rendering. -- For unit tests, can instead access the scenarios via the GameState. -loadScenarioCollection :: IO ScenarioCollection +loadScenarioCollection :: IO (ScenarioCollection ScenarioInfo) loadScenarioCollection = simpleErrorHandle $ do tem <- loadEntitiesAndTerrain @@ -180,17 +182,17 @@ -- all the scenarios via the usual code path; we do not need to do -- anything with them here while simply rendering pedagogy info. worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem - ignoreWarnings @(Seq SystemFailure) $ loadScenarios $ ScenarioInputs worlds tem + ignoreWarnings @(Seq SystemFailure) $ loadScenarios (ScenarioInputs worlds tem) True renderUsagesMarkdown :: CoverageInfo -> Text -renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) = +renderUsagesMarkdown (CoverageInfo (TutorialInfo (ScenarioWith s (ScenarioPath sp)) idx _sCmds dCmds) novelCmds) = T.unlines bodySections where bodySections = firstLine : otherLines otherLines = intercalate [""] - [ pure . surround "`" . T.pack $ view scenarioPath si + [ pure . surround "`" . T.pack $ sp , pure . surround "*" . T.strip . docToText $ view (scenarioOperation . scenarioDescription) s , renderSection "Introduced in solution" . renderCmdList $ M.keysSet novelCmds , renderSection "Referenced in description" $ renderCmdList dCmds @@ -249,7 +251,7 @@ render (cmd, tut) = T.unwords [ linkifyCommand cmd - , "(" <> renderTutorialTitle (tutIndex tut) (fst $ scenarioPair tut) <> ")" + , "(" <> renderTutorialTitle (tutIndex tut) (view getScenario $ scenarioPair tut) <> ")" ] renderFullCmdList = renderList . map render . sortOn fst infos = generateIntroductionsSequence ss diff --git a/src/swarm-doc/Swarm/Doc/Schema/Refined.hs b/src/swarm-doc/Swarm/Doc/Schema/Refined.hs --- a/src/swarm-doc/Swarm/Doc/Schema/Refined.hs +++ b/src/swarm-doc/Swarm/Doc/Schema/Refined.hs @@ -9,6 +9,7 @@ module Swarm.Doc.Schema.Refined where import Control.Applicative ((<|>)) +import Control.Monad (unless) import Data.Aeson import Data.List.Extra (replace) import Data.List.NonEmpty (NonEmpty) @@ -122,9 +123,8 @@ theType <- maybe (fail "Unspecified sub-schema type") return maybeType markdownDescription <- mapM getMarkdown $ _description rawSchema - if null (_properties rawSchema) || not (fromMaybe True (_additionalProperties rawSchema)) - then return () - else fail "All objects must specify '\"additionalProperties\": true'" + unless (null (_properties rawSchema) || not (fromMaybe True (_additionalProperties rawSchema))) $ + fail "All objects must specify '\"additionalProperties\": true'" return SwarmSchema diff --git a/src/swarm-doc/Swarm/Doc/Util.hs b/src/swarm-doc/Swarm/Doc/Util.hs --- a/src/swarm-doc/Swarm/Doc/Util.hs +++ b/src/swarm-doc/Swarm/Doc/Util.hs @@ -7,15 +7,8 @@ -- Utilities for generating doc markup module Swarm.Doc.Util where -import Control.Effect.Throw (Has, Throw, throwError) -import Control.Lens (view) -import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Text qualified as T -import Swarm.Game.Failure (SystemFailure (CustomFailure)) -import Swarm.Game.Robot (Robot) -import Swarm.Game.Robot.Concrete (instantiateRobot) -import Swarm.Game.Scenario (ScenarioLandscape, scenarioRobots) import Swarm.Language.Syntax (Const (..)) import Swarm.Language.Syntax qualified as Syntax @@ -45,8 +38,3 @@ constSyntax :: Const -> Text constSyntax = Syntax.syntax . Syntax.constInfo - -instantiateBaseRobot :: Has (Throw SystemFailure) sig m => ScenarioLandscape -> m Robot -instantiateBaseRobot sLandscape = case listToMaybe $ view scenarioRobots sLandscape of - Just r -> pure $ instantiateRobot Nothing 0 r - Nothing -> throwError $ CustomFailure "Scenario contains no robots" diff --git a/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs b/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs --- a/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs +++ b/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs @@ -28,21 +28,21 @@ import Swarm.Doc.Util import Swarm.Doc.Wiki.Matrix import Swarm.Doc.Wiki.Util +import Swarm.Failure (simpleErrorHandle) import Swarm.Game.Device qualified as D 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.Failure (simpleErrorHandle) import Swarm.Game.Recipe (Recipe, loadRecipes, recipeCatalysts, recipeInputs, recipeOutputs, recipeTime, recipeWeight) import Swarm.Game.Terrain (loadTerrain, terrainByName) import Swarm.Language.Capability (Capability) import Swarm.Language.Capability qualified as Capability -import Swarm.Language.Pretty (prettyText, prettyTextLine) import Swarm.Language.Syntax (Const (..)) import Swarm.Language.Syntax qualified as Syntax import Swarm.Language.Text.Markdown as Markdown (docToMark) import Swarm.Language.Typecheck (inferConst) -import Swarm.Util (showT) +import Swarm.Pretty (prettyText, prettyTextLine) +import Swarm.Util (applyWhen, maximum0, showT) -- * Types @@ -67,7 +67,7 @@ Commands -> T.putStrLn commandsPage CommandMatrix -> case pandocToText commandsMatrix of Right x -> T.putStrLn x - Left x -> error $ T.unpack x + Left x -> T.putStrLn x Capabilities -> simpleErrorHandle $ do entities <- loadEntities sendIO $ T.putStrLn $ capabilityPage address entities @@ -99,7 +99,7 @@ format w x = wrap ' ' x <> T.replicate (w - T.length x) " " maxWidths :: [[Text]] -> [Int] -maxWidths = map (maximum . map T.length) . transpose +maxWidths = map (maximum0 . map T.length) . transpose -- ** COMMANDS @@ -170,10 +170,7 @@ then t else addLink (entityAddress <> "#" <> T.replace " " "-" t) t linkCommand c = - ( if T.null commandsAddress - then id - else addLink (commandsAddress <> "#" <> showT c) - ) + applyWhen (not $ T.null commandsAddress) (addLink $ commandsAddress <> "#" <> showT c) . codeQuote $ constSyntax c @@ -188,7 +185,11 @@ header = [listToRow mw capabilityHeader, separatingLine mw] capabilityPage :: PageAddress -> EntityMap -> Text -capabilityPage a em = capabilityTable a em enumerate +capabilityPage a em = capabilityTable a em $ filter usedCapability enumerate + where + usedCapability c = case c of + Capability.CExecute con -> Capability.constCaps con == Just c + _ -> True -- ** Entities diff --git a/src/swarm-engine/Swarm/Game/Achievement/Attainment.hs b/src/swarm-engine/Swarm/Game/Achievement/Attainment.hs --- a/src/swarm-engine/Swarm/Game/Achievement/Attainment.hs +++ b/src/swarm-engine/Swarm/Game/Achievement/Attainment.hs @@ -12,7 +12,7 @@ obtainedAt, ) where -import Control.Lens hiding (from, (<.>)) +import Control.Lens (makeLenses) import Data.Aeson ( Options (..), defaultOptions, @@ -23,7 +23,9 @@ import Data.Time (ZonedTime, zonedTimeToUTC) import Data.Yaml as Y import GHC.Generics (Generic) -import Swarm.Game.Achievement.Definitions +import Swarm.Game.Achievement.Definitions ( + CategorizedAchievement, + ) -- | A record holding an achievement along with some metadata to -- record the time at which the achievement was obtained, and the diff --git a/src/swarm-engine/Swarm/Game/Achievement/Description.hs b/src/swarm-engine/Swarm/Game/Achievement/Description.hs --- a/src/swarm-engine/Swarm/Game/Achievement/Description.hs +++ b/src/swarm-engine/Swarm/Game/Achievement/Description.hs @@ -103,6 +103,13 @@ "`give` something to your`self`." Easy True + GameplayAchievement EquippedAllDevices -> + AchievementInfo + "Swiss Army Robot" + (Just $ Freeform "You never know when that might come in handy...") + "`equip` all craftable devices simultaneously." + Gruelling + True -- | Validity conditions are required if-and-only-if the achievement -- category is 'GameplayAchievement'. @@ -116,3 +123,4 @@ GetDisoriented -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode SwapSame -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode GaveToSelf -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode + EquippedAllDevices -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode diff --git a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs --- a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs +++ b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs @@ -13,10 +13,10 @@ import Control.Monad (forM_) import Data.Sequence (Seq) import Data.Yaml qualified as Y +import Swarm.Failure import Swarm.Game.Achievement.Attainment import Swarm.Game.Achievement.Definitions -import Swarm.Game.Failure -import Swarm.Game.ResourceLoading (getSwarmAchievementsPath) +import Swarm.ResourceLoading (getSwarmAchievementsPath) import Swarm.Util.Effect (forMW) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (()) diff --git a/src/swarm-engine/Swarm/Game/CESK.hs b/src/swarm-engine/Swarm/Game/CESK.hs --- a/src/swarm-engine/Swarm/Game/CESK.hs +++ b/src/swarm-engine/Swarm/Game/CESK.hs @@ -92,13 +92,12 @@ import Swarm.Game.Ingredients (Count) import Swarm.Game.Tick import Swarm.Game.World (WorldUpdate (..)) -import Swarm.Language.Context import Swarm.Language.Elaborate (insertSuspend) -import Swarm.Language.Pretty import Swarm.Language.Requirements.Type (Requirements) import Swarm.Language.Syntax import Swarm.Language.Types import Swarm.Language.Value as V +import Swarm.Pretty (PrettyPrec (..), pparens, ppr) import Swarm.Util.JSON (optionsMinimize) ------------------------------------------------------------ @@ -123,6 +122,13 @@ -- application) in environment @e@. We will also push an 'FApp' -- frame on the stack. FArg Term Env + | -- | @FVArg v@ says that we were evaluating the left-hand side of + -- an application, and the next thing we should do is apply it + -- to the given value. This does not normally occur as part of + -- the usual evaluation process for applications, which instead + -- uses FArg. However, it is sometimes useful when reducing + -- other constructs---for example, the pair eliminator 'match'. + FVArg Value | -- | @FApp v@ says that we were evaluating the right-hand side of -- an application; once we are done, we should pass the resulting -- value as an argument to @v@. @@ -164,14 +170,11 @@ | -- | If an exception bubbles all the way up to this frame, then -- switch to Suspended mode with this saved top-level context. FRestoreEnv Env - deriving (Eq, Show, Generic) + deriving (Generic) instance ToJSON Frame where toJSON = genericToJSON optionsMinimize -instance FromJSON Frame where - parseJSON = genericParseJSON optionsMinimize - -- | A continuation is just a stack of frames. type Cont = [Frame] @@ -184,7 +187,7 @@ -- | 'Store' represents a store, /i.e./ memory, indexing integer -- locations to 'Value's. data Store = Store {next :: Addr, mu :: IntMap Value} - deriving (Show, Eq, Generic, FromJSON, ToJSON) + deriving (Generic, ToJSON) emptyStore :: Store emptyStore = Store 0 IM.empty @@ -264,14 +267,11 @@ -- evaluation, and otherwise it is just like 'In' with a hole -- for the 'Term' we are going to evaluate. Suspended Value Env Store Cont - deriving (Eq, Show, Generic) + deriving (Generic) instance ToJSON CESK where toJSON = genericToJSON optionsMinimize -instance FromJSON CESK where - parseJSON = genericParseJSON optionsMinimize - -- | Is the CESK machine in a final (finished) state? If so, extract -- the final value and store. finalValue :: CESK -> Maybe Value @@ -326,9 +326,9 @@ -- | Create a brand new CESK machine, with empty environment and -- store, to evaluate a given term. We always initialize the -- machine with a single FExec frame as the continuation; if the --- given term does not have a command type, we wrap it in @return@. +-- given term does not have a command type, we wrap it in @pure@. initMachine :: TSyntax -> CESK -initMachine t = In (prepareTerm mempty t) mempty emptyStore [FExec] +initMachine t = In (prepareTerm V.emptyEnv t) V.emptyEnv emptyStore [FExec] -- | Load a program into an existing robot CESK machine: either -- continue from a suspended state, or, as a fallback, start from @@ -355,18 +355,18 @@ -- In any other state, just start with an empty environment. This -- happens e.g. when running a program on the base robot for the -- very first time. - cesk -> In (insertSuspend $ prepareTerm mempty t) mempty (cesk ^. store) (FExec : (cesk ^. cont)) + cesk -> In (insertSuspend $ prepareTerm V.emptyEnv t) V.emptyEnv (cesk ^. store) (FExec : (cesk ^. cont)) -- | Prepare a term for evaluation by a CESK machine in the given -- environment: erase all type annotations, and optionally wrap it --- in @return@ if it does not have a command type. Note that since +-- in @pure@ if it does not have a command type. Note that since -- the environment might contain type aliases, we have to be careful -- to expand them before concluding whether the term has a command -- type or not. prepareTerm :: Env -> TSyntax -> Term prepareTerm e t = case whnfType (e ^. envTydefs) (ptBody (t ^. sType)) of TyCmd _ -> t' - _ -> TApp (TConst Return) t' + _ -> TApp (TConst Pure) t' where t' = eraseS t @@ -411,23 +411,24 @@ FSnd t _ -> (11, "(" <> inner <> "," <+> ppr t <> ")") FFst v -> (11, "(" <> ppr (valueToTerm v) <> "," <+> inner <> ")") FArg t _ -> (10, pparens (p < 10) inner <+> prettyPrec 11 t) + FVArg v -> (10, pparens (p < 10) inner <+> prettyPrec 11 (valueToTerm v)) FApp v -> (10, prettyPrec 10 (valueToTerm v) <+> pparens (p < 11) inner) - FLet x _ t _ -> (11, hsep ["let", pretty x, "=", inner, "in", ppr t]) + FLet x _ t _ -> (11, hsep ["let", ppr x, "=", inner, "in", ppr t]) FTry v -> (10, "try" <+> pparens (p < 11) inner <+> prettyPrec 11 (valueToTerm v)) FExec -> prettyPrefix "E·" (p, inner) FBind Nothing _ t _ -> (0, pparens (p < 1) inner <+> ";" <+> ppr t) - FBind (Just x) _ t _ -> (0, hsep [pretty x, "<-", pparens (p < 1) inner, ";", ppr t]) + FBind (Just x) _ t _ -> (0, hsep [ppr x, "<-", pparens (p < 1) inner, ";", ppr t]) FImmediate c _worldUpds _robotUpds -> prettyPrefix ("I[" <> ppr c <> "]·") (p, inner) FUpdate {} -> (p, inner) FFinishAtomic -> prettyPrefix "A·" (p, inner) FRcd _ done foc rest -> (11, encloseSep "[" "]" ", " (pDone ++ [pFoc] ++ pRest)) where - pDone = map (\(x, v) -> pretty x <+> "=" <+> ppr (valueToTerm v)) (reverse done) - pFoc = pretty foc <+> "=" <+> inner + pDone = map (\(x, v) -> ppr x <+> "=" <+> ppr (valueToTerm v)) (reverse done) + pFoc = ppr foc <+> "=" <+> inner pRest = map pprEq rest - pprEq (x, Nothing) = pretty x - pprEq (x, Just t) = pretty x <+> "=" <+> ppr t - FProj x -> (11, pparens (p < 11) inner <> "." <> pretty x) + pprEq (x, Nothing) = ppr x + pprEq (x, Just t) = ppr x <+> "=" <+> ppr t + FProj x -> (11, pparens (p < 11) inner <> "." <> ppr x) FSuspend _ -> (10, "suspend" <+> pparens (p < 11) inner) FRestoreEnv _ -> (10, "restore" <+> pparens (p < 11) inner) diff --git a/src/swarm-engine/Swarm/Game/Exception.hs b/src/swarm-engine/Swarm/Game/Exception.hs --- a/src/swarm-engine/Swarm/Game/Exception.hs +++ b/src/swarm-engine/Swarm/Game/Exception.hs @@ -30,10 +30,10 @@ import Swarm.Game.Entity (EntityMap, devicesForCap, entityName) import Swarm.Language.Capability (Capability (CGod), capabilityName) import Swarm.Language.JSON () -import Swarm.Language.Pretty (prettyText) import Swarm.Language.Requirements.Type (Requirements (..)) import Swarm.Language.Syntax (Const, Term) import Swarm.Log (Severity (..)) +import Swarm.Pretty (prettyText) import Swarm.Util import Witch (from) @@ -129,8 +129,8 @@ -- "obtain device", or "obtain consumables". formatIncapableFix :: IncapableFix -> IncapableFixWords formatIncapableFix = \case - FixByEquip -> IncapableFixWords "equip" "device" - FixByObtainDevice -> IncapableFixWords "obtain" "device" + FixByEquip -> IncapableFixWords "equip" "device(s)" + FixByObtainDevice -> IncapableFixWords "obtain" "device(s)" FixByObtainConsumables -> IncapableFixWords "obtain" "consumables" -- | Pretty print the incapable exception with an actionable suggestion @@ -139,11 +139,11 @@ -- >>> import Data.Either (fromRight) -- >>> import Control.Carrier.Throw.Either (runThrow) -- >>> import Control.Algebra (run) --- >>> import Swarm.Game.Failure (LoadingFailure) +-- >>> import Swarm.Failure (LoadingFailure) -- >>> import qualified Data.Set as S -- >>> :set -XTypeApplications --- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty (S.singleton CAppear) --- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" mempty mempty (S.singleton CAppear) +-- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty (S.singleton $ CExecute Appear) +-- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" mempty mempty (S.singleton $ CExecute Appear) -- >>> m = fromRight mempty . run . runThrow @LoadingFailure $ buildEntityMap [w,r] -- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByEquip cs t -- @@ -152,13 +152,13 @@ -- 'as' -- If God in troth thou wantest to play, try thou a Creative game. -- --- >>> incapableError (R.singletonCap CAppear) (TConst Appear) --- You do not have the device required for: +-- >>> incapableError (R.singletonCap $ CExecute Appear) (TConst Appear) +-- You do not have the device(s) required for: -- 'appear' -- Please equip: -- - magic wand or the one ring -- --- >>> incapableError (R.singletonCap CRandom) (TConst Random) +-- >>> incapableError (R.singletonCap $ CExecute Random) (TConst Random) -- Missing the random capability for: -- 'random' -- but no device yet provides it. See diff --git a/src/swarm-engine/Swarm/Game/Popup.hs b/src/swarm-engine/Swarm/Game/Popup.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Popup.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +module Swarm.Game.Popup ( + -- * Popup types + Popup (..), + + -- * Popup state + PopupState, + currentPopup, + popupQueue, + initPopupState, + addPopup, + nextPopup, +) where + +import Control.Lens (makeLenses, use, (%~), (.=)) +import Control.Monad.State (MonadState) +import Data.Sequence (Seq, (|>), pattern (:<|)) +import Data.Sequence qualified as Seq +import Swarm.Game.Achievement.Definitions (CategorizedAchievement) +import Swarm.Language.Syntax (Const) + +-- | Different types of popups that can be displayed to the +-- player. +data Popup + = AchievementPopup CategorizedAchievement + | RecipesPopup + | CommandsPopup [Const] + | DebugWarningPopup + +-- | State to track pending popup queue as well as any +-- popup which is currently being displayed. +data PopupState = PopupState + { _currentPopup :: Maybe Popup + , _popupQueue :: Seq Popup + } + +makeLenses ''PopupState + +-- | Initial, empty popup state. +initPopupState :: PopupState +initPopupState = + PopupState + { _currentPopup = Nothing + , _popupQueue = Seq.empty + } + +-- | Add a popup to the end of the queue. +addPopup :: Popup -> PopupState -> PopupState +addPopup notif = popupQueue %~ (|> notif) + +-- | Move the next popup (if any) from the queue to the +-- currently displayed popup. +nextPopup :: MonadState PopupState m => m () +nextPopup = do + q <- use popupQueue + case q of + Seq.Empty -> currentPopup .= Nothing + n :<| ns -> do + currentPopup .= Just n + popupQueue .= ns diff --git a/src/swarm-engine/Swarm/Game/Robot/Activity.hs b/src/swarm-engine/Swarm/Game/Robot/Activity.hs --- a/src/swarm-engine/Swarm/Game/Robot/Activity.hs +++ b/src/swarm-engine/Swarm/Game/Robot/Activity.hs @@ -16,7 +16,7 @@ import Control.Lens hiding (Const, contains) import Data.Aeson qualified as Ae (FromJSON (..), ToJSON (..)) -import Data.Map (Map) +import Data.Map.Strict (Map) import GHC.Generics (Generic) import Swarm.Game.Tick import Swarm.Language.Syntax (Const) diff --git a/src/swarm-engine/Swarm/Game/Robot/Concrete.hs b/src/swarm-engine/Swarm/Game/Robot/Concrete.hs --- a/src/swarm-engine/Swarm/Game/Robot/Concrete.hs +++ b/src/swarm-engine/Swarm/Game/Robot/Concrete.hs @@ -141,7 +141,7 @@ Ae.object $ catMaybes [ "id" .== (r ^. robotID) - , "name" .== (r ^. robotEntity . entityDisplay) + , "name" .== (r ^. robotEntity . entityName) , "description" .=? (r ^. robotEntity . entityDescription) $ mempty , "loc" .== (r ^. robotLocation) , "dir" .=? (r ^. robotEntity . entityOrientation) $ zero diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs --- a/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs @@ -144,7 +144,7 @@ getBestGroups = rearrangeTuples . M.toList . bestToMap where - groupByStartTime = NE.groupAllWith $ view scenarioStarted . getMetric . snd + groupByStartTime = NE.groupAllWith $ view scenarioStarted . view metricData . snd rearrangeTuples = map (snd . NE.head &&& NE.map fst) . groupByStartTime bestToMap :: BestRecords -> Map BestByCriteria ProgressMetric @@ -161,4 +161,4 @@ ] ensurePresent x = - (getMetric x ^. scenarioAttemptMetrics . scenarioCodeMetrics) >> Just x + (x ^. metricData . scenarioAttemptMetrics . scenarioCodeMetrics) >> Just x diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs --- a/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs @@ -12,7 +12,7 @@ import Swarm.Language.Syntax data CodeSizeDeterminators = CodeSizeDeterminators - { initialCode :: Maybe TSyntax + { initialCode :: Maybe Syntax , hasUsedREPL :: Bool } deriving (Show) diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs --- a/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs @@ -1,15 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause -- -- Data types and functions applicable across different -- scoring methods. -module Swarm.Game.Scenario.Scoring.GenericMetrics where +module Swarm.Game.Scenario.Scoring.GenericMetrics ( + Progress (..), + Metric (Metric), + metricProgress, + metricData, + chooseBetter, +) where +import Control.Applicative ((<|>)) +import Control.Lens import Data.Aeson +import Data.List.Extra (dropPrefix) import Data.Ord (Down (Down)) import GHC.Generics (Generic) import Swarm.Util (maxOn) -import Swarm.Util.JSON (optionsUntagged) +import Swarm.Util.JSON (optionsMinimize, optionsUntagged) +import Swarm.Util.Lens (makeLensesNoSigs) -- | This is a subset of the "ScenarioStatus" type -- that excludes the "NotStarted" case. @@ -24,11 +36,30 @@ instance ToJSON Progress where toJSON = genericToJSON optionsUntagged -data Metric a = Metric Progress a - deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON) +data Metric a = Metric + { _metricProgress :: Progress + , _metricData :: a + } + deriving (Eq, Ord, Show, Read, Generic) -getMetric :: Metric a -> a -getMetric (Metric _ x) = x +metricSerializeOptions :: Options +metricSerializeOptions = optionsMinimize {fieldLabelModifier = camelTo2 '_' . dropPrefix "_metric"} + +instance FromJSON a => FromJSON (Metric a) where + parseJSON v = + (uncurry Metric <$> parseJSON v) -- parse saves from time when metric did not have named fields + <|> genericParseJSON metricSerializeOptions v + +instance ToJSON a => ToJSON (Metric a) where + toJSON = genericToJSON metricSerializeOptions + +makeLensesNoSigs ''Metric + +-- | The player progress, so that we know if this game was completed. +metricProgress :: Lens' (Metric a) Progress + +-- | Metric data, for example start and end time. +metricData :: Lens' (Metric a) a -- | This encodes the notion of "more play is better" -- for incomplete games (rationale: more play = more fun), diff --git a/src/swarm-engine/Swarm/Game/Scenario/Status.hs b/src/swarm-engine/Swarm/Game/Scenario/Status.hs --- a/src/swarm-engine/Swarm/Game/Scenario/Status.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Status.hs @@ -16,6 +16,7 @@ genericToJSON, ) import Data.Function (on) +import Data.String (IsString (..)) import Data.Time (ZonedTime, diffUTCTime, zonedTimeToUTC) import Data.Yaml as Y import GHC.Generics (Generic) @@ -67,9 +68,6 @@ toEncoding = genericToEncoding scenarioOptions toJSON = genericToJSON scenarioOptions -seedLaunchParams :: Applicative f => Maybe Seed -> ParameterizableLaunchParams a f -seedLaunchParams s = LaunchParams (pure s) (pure Nothing) - emptyLaunchParams :: Applicative f => ParameterizableLaunchParams a f emptyLaunchParams = LaunchParams (pure Nothing) (pure Nothing) @@ -78,32 +76,55 @@ NotStarted -> emptyLaunchParams Played x _ _ -> x +-- | The normalized path to a scenario, amenable to lookup +newtype ScenarioPath = ScenarioPath + { getScenarioPath :: FilePath + } + deriving (Eq, Show) + +instance IsString ScenarioPath where + fromString = ScenarioPath + +data ScenarioWith a = ScenarioWith + { _getScenario :: Scenario + , _getScenarioInfo :: a + } + deriving (Generic, Functor) + +makeLenses ''ScenarioWith + -- | A 'ScenarioInfo' record stores metadata about a scenario: its -- canonical path and status. -- By way of the 'ScenarioStatus' record, it stores the -- most recent status and best-ever status. -data ScenarioInfo = ScenarioInfo - { _scenarioPath :: FilePath +data ScenarioInfoT a = ScenarioInfo + { _scenarioPath :: a , _scenarioStatus :: ScenarioStatus } - deriving (Eq, Ord, Show, Read, Generic) + deriving (Eq, Ord, Show, Read, Generic, Functor) -instance FromJSON ScenarioInfo where +type ScenarioInfo = ScenarioInfoT FilePath + +instance (FromJSON a) => FromJSON (ScenarioInfoT a) where parseJSON = genericParseJSON scenarioOptions -instance ToJSON ScenarioInfo where +instance (ToJSON a) => ToJSON (ScenarioInfoT a) where toEncoding = genericToEncoding scenarioOptions toJSON = genericToJSON scenarioOptions -type ScenarioInfoPair = (Scenario, ScenarioInfo) - -makeLensesNoSigs ''ScenarioInfo +makeLensesNoSigs ''ScenarioInfoT -- | The path of the scenario, relative to @data/scenarios@. scenarioPath :: Lens' ScenarioInfo FilePath -- | The status of the scenario. scenarioStatus :: Lens' ScenarioInfo ScenarioStatus + +-- | Check if a given scenario has been completed. +scenarioIsCompleted :: ScenarioInfo -> Bool +scenarioIsCompleted (ScenarioInfo _ (Played _ _ best)) = + best ^. scenarioBestByTime . metricProgress == Completed +scenarioIsCompleted _ = False -- | Update the current 'ScenarioInfo' record when quitting a game. -- diff --git a/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs b/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs deleted file mode 100644 --- a/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs +++ /dev/null @@ -1,215 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Online operations for structure recognizer. --- --- See "Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute" for --- details of the structure recognition process. -module Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking ( - entityModified, -) where - -import Control.Carrier.State.Lazy -import Control.Effect.Lens -import Control.Lens ((^.)) -import Control.Monad (forM, forM_, guard) -import Data.HashMap.Strict qualified as HM -import Data.HashSet (HashSet) -import Data.HashSet qualified as HS -import Data.Hashable (Hashable) -import Data.Int (Int32) -import Data.List (sortOn) -import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M -import Data.Maybe (listToMaybe) -import Data.Ord (Down (..)) -import Data.Semigroup (Max (..), Min (..)) -import Linear (V2 (..)) -import Swarm.Game.Entity (Entity) -import Swarm.Game.Location (Location) -import Swarm.Game.Scenario (StructureCells) -import Swarm.Game.Scenario.Topography.Structure.Recognition -import Swarm.Game.Scenario.Topography.Structure.Recognition.Log -import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -import Swarm.Game.State -import Swarm.Game.State.Substate -import Swarm.Game.Universe -import Swarm.Game.World.Modify -import Text.AhoCorasick - --- | A hook called from the centralized entity update function, --- 'Swarm.Game.Step.Util.updateEntityAt'. --- --- This handles structure detection upon addition of an entity, --- and structure de-registration upon removal of an entity. --- Also handles atomic entity swaps. -entityModified :: - (Has (State GameState) sig m) => - CellModification Entity -> - Cosmic Location -> - m () -entityModified modification cLoc = do - case modification of - Add newEntity -> doAddition newEntity - Remove _ -> doRemoval - Swap _ newEntity -> doRemoval >> doAddition newEntity - where - doAddition newEntity = do - entLookup <- use $ discovery . structureRecognition . automatons . automatonsByEntity - forM_ (HM.lookup newEntity entLookup) $ \finder -> do - let msg = FoundParticipatingEntity $ ParticipatingEntity newEntity (finder ^. inspectionOffsets) - discovery . structureRecognition . recognitionLog %= (msg :) - registerRowMatches cLoc finder - - doRemoval = do - -- Entity was removed; may need to remove registered structure. - structureRegistry <- use $ discovery . structureRecognition . foundStructures - forM_ (M.lookup cLoc $ foundByLocation structureRegistry) $ \fs -> do - let structureName = getName $ originalDefinition $ structureWithGrid fs - in do - discovery . structureRecognition . recognitionLog %= (StructureRemoved structureName :) - discovery . structureRecognition . foundStructures %= removeStructure fs - --- | In case this cell would match a candidate structure, --- ensures that the entity in this cell is not already --- participating in a registered structure. --- --- Furthermore, treating cells in registered structures --- as 'Nothing' has the effect of "masking" them out, --- so that they can overlap empty cells within the bounding --- box of the candidate structure. --- --- Finally, entities that are not members of any candidate --- structure are also masked out, so that it is OK for them --- to intrude into the candidate structure's bounding box --- where the candidate structure has empty cells. -candidateEntityAt :: - (Has (State GameState) sig m) => - -- | participating entities - HashSet Entity -> - Cosmic Location -> - m (Maybe Entity) -candidateEntityAt participating cLoc = do - registry <- use $ discovery . structureRecognition . foundStructures - if M.member cLoc $ foundByLocation registry - then return Nothing - else do - maybeEnt <- entityAt cLoc - return $ do - ent <- maybeEnt - guard $ HS.member ent participating - return ent - --- | Excludes entities that are already part of a --- registered found structure. -getWorldRow :: - (Has (State GameState) sig m) => - -- | participating entities - HashSet Entity -> - Cosmic Location -> - InspectionOffsets -> - Int32 -> - m [Maybe Entity] -getWorldRow participatingEnts cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) yOffset = - mapM (candidateEntityAt participatingEnts) horizontalOffsets - where - horizontalOffsets = map mkLoc [offsetLeft .. offsetRight] - - -- NOTE: We negate the yOffset because structure rows are numbered increasing from top - -- to bottom, but swarm world coordinates increase from bottom to top. - mkLoc x = cLoc `offsetBy` V2 x (negate yOffset) - --- | This is the first (one-dimensional) stage --- in a two-stage (two-dimensional) search. -registerRowMatches :: - (Has (State GameState) sig m) => - Cosmic Location -> - AutomatonInfo Entity (AtomicKeySymbol Entity) (StructureSearcher StructureCells Entity) -> - m () -registerRowMatches cLoc (AutomatonInfo participatingEnts horizontalOffsets sm) = do - entitiesRow <- getWorldRow participatingEnts cLoc horizontalOffsets 0 - let candidates = findAll sm entitiesRow - mkCandidateLogEntry c = - FoundRowCandidate - (HaystackContext entitiesRow (HaystackPosition $ pIndex c)) - (needleContent $ pVal c) - rowMatchInfo - where - rowMatchInfo = NE.toList . NE.map (f . myRow) . singleRowItems $ pVal c - where - f x = MatchingRowFrom (rowIndex x) $ getName . originalDefinition . wholeStructure $ x - - logEntry = FoundRowCandidates $ map mkCandidateLogEntry candidates - - discovery . structureRecognition . recognitionLog %= (logEntry :) - candidates2D <- forM candidates $ checkVerticalMatch cLoc horizontalOffsets - registerStructureMatches $ concat candidates2D - -checkVerticalMatch :: - (Has (State GameState) sig m) => - Cosmic Location -> - -- | Horizontal search offsets - InspectionOffsets -> - Position (StructureSearcher StructureCells Entity) -> - m [FoundStructure StructureCells Entity] -checkVerticalMatch cLoc (InspectionOffsets (Min searchOffsetLeft) _) foundRow = - getMatches2D cLoc horizontalFoundOffsets $ automaton2D $ pVal foundRow - where - foundLeftOffset = searchOffsetLeft + fromIntegral (pIndex foundRow) - foundRightInclusiveIndex = foundLeftOffset + fromIntegral (pLength foundRow) - 1 - horizontalFoundOffsets = InspectionOffsets (pure foundLeftOffset) (pure foundRightInclusiveIndex) - -getFoundStructures :: - Hashable keySymb => - (Int32, Int32) -> - Cosmic Location -> - StateMachine keySymb (StructureWithGrid StructureCells Entity) -> - [keySymb] -> - [FoundStructure StructureCells Entity] -getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows = - map mkFound candidates - where - candidates = findAll sm entityRows - mkFound candidate = FoundStructure (pVal candidate) $ cLoc `offsetBy` loc - where - -- NOTE: We negate the yOffset because structure rows are numbered increasing from top - -- to bottom, but swarm world coordinates increase from bottom to top. - loc = V2 offsetLeft $ negate $ offsetTop + fromIntegral (pIndex candidate) - -getMatches2D :: - (Has (State GameState) sig m) => - Cosmic Location -> - -- | Horizontal found offsets (inclusive indices) - InspectionOffsets -> - AutomatonInfo Entity (SymbolSequence Entity) (StructureWithGrid StructureCells Entity) -> - m [FoundStructure StructureCells Entity] -getMatches2D - cLoc - horizontalFoundOffsets@(InspectionOffsets (Min offsetLeft) _) - (AutomatonInfo participatingEnts (InspectionOffsets (Min offsetTop) (Max offsetBottom)) sm) = do - entityRows <- mapM getRow verticalOffsets - return $ getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows - where - getRow = getWorldRow participatingEnts cLoc horizontalFoundOffsets - verticalOffsets = [offsetTop .. offsetBottom] - --- | --- We only allow an entity to participate in one structure at a time, --- so multiple matches require a tie-breaker. --- The largest structure (by area) shall win. -registerStructureMatches :: - (Has (State GameState) sig m) => - [FoundStructure StructureCells Entity] -> - m () -registerStructureMatches unrankedCandidates = do - discovery . structureRecognition . recognitionLog %= (newMsg :) - - forM_ (listToMaybe rankedCandidates) $ \fs -> - discovery . structureRecognition . foundStructures %= addFound fs - where - -- Sorted by decreasing order of preference. - rankedCandidates = sortOn Down unrankedCandidates - - getStructName (FoundStructure swg _) = getName $ originalDefinition swg - newMsg = FoundCompleteStructureCandidates $ map getStructName rankedCandidates diff --git a/src/swarm-engine/Swarm/Game/ScenarioInfo.hs b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs --- a/src/swarm-engine/Swarm/Game/ScenarioInfo.hs +++ b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -9,11 +11,11 @@ -- * Scenario info ScenarioStatus (..), _NotStarted, - ScenarioInfo (..), + ScenarioInfo, scenarioPath, scenarioStatus, CodeSizeDeterminators (CodeSizeDeterminators), - ScenarioInfoPair, + ScenarioWith, -- * Scenario collection ScenarioCollection (..), @@ -24,6 +26,7 @@ ScenarioItem (..), scenarioItemName, _SISingle, + pathifyCollection, -- ** Tutorials tutorialsDirname, @@ -42,7 +45,7 @@ import Control.Effect.Lift (Lift, sendIO) import Control.Effect.Throw (Throw, liftEither) import Control.Lens hiding (from, (<.>)) -import Control.Monad (filterM, forM_, when, (<=<)) +import Control.Monad (filterM, forM_, void, when, (<=<)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Char (isSpace) import Data.Either (partitionEithers) @@ -51,33 +54,69 @@ import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M +import Data.Map.Ordered (OMap) +import Data.Map.Ordered qualified as OM import Data.Maybe (isJust) import Data.Sequence (Seq) import Data.Sequence qualified as Seq import Data.Text (Text) import Data.Yaml as Y -import Swarm.Game.Failure -import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath) +import Swarm.Failure import Swarm.Game.Scenario import Swarm.Game.Scenario.Scoring.CodeSize import Swarm.Game.Scenario.Status +import Swarm.ResourceLoading (getDataDirSafe, getSwarmSavePath) +import Swarm.Util (lookupEither) import Swarm.Util.Effect (warn, withThrow) import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), ()) +import System.IO (readFile') +import System.IO.Error (catchIOError) import Witch (into) +------------------------------------------------------------ + +-- * Utilities + +-- | Given an ordered list of keys and a map, return a partition consisting of: +-- * Left: the keys that were not present +-- * Right: the retrievable key-value pairs in corresponding order to the provided keys +lookupInOrder :: Ord k => Map k v -> [k] -> ([k], [(k, v)]) +lookupInOrder m = partitionEithers . map produceKeyValuePair + where + produceKeyValuePair k = sequenceA (k, lookupEither k m) + +-- ** Ordered Map utilities + +type instance Index (OMap k a) = k +type instance IxValue (OMap k a) = a + +-- | Adapted from: +-- https://hackage.haskell.org/package/lens-5.3.4/docs/src/Control.Lens.At.html#line-319 +instance Ord k => Ixed (OMap k a) where + ix k f m = case OM.lookup k m of + Just v -> f v <&> \v' -> OM.alter (const $ Just v') k m + Nothing -> pure m + +-- | Strangely, an 'elems' function is missing from the 'OMap' API. +orderedElems :: OMap k a -> [a] +orderedElems = map snd . OM.assocs + +fromMapOM :: Ord k => Map k a -> OMap k a +fromMapOM = OM.fromList . M.toList + -- ---------------------------------------------------------------------------- -- Scenario Item -- ---------------------------------------------------------------------------- -- | A scenario item is either a specific scenario, or a collection of -- scenarios (/e.g./ the scenarios contained in a subdirectory). -data ScenarioItem = SISingle ScenarioInfoPair | SICollection Text ScenarioCollection - deriving (Show) +data ScenarioItem a = SISingle (ScenarioWith a) | SICollection Text (ScenarioCollection a) + deriving (Functor) -- | Retrieve the name of a scenario item. -scenarioItemName :: ScenarioItem -> Text -scenarioItemName (SISingle (s, _ss)) = s ^. scenarioMetadata . scenarioName +scenarioItemName :: ScenarioItem a -> Text +scenarioItemName (SISingle (ScenarioWith s _ss)) = s ^. scenarioMetadata . scenarioName scenarioItemName (SICollection name _) = name -- | A scenario collection is a tree of scenarios, keyed by name, @@ -85,21 +124,23 @@ -- -- /Invariant:/ every item in the -- 'scOrder' exists as a key in the 'scMap'. -data ScenarioCollection = SC - { scOrder :: Maybe [FilePath] - , scMap :: Map FilePath ScenarioItem +newtype ScenarioCollection a = SC + { scMap :: OMap FilePath (ScenarioItem a) } - deriving (Show) + deriving (Functor) +pathifyCollection :: Functor f => f ScenarioInfo -> f ScenarioPath +pathifyCollection = fmap (ScenarioPath . view scenarioPath) + -- | Access and modify 'ScenarioItem's in collection based on their path. -scenarioItemByPath :: FilePath -> Traversal' ScenarioCollection ScenarioItem +scenarioItemByPath :: FilePath -> Traversal' (ScenarioCollection a) (ScenarioItem a) scenarioItemByPath path = ixp ps where ps = splitDirectories path - ixp :: (Applicative f) => [String] -> (ScenarioItem -> f ScenarioItem) -> ScenarioCollection -> f ScenarioCollection + ixp :: (Applicative f) => [String] -> (ScenarioItem a -> f (ScenarioItem a)) -> ScenarioCollection a -> f (ScenarioCollection a) ixp [] _ col = pure col - ixp [s] f (SC n m) = SC n <$> ix s f m - ixp (d : xs) f (SC n m) = SC n <$> ix d inner m + ixp [s] f (SC m) = SC <$> ix s f m + ixp (d : xs) f (SC m) = SC <$> ix d inner m where inner si = case si of SISingle {} -> pure si @@ -111,15 +152,15 @@ -- | Extract just the collection of tutorial scenarios from the entire -- scenario collection. -getTutorials :: ScenarioCollection -> ScenarioCollection -getTutorials sc = case M.lookup tutorialsDirname (scMap sc) of +getTutorials :: ScenarioCollection a -> ScenarioCollection a +getTutorials sc = case OM.lookup tutorialsDirname (scMap sc) of Just (SICollection _ c) -> c - _ -> error $ "No tutorials exist: " ++ show sc + _ -> SC OM.empty -- | Canonicalize a scenario path, making it usable as a unique key. normalizeScenarioPath :: (MonadIO m) => - ScenarioCollection -> + ScenarioCollection a -> FilePath -> m FilePath normalizeScenarioPath col p = @@ -128,19 +169,18 @@ then return path else liftIO $ do canonPath <- canonicalizePath path - eitherDdir <- runM . runThrow @SystemFailure $ getDataDirSafe Scenarios "." -- no way we got this far without data directory - d <- canonicalizePath $ fromRight' eitherDdir + eitherDataDir <- runM . runThrow @SystemFailure $ getDataDirSafe Scenarios "." -- no way we got this far without data directory + d <- canonicalizePath $ fromRight' eitherDataDir let n = stripPrefix (d "scenarios") canonPath & maybe canonPath (dropWhile (== pathSeparator)) return n -- | Convert a scenario collection to a list of scenario items. -scenarioCollectionToList :: ScenarioCollection -> [ScenarioItem] -scenarioCollectionToList (SC Nothing m) = M.elems m -scenarioCollectionToList (SC (Just order) m) = (m M.!) <$> order +scenarioCollectionToList :: ScenarioCollection a -> [ScenarioItem a] +scenarioCollectionToList (SC xs) = orderedElems xs -flatten :: ScenarioItem -> [ScenarioInfoPair] +flatten :: ScenarioItem a -> [ScenarioWith a] flatten (SISingle p) = [p] flatten (SICollection _ c) = concatMap flatten $ scenarioCollectionToList c @@ -148,85 +188,91 @@ loadScenarios :: (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => ScenarioInputs -> - m ScenarioCollection -loadScenarios scenarioInputs = do + Bool -> + m (ScenarioCollection ScenarioInfo) +loadScenarios scenarioInputs loadTestScenarios = do res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios" case res of Left err -> do warn err - return $ SC mempty mempty - Right dataDir -> loadScenarioDir scenarioInputs dataDir + return $ SC OM.empty + Right dataDir -> loadScenarioDir scenarioInputs loadTestScenarios dataDir -- | The name of the special file which indicates the order of -- scenarios in a folder. orderFileName :: FilePath orderFileName = "00-ORDER.txt" -readOrderFile :: (Has (Lift IO) sig m) => FilePath -> m [String] -readOrderFile orderFile = - filter (not . null) . lines <$> sendIO (readFile orderFile) +testingDirectory :: FilePath +testingDirectory = "Testing" --- | Recursively load all scenarios from a particular directory, and also load --- the 00-ORDER file (if any) giving the order for the scenarios. +readOrderFile :: FilePath -> IO (Maybe [String]) +readOrderFile orderFile = fmap nonEmptyLines <$> readFileMaybe orderFile + where + nonEmptyLines :: String -> [String] + nonEmptyLines = filter (not . null) . lines + readFileMaybe :: FilePath -> IO (Maybe String) + readFileMaybe path = (Just <$> readFile' path) `catchIOError` (\_ -> return Nothing) + loadScenarioDir :: + forall m sig. (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => ScenarioInputs -> + Bool -> FilePath -> - m ScenarioCollection -loadScenarioDir scenarioInputs dir = do - let orderFile = dir orderFileName - dirName = takeBaseName dir - orderExists <- sendIO $ doesFileExist orderFile - morder <- case orderExists of - False -> do - when (dirName /= "Testing") . warn $ - OrderFileWarning (dirName orderFileName) NoOrderFile - return Nothing - True -> Just <$> readOrderFile orderFile - itemPaths <- sendIO $ keepYamlOrPublicDirectory dir =<< listDirectory dir - - case morder of - Just order -> do - let missing = itemPaths \\ order - dangling = order \\ itemPaths - - forM_ (NE.nonEmpty missing) $ - warn - . OrderFileWarning (dirName orderFileName) - . MissingFiles + m (ScenarioCollection ScenarioInfo) +loadScenarioDir scenarioInputs loadTestScenarios dir = do + itemPaths <- sendIO $ filterM (isYamlOrPublicDirectory dir) =<< listDirectory dir + scenarioMap <- loadItems itemPaths + sendIO (readOrderFile orderFile) >>= \case + Nothing -> loadUnorderedScenarioDir scenarioMap + Just order -> loadOrderedScenarioDir order scenarioMap + where + dirName, orderFile, orderFileShortPath :: FilePath + dirName = takeBaseName dir + orderFile = dir orderFileName + orderFileShortPath = dirName orderFileName - forM_ (NE.nonEmpty dangling) $ - warn - . OrderFileWarning (dirName orderFileName) - . DanglingFiles - Nothing -> pure () + -- The function for individual directory items either warns about SystemFailure, + -- or has thrown SystemFailure. The following code just adds that thrown failure to others. + loadItems :: [FilePath] -> m (Map FilePath (ScenarioItem ScenarioInfo)) + loadItems items = do + let loadItem f = runThrow @SystemFailure $ (f,) <$> loadScenarioItem scenarioInputs loadTestScenarios (dir f) + (scenarioFailures, okScenarios) <- partitionEithers <$> mapM loadItem items + add (Seq.fromList scenarioFailures) + return $ M.fromList okScenarios - -- Only keep the files from 00-ORDER.txt that actually exist. - let morder' = filter (`elem` itemPaths) <$> morder - loadItem filepath = do - item <- loadScenarioItem scenarioInputs (dir filepath) - return (filepath, item) - scenarios <- mapM (runThrow @SystemFailure . loadItem) itemPaths - let (failures, successes) = partitionEithers scenarios - scenarioMap = M.fromList successes - -- Now only keep the files that successfully parsed. - morder'' = filter (`M.member` scenarioMap) <$> morder' - collection = SC morder'' scenarioMap - add (Seq.fromList failures) -- Register failed individual scenarios as warnings - return collection - where - -- Keep only files which are .yaml files or directories that start - -- with something other than an underscore. - keepYamlOrPublicDirectory = filterM . isCatalogEntry + isHiddenDir :: String -> Bool + isHiddenDir f = not loadTestScenarios && f == testingDirectory - -- Whether the directory or file should be included in the scenario catalog. - isCatalogEntry d f = do + -- Keep only files which are .yaml files or directories not starting with an underscore. + -- Marked directories contain scenarios that can't be parsed (failure tests) or only script solutions. + isYamlOrPublicDirectory :: FilePath -> String -> IO Bool + isYamlOrPublicDirectory d f = do isDir <- doesDirectoryExist $ d f return $ if isDir - then not $ "_" `isPrefixOf` f + then not ("_" `isPrefixOf` f || isHiddenDir f) else takeExtensions f == ".yaml" + -- warn that the ORDER file is missing + loadUnorderedScenarioDir :: Map FilePath (ScenarioItem a) -> m (ScenarioCollection a) + loadUnorderedScenarioDir scenarioMap = do + when (dirName /= testingDirectory) (warn $ OrderFileWarning orderFileShortPath NoOrderFile) + pure . SC $ fromMapOM scenarioMap + + -- warn if the ORDER file does not match directory contents + loadOrderedScenarioDir :: [String] -> Map FilePath (ScenarioItem a) -> m (ScenarioCollection a) + loadOrderedScenarioDir order scenarioMap = do + let missing = M.keys scenarioMap \\ order + (notPresent, loaded) = lookupInOrder scenarioMap order + dangling = filter (not . isHiddenDir) notPresent + + forM_ (NE.nonEmpty missing) (warn . OrderFileWarning orderFileShortPath . MissingFiles) + forM_ (NE.nonEmpty dangling) (warn . OrderFileWarning orderFileShortPath . DanglingFiles) + + pure $ SC $ OM.fromList loaded + -- | How to transform scenario path to save path. scenarioPathToSavePath :: FilePath -> FilePath -> FilePath scenarioPathToSavePath path swarmData = swarmData Data.List.intercalate "_" (splitDirectories path) @@ -237,17 +283,21 @@ FilePath -> m ScenarioInfo loadScenarioInfo p = do - path <- sendIO $ normalizeScenarioPath (SC Nothing mempty) p + path <- sendIO $ normalizeScenarioPath (SC OM.empty) p infoPath <- sendIO $ scenarioPathToSavePath path <$> getSwarmSavePath False hasInfo <- sendIO $ doesFileExist infoPath if not hasInfo then do return $ ScenarioInfo path NotStarted - else - withThrow (AssetNotLoaded (Data Scenarios) infoPath . CanNotParseYaml) - . (liftEither <=< sendIO) - $ decodeFileEither infoPath + else do + si <- + withThrow (AssetNotLoaded (Data Scenarios) infoPath . CanNotParseYaml) + . (liftEither <=< sendIO) + $ decodeFileEither infoPath + -- We overwrite the (void) path that was saved inside the yaml file, so that there + -- is only a single authoritative path "key": the original scenario path. + return $ path <$ (si :: ScenarioInfoT ()) -- | Save info about played scenario to XDG data directory. saveScenarioInfo :: @@ -256,7 +306,8 @@ IO () saveScenarioInfo path si = do infoPath <- scenarioPathToSavePath path <$> getSwarmSavePath True - encodeFile infoPath si + -- We do not store the path in the save file (see #2390). + encodeFile infoPath $ void si -- | Load a scenario item (either a scenario, or a subdirectory -- containing a collection of scenarios) from a particular path. @@ -266,21 +317,22 @@ , Has (Lift IO) sig m ) => ScenarioInputs -> + Bool -> FilePath -> - m ScenarioItem -loadScenarioItem scenarioInputs path = do + m (ScenarioItem ScenarioInfo) +loadScenarioItem scenarioInputs loadTestScenarios path = do isDir <- sendIO $ doesDirectoryExist path let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path case isDir of - True -> SICollection collectionName <$> loadScenarioDir scenarioInputs path + True -> SICollection collectionName <$> loadScenarioDir scenarioInputs loadTestScenarios path False -> do s <- loadScenarioFile scenarioInputs path eitherSi <- runThrow @SystemFailure (loadScenarioInfo path) case eitherSi of - Right si -> return $ SISingle (s, si) + Right si -> return $ SISingle $ ScenarioWith s si Left warning -> do warn warning - return $ SISingle (s, ScenarioInfo path NotStarted) + return . SISingle . ScenarioWith s $ ScenarioInfo path NotStarted ------------------------------------------------------------ -- Some lenses + prisms diff --git a/src/swarm-engine/Swarm/Game/State.hs b/src/swarm-engine/Swarm/Game/State.hs --- a/src/swarm-engine/Swarm/Game/State.hs +++ b/src/swarm-engine/Swarm/Game/State.hs @@ -15,6 +15,7 @@ creativeMode, winCondition, winSolution, + completionStatsSaved, -- ** Launch parameters LaunchParams, @@ -35,6 +36,8 @@ -- ** GameState initialization initGameState, CodeToRun (..), + toRunSource, + toRunSyntax, Sha1 (..), SolutionSource (..), parseCodeFile, @@ -64,6 +67,7 @@ genMultiWorld, genRobotTemplates, entityAt, + mtlEntityAt, contentAt, zoomWorld, zoomRobots, @@ -76,6 +80,7 @@ import Control.Effect.Throw import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) import Control.Monad (forM, join) +import Control.Monad.Trans.State.Strict qualified as TS import Data.Aeson (ToJSON) import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Foldable (toList) @@ -85,6 +90,7 @@ import Data.IntSet qualified as IS import Data.Map qualified as M import Data.Maybe (fromMaybe, mapMaybe) +import Data.MonoidMap qualified as MM import Data.Sequence (Seq ((:<|))) import Data.Sequence qualified as Seq import Data.Text (Text) @@ -92,15 +98,17 @@ import Data.Text.IO qualified as TIO import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL +import Data.Tuple (swap) import GHC.Generics (Generic) +import Swarm.Failure (SystemFailure (..)) import Swarm.Game.CESK (Store, emptyStore, store, suspendedEnv) import Swarm.Game.Entity -import Swarm.Game.Failure (SystemFailure (..)) import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Robot import Swarm.Game.Robot.Concrete import Swarm.Game.Scenario.Status +import Swarm.Game.State.Config import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Substate @@ -114,7 +122,7 @@ import Swarm.Language.Syntax (SrcLoc (..), TSyntax, sLoc) import Swarm.Language.Value (Env) import Swarm.Log -import Swarm.Util (uniq) +import Swarm.Util (applyWhen, uniq) import Swarm.Util.Lens (makeLensesNoSigs) newtype Sha1 = Sha1 String @@ -127,8 +135,13 @@ -- on a leaderboard. PlayerAuthored FilePath Sha1 -data CodeToRun = CodeToRun SolutionSource TSyntax +data CodeToRun = CodeToRun + { _toRunSource :: SolutionSource + , _toRunSyntax :: TSyntax + } +makeLenses ''CodeToRun + getRunCodePath :: CodeToRun -> Maybe FilePath getRunCodePath (CodeToRun solutionSource _) = case solutionSource of ScenarioSuggested -> Nothing @@ -159,6 +172,22 @@ -- | The main record holding the state for the game itself (as -- distinct from the UI). See the lenses below for access to its -- fields. +-- +-- To answer the question of what belongs in the `GameState` and +-- what belongs in the `UIState`, ask yourself the question: is this +-- something specific to a particular UI, or is it something +-- inherent to the game which would be needed even if we put a +-- different UI on top (web-based, GUI-based, etc.)? For example, +-- tracking whether the game is paused needs to be in the +-- `GameState`: especially if we want to have the game running in +-- one thread and the UI running in another thread, then the game +-- itself needs to keep track of whether it is currently paused, so +-- that it can know whether to step independently of the UI telling +-- it so. For example, the game may run for several ticks during a +-- single frame, but if an objective is completed during one of +-- those ticks, the game needs to immediately auto-pause without +-- waiting for the UI to tell it that it should do so, which could +-- come several ticks late. data GameState = GameState { _creativeMode :: Bool , _temporal :: TemporalState @@ -169,11 +198,12 @@ , _discovery :: Discovery , _randomness :: Randomness , _recipesInfo :: Recipes - , _currentScenarioPath :: Maybe FilePath + , _currentScenarioPath :: Maybe ScenarioPath , _landscape :: Landscape , _needsRedraw :: Bool , _gameControls :: GameControls , _messageInfo :: Messages + , _completionStatsSaved :: Bool } makeLensesNoSigs ''GameState @@ -199,9 +229,9 @@ robotsAtLocation :: Cosmic Location -> GameState -> [Robot] robotsAtLocation loc gs = mapMaybe (`IM.lookup` (gs ^. robotInfo . robotMap)) - . maybe [] IS.toList - . M.lookup (loc ^. planar) - . M.findWithDefault mempty (loc ^. subworld) + . IS.toList + . MM.get (loc ^. planar) + . MM.get (loc ^. subworld) . view (robotInfo . robotsByLocation) $ gs @@ -211,14 +241,15 @@ -- | Get all the robots within a given Manhattan distance from a -- location. robotsInArea :: Cosmic Location -> Int32 -> Robots -> [Robot] -robotsInArea (Cosmic subworldName o) d rs = map (rm IM.!) rids +robotsInArea (Cosmic subworldName o) d rs = mapMaybe (rm IM.!?) rids where rm = rs ^. robotMap rl = rs ^. robotsByLocation rids = - concatMap IS.elems $ - getElemsInArea o d $ - M.findWithDefault mempty subworldName rl + concatMap IS.elems + . getElemsInArea o d + . MM.toMap + $ MM.get subworldName rl -- | The base robot, if it exists. baseRobot :: Traversal' GameState Robot @@ -247,7 +278,16 @@ -- -- This is useful as an index to the scenarios collection, -- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'. -currentScenarioPath :: Lens' GameState (Maybe FilePath) +-- +-- Note that it is possible for this to be missing even +-- with an active game state, since the game state can +-- be initialized from sources other than a scenario +-- file on disk. +-- +-- We keep a reference to the possible path within the GameState, +-- however, so that the achievement/progress saving functions +-- do not require access to anything outside GameState. +currentScenarioPath :: Lens' GameState (Maybe ScenarioPath) -- | Info about the lay of the land landscape :: Lens' GameState Landscape @@ -264,6 +304,17 @@ -- | Message info messageInfo :: Lens' GameState Messages +-- | Whether statistics for the current scenario have been saved to +-- disk *upon scenario completion*. (It should remain False whenever +-- the current scenario has not been completed, either because there +-- is no win condition or because the player has not yet achieved +-- it.) If this is set to True, we should not update completion +-- statistics any more. We need this to make sure we don't +-- overwrite statistics if the user continues playing the scenario +-- after completing it (or even if the user stays in the completion +-- menu for a while before quitting; see #1932). +completionStatsSaved :: Lens' GameState Bool + ------------------------------------------------------------ -- Utilities ------------------------------------------------------------ @@ -283,7 +334,7 @@ new = takeWhile (\l -> l ^. leTime > gs ^. messageInfo . lastSeenMessageTime) $ reverse allUniq -- creative players and system robots just see all messages (and focused robots logs) unchecked = gs ^. creativeMode || fromMaybe False (focusedRobot gs ^? _Just . systemRobot) - messages = (if unchecked then id else focusedOrLatestClose) (gs ^. messageInfo . messageQueue) + messages = applyWhen (not unchecked) focusedOrLatestClose (gs ^. messageInfo . messageQueue) allMessages = Seq.sort $ focusedLogs <> messages focusedLogs = maybe Empty (view robotLog) (focusedRobot gs) -- classic players only get to see messages that they said and a one message that they just heard @@ -321,7 +372,7 @@ recalcViewCenterAndRedraw g = g & robotInfo .~ newRobotInfo - & (if ((/=) `on` (^. viewCenter)) oldRobotInfo newRobotInfo then needsRedraw .~ True else id) + & applyWhen (((/=) `on` (^. viewCenter)) oldRobotInfo newRobotInfo) (needsRedraw .~ True) where oldRobotInfo = g ^. robotInfo newRobotInfo = recalcViewCenter oldRobotInfo @@ -450,7 +501,9 @@ initGameState gsc = GameState { _creativeMode = False - , _temporal = initTemporalState + , _temporal = + initTemporalState (startPaused gsc) + & pauseOnObjective .~ (if pauseOnObjectiveCompletion gsc then PauseOnAnyObjective else PauseOnWin) , _winCondition = NoWinCondition , _winSolution = Nothing , _robotInfo = initRobots gsc @@ -463,7 +516,17 @@ , _needsRedraw = False , _gameControls = initGameControls , _messageInfo = initMessages + , _completionStatsSaved = False } + +-- | Provide an entity accessor via the MTL transformer State API. +-- This is useful for the structure recognizer. +mtlEntityAt :: Cosmic Location -> TS.State GameState (Maybe Entity) +mtlEntityAt = TS.state . runGetEntity + where + runGetEntity :: Cosmic Location -> GameState -> (Maybe Entity, GameState) + runGetEntity loc gs = + swap . run . Fused.runState gs $ entityAt loc -- | Get the entity (if any) at a given location. entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity) diff --git a/src/swarm-engine/Swarm/Game/State/Initialize.hs b/src/swarm-engine/Swarm/Game/State/Initialize.hs --- a/src/swarm-engine/Swarm/Game/State/Initialize.hs +++ b/src/swarm-engine/Swarm/Game/State/Initialize.hs @@ -1,3 +1,4 @@ +-- | -- SPDX-License-Identifier: BSD-3-Clause -- Description: Game-related state and utilities -- @@ -11,10 +12,8 @@ import Control.Arrow (Arrow ((&&&))) import Control.Carrier.State.Lazy qualified as Fused import Control.Effect.Lens (view) -import Control.Effect.Lift (Has) -import Control.Effect.State (State) -import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) -import Data.Foldable.Extra (allM) +import Control.Lens hiding (view) +import Data.Hashable (Hashable) import Data.IntMap qualified as IM import Data.List (partition) import Data.List.NonEmpty (NonEmpty) @@ -24,7 +23,7 @@ import Data.Maybe (isNothing) import Data.Set qualified as S import Data.Text (Text) -import Linear (V2 (..)) +import Data.Tuple.Extra (dupe) import Swarm.Game.CESK (finalValue, initMachine) import Swarm.Game.Device (getCapabilitySet, getMap) import Swarm.Game.Entity @@ -34,6 +33,7 @@ inRecipeMap, outRecipeMap, ) +import Swarm.Game.Recipe.Graph qualified as RG import Swarm.Game.Robot import Swarm.Game.Robot.Concrete import Swarm.Game.Scenario @@ -42,52 +42,59 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition import Swarm.Game.Scenario.Topography.Structure.Recognition.Log import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (emptyFoundStructures) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.State import Swarm.Game.State.Landscape (mkLandscape) import Swarm.Game.State.Robot (setRobotInfo) import Swarm.Game.State.Substate -import Swarm.Game.Universe as U (offsetBy) +import Swarm.Game.Step.Util (adaptGameState) import Swarm.Game.World.Gen (Seed) import Swarm.Language.Capability (constCaps) -import Swarm.Language.Syntax (allConst) +import Swarm.Language.Syntax (allConst, erase) import Swarm.Language.Types -import Swarm.Util (binTuples, (?)) +import Swarm.Util (applyWhen, binTuples, (?)) import System.Clock qualified as Clock import System.Random (mkStdGen) -- | Create an initial game state corresponding to the given scenario. scenarioToGameState :: - Scenario -> + ScenarioWith (Maybe ScenarioPath) -> ValidatedLaunchParams -> GameStateConfig -> IO GameState -scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) gsc = do +scenarioToGameState si@(ScenarioWith scenario _) (LaunchParams (Identity userSeed) (Identity toRun)) gsc = do theSeed <- arbitrateSeed userSeed $ scenario ^. scenarioLandscape now <- Clock.getTime Clock.Monotonic - return $ pureScenarioToGameState scenario theSeed now toRun gsc + return $ pureScenarioToGameState si theSeed now toRun gsc pureScenarioToGameState :: - Scenario -> + ScenarioWith (Maybe ScenarioPath) -> Seed -> Clock.TimeSpec -> Maybe CodeToRun -> GameStateConfig -> GameState -pureScenarioToGameState scenario theSeed now toRun gsc = +pureScenarioToGameState (ScenarioWith scenario fp) theSeed now toRun gsc = preliminaryGameState - & discovery . structureRecognition .~ recognizer + & discovery . structureRecognition .~ recognition where sLandscape = scenario ^. scenarioLandscape - recognizer = - runIdentity $ - Fused.evalState preliminaryGameState $ - mkRecognizer (sLandscape ^. scenarioStructures) + -- It may be possible at some point for the game seed to affect whether + -- initially-placed structures remain intact, by way of random placements. + -- Therefore we run this at 'GameState' initialization time, rather than + -- 'Scenario' parse time. + recognition = + runIdentity + . Fused.evalState preliminaryGameState + . adaptGameState + $ initializeRecognition mtlEntityAt (sLandscape ^. scenarioStructures) gs = initGameState gsc preliminaryGameState = gs + & currentScenarioPath .~ fp & robotInfo %~ setRobotInfo baseID robotList' & creativeMode .~ scenario ^. scenarioOperation . scenarioCreative & winCondition .~ theWinCondition @@ -95,11 +102,12 @@ & discovery . availableCommands .~ Notifications 0 False initialCommands & discovery . knownEntities .~ sLandscape ^. scenarioKnown & discovery . tagMembers .~ buildTagMap em + & discovery . craftableDevices .~ craftable & randomness . seed .~ theSeed & randomness . randGen .~ mkStdGen theSeed & recipesInfo %~ modifyRecipesInfo & landscape .~ mkLandscape sLandscape worldTuples theSeed - & gameControls . initiallyRunCode .~ initialCodeToRun + & gameControls . initiallyRunCode .~ (erase <$> initialCodeToRun) & gameControls . replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working, -- otherwise the store of definition cells is not saved (see #333, #838) False -> REPLDone Nothing @@ -108,6 +116,15 @@ robotList' = (robotCreatedAt .~ now) <$> robotList + -- Get the names of all devices (i.e. entities that provide at least + -- one capability) which can be recursively crafted from the + -- starting inventory + entities available in the world + craftable = S.map (view entityName) . S.filter isDevice $ S.unions (RG.levels recipeGraph) + where + recipeGraph = RG.scenarioRecipeGraph scenario (initState gsc) + isDevice :: Entity -> Bool + isDevice = not . M.null . getMap . view entityCapabilities + modifyRecipesInfo oldRecipesInfo = oldRecipesInfo & recipesOut %~ addRecipesWith outRecipeMap @@ -118,11 +135,9 @@ baseID = 0 (things, devices) = partition (M.null . getMap . view entityCapabilities) (M.elems (entitiesByName em)) - getCodeToRun (CodeToRun _ s) = s - robotsByBasePrecedence = genRobotTemplates sLandscape worldTuples - initialCodeToRun = getCodeToRun <$> toRun + initialCodeToRun = view toRunSyntax <$> toRun robotListRaw = zipWith (instantiateRobot Nothing) [baseID ..] robotsByBasePrecedence @@ -142,14 +157,14 @@ -- If we are in creative mode, give base all the things & ix baseID . robotInventory - %~ case scenario ^. scenarioOperation . scenarioCreative of - False -> id - True -> union (fromElems (map (0,) things)) + %~ applyWhen + (scenario ^. scenarioOperation . scenarioCreative) + (union (fromElems (map (0,) things))) & ix baseID . equippedDevices - %~ case scenario ^. scenarioOperation . scenarioCreative of - False -> id - True -> const (fromList devices) + %~ applyWhen + (scenario ^. scenarioOperation . scenarioCreative) + (const (fromList devices)) running = case robotList of [] -> False @@ -177,43 +192,34 @@ addRecipesWith f = IM.unionWith (<>) (f $ scenario ^. scenarioOperation . scenarioRecipes) -mkRecognizer :: - (Has (State GameState) sig m) => - StaticStructureInfo -> - m (StructureRecognizer StructureCells Entity) -mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do - foundIntact <- mapM (sequenceA . (id &&& ensureStructureIntact)) allPlaced - let fs = populateStaticFoundStructures . map fst . filter snd $ foundIntact +-- | +-- As part of initializing the recognizer, we also pre-populate the +-- list of "found" structures with those statically placed by the scenario definition. +-- Note that this bypasses the regular "online" recognition machinery; +-- we don't actually have to "search" for these structures since we are +-- explicitly given their location; we only need to validate that each +-- structure remains intact given other, potentially overlapping static placements. +initializeRecognition :: + (Monad s, Hashable a, Eq b) => + GenericEntLocator s a -> + StaticStructureInfo b a -> + s (RecognitionState b a) +initializeRecognition entLoader structInfo = do + foundIntact <- mapM checkIntactness allPlaced + + let fs = populateStaticFoundStructures . map fst . filter (null . snd) $ foundIntact return $ - StructureRecognizer - (mkAutomatons structDefs) + RecognitionState fs [IntactStaticPlacement $ map mkLogEntry foundIntact] where + checkIntactness = traverse (ensureStructureIntact emptyFoundStructures entLoader) . dupe + allPlaced = lookupStaticPlacements structInfo mkLogEntry (x, intact) = IntactPlacementLog intact - ((getName . originalDefinition . structureWithGrid) x) - (upperLeftCorner x) - --- | Matches definitions against the placements. --- Fails fast (short-circuits) if a non-matching --- cell is encountered. -ensureStructureIntact :: - (Has (State GameState) sig m) => - FoundStructure StructureCells Entity -> - m Bool -ensureStructureIntact (FoundStructure (StructureWithGrid _ _ grid) upperLeft) = - allM outer $ zip [0 ..] grid - where - outer (y, row) = allM (inner y) $ zip [0 ..] row - inner y (x, maybeTemplateEntity) = case maybeTemplateEntity of - Nothing -> return True - Just _ -> - fmap (== maybeTemplateEntity) $ - entityAt $ - upperLeft `offsetBy` V2 x (negate y) + $ PositionedStructure (upperLeftCorner x) ((distillLabel . structureWithGrid) x) buildTagMap :: EntityMap -> Map Text (NonEmpty EntityName) buildTagMap em = diff --git a/src/swarm-engine/Swarm/Game/State/Robot.hs b/src/swarm-engine/Swarm/Game/State/Robot.hs --- a/src/swarm-engine/Swarm/Game/State/Robot.hs +++ b/src/swarm-engine/Swarm/Game/State/Robot.hs @@ -62,22 +62,20 @@ import Data.IntSet qualified as IS import Data.IntSet.Lens (setOf) import Data.List (partition) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M import Data.Maybe (fromMaybe, mapMaybe) +import Data.MonoidMap (MonoidMap) +import Data.MonoidMap qualified as MM import Data.Set qualified as S -import Data.Tuple (swap) import GHC.Generics (Generic) import Swarm.Game.CESK (CESK (Waiting)) import Swarm.Game.Location -import Swarm.Game.ResourceLoading (NameGenerator) import Swarm.Game.Robot import Swarm.Game.Robot.Concrete import Swarm.Game.State.Config import Swarm.Game.Tick import Swarm.Game.Universe as U -import Swarm.Util (binTuples, surfaceEmpty, (<+=), (<<.=)) +import Swarm.ResourceLoading (NameGenerator) +import Swarm.Util ((<+=), (<<.=)) import Swarm.Util.Lens (makeLensesExcluding) -- | The 'ViewCenterRule' specifies how to determine the center of the @@ -120,13 +118,13 @@ -- 'wakeUpRobotsDoneSleeping'. -- Waiting robots for a given time are a list because it is cheaper to -- prepend to a list than insert into a 'Set'. - _waitingRobots :: Map TickNumber [RID] + _waitingRobots :: MonoidMap TickNumber [RID] , _currentTickWakeableBots :: [RID] - , _robotsByLocation :: Map SubworldName (Map Location IntSet) + , _robotsByLocation :: MonoidMap SubworldName (MonoidMap Location IntSet) , -- This member exists as an optimization so -- that we do not have to iterate over all "waiting" robots, -- since there may be many. - _robotsWatching :: Map (Cosmic Location) IntSet + _robotsWatching :: MonoidMap (Cosmic Location) IntSet , _robotNaming :: RobotNaming , _viewCenterRule :: ViewCenterRule , _viewCenter :: Cosmic Location @@ -153,7 +151,7 @@ -- | The names of the robots that are currently sleeping, indexed by wake up -- time. Note that this may not include all sleeping robots, particularly -- those that are only taking a short nap (e.g. @wait 1@). -waitingRobots :: Getter Robots (Map TickNumber [RID]) +waitingRobots :: Getter Robots (MonoidMap TickNumber [RID]) waitingRobots = internalWaitingRobots -- | Get a list of all the robots that are \"watching\" by location. @@ -168,10 +166,10 @@ -- location of a robot changes, or a robot is created or destroyed. -- Fortunately, there are relatively few ways for these things to -- happen. -robotsByLocation :: Lens' Robots (Map SubworldName (Map Location IntSet)) +robotsByLocation :: Lens' Robots (MonoidMap SubworldName (MonoidMap Location IntSet)) -- | Get a list of all the robots that are \"watching\" by location. -robotsWatching :: Lens' Robots (Map (Cosmic Location) IntSet) +robotsWatching :: Lens' Robots (MonoidMap (Cosmic Location) IntSet) -- | State and data for assigning identifiers to robots robotNaming :: Lens' Robots RobotNaming @@ -200,9 +198,9 @@ Robots { _robotMap = IM.empty , _activeRobots = IS.empty - , _waitingRobots = M.empty + , _waitingRobots = mempty , _currentTickWakeableBots = mempty - , _robotsByLocation = M.empty + , _robotsByLocation = mempty , _robotsWatching = mempty , _robotNaming = RobotNaming @@ -267,17 +265,14 @@ addRobotToLocation :: (Has (State Robots) sig m) => RID -> Cosmic Location -> m () addRobotToLocation rid rLoc = robotsByLocation - %= M.insertWith - (M.unionWith IS.union) - (rLoc ^. subworld) - (M.singleton (rLoc ^. planar) (IS.singleton rid)) + %= MM.adjust (MM.adjust (IS.insert rid) (rLoc ^. planar)) (rLoc ^. subworld) -- | Takes a robot out of the 'activeRobots' set and puts it in the 'waitingRobots' -- queue. sleepUntil :: (Has (State Robots) sig m) => RID -> TickNumber -> m () sleepUntil rid time = do internalActiveRobots %= IS.delete rid - internalWaitingRobots . at time . non [] %= (rid :) + internalWaitingRobots %= MM.adjust (rid :) time -- | Takes a robot out of the 'activeRobots' set. sleepForever :: (Has (State Robots) sig m) => RID -> m () @@ -301,22 +296,18 @@ -- * 'internalActiveRobots' (aka 'activeRobots') wakeUpRobotsDoneSleeping :: (Has (State Robots) sig m) => TickNumber -> m () wakeUpRobotsDoneSleeping time = do - mrids <- internalWaitingRobots . at time <<.= Nothing - case mrids of - Nothing -> return () - Just rids -> do - robots <- use robotMap - let robotIdSet = IM.keysSet robots - wakeableRIDsSet = IS.fromList rids + robotIdSet <- IM.keysSet <$> use robotMap + wakeableRIDsSet <- IS.fromList . MM.get time <$> use internalWaitingRobots + internalWaitingRobots %= MM.nullify time - -- Limit ourselves to the robots that have not expired in their sleep - newlyAlive = IS.intersection robotIdSet wakeableRIDsSet + -- Limit ourselves to the robots that have not expired in their sleep + let newlyAlive = IS.intersection robotIdSet wakeableRIDsSet - internalActiveRobots %= IS.union newlyAlive + internalActiveRobots %= IS.union newlyAlive - -- These robots' wake times may have been moved "forward" - -- by 'wakeWatchingRobots'. - clearWatchingRobots wakeableRIDsSet + -- These robots' wake times may have been moved "forward" + -- by 'wakeWatchingRobots'. + clearWatchingRobots wakeableRIDsSet -- | Clear the "watch" state of all of the -- awakened robots @@ -325,7 +316,7 @@ IntSet -> m () clearWatchingRobots rids = do - robotsWatching %= M.map (`IS.difference` rids) + robotsWatching %= MM.map (`IS.difference` rids) -- | Iterates through all of the currently @wait@-ing robots, -- and moves forward the wake time of the ones that are @watch@-ing this location. @@ -346,25 +337,22 @@ botsWatchingThisLoc = mapMaybe (`IM.lookup` rMap) $ IS.toList $ - M.findWithDefault mempty loc watchingMap + MM.get loc watchingMap -- Step 2: Get the target wake time for each of these robots wakeTimes :: [(RID, TickNumber)] wakeTimes = mapMaybe (sequenceA . (view robotID &&& waitingUntil)) botsWatchingThisLoc - wakeTimesToPurge :: Map TickNumber (S.Set RID) - wakeTimesToPurge = M.fromListWith (<>) $ map (fmap S.singleton . swap) wakeTimes + wakeTimesToPurge :: MonoidMap TickNumber (S.Set RID) + wakeTimesToPurge = foldr (uncurry (MM.adjust . S.insert)) mempty wakeTimes -- Step 3: Take these robots out of their time-indexed slot in "waitingRobots". -- To preserve performance, this should be done without iterating over the -- entire "waitingRobots" map. - filteredWaiting = foldr f waitingMap $ M.toList wakeTimesToPurge + filteredWaiting :: MonoidMap TickNumber [RID] + filteredWaiting = MM.foldrWithKey f waitingMap wakeTimesToPurge where - -- Note: some of the map values may become empty lists. - -- But we shall not worry about cleaning those up here; - -- they will be "garbage collected" as a matter of course - -- when their tick comes up in "wakeUpRobotsDoneSleeping". - f (k, botsToRemove) = M.adjust (filter (`S.notMember` botsToRemove)) k + f k botsToRemove = MM.adjust (filter (`S.notMember` botsToRemove)) k -- Step 4: Re-add the watching bots to be awakened ASAP: wakeableBotIds = map fst wakeTimes @@ -378,7 +366,7 @@ [ (currentTick, currTickWakeable) , (addTicks 1 currentTick, nextTickWakeable) ] - newInsertions = M.filter (not . null) $ M.fromList wakeTimeGroups + newInsertions = MM.fromList wakeTimeGroups -- Contract: This must be emptied immediately -- in 'iterateRobots' @@ -389,7 +377,7 @@ -- 2. In each robot, via the CESK machine state -- 1. Update the game state - internalWaitingRobots .= M.unionWith (<>) filteredWaiting newInsertions + internalWaitingRobots .= filteredWaiting <> newInsertions -- 2. Update the machine of each robot forM_ wakeTimeGroups $ \(newWakeTime, wakeableBots) -> @@ -416,12 +404,8 @@ RID -> m () removeRobotFromLocationMap (Cosmic oldSubworld oldPlanar) rid = - robotsByLocation %= M.update (tidyDelete rid) oldSubworld - where - deleteOne x = surfaceEmpty IS.null . IS.delete x - - tidyDelete robID = - surfaceEmpty M.null . M.update (deleteOne robID) oldPlanar + robotsByLocation + %= MM.adjust (MM.adjust (IS.delete rid) oldPlanar) oldSubworld setRobotInfo :: RID -> [Robot] -> Robots -> Robots setRobotInfo baseID robotList rState = @@ -432,19 +416,16 @@ setRobotList robotList rState = rState & robotMap .~ IM.fromList (map (view robotID &&& id) robotList) - & robotsByLocation .~ M.map (groupRobotsByPlanarLocation . NE.toList) (groupRobotsBySubworld robotList) + & robotsByLocation .~ groupRobotsByLocation robotList & internalActiveRobots .~ setOf (traverse . robotID) robotList & robotNaming . gensym .~ initGensym where initGensym = length robotList - 1 - groupRobotsBySubworld = - binTuples . map (view (robotLocation . subworld) &&& id) - - groupRobotsByPlanarLocation rs = - M.fromListWith - IS.union - (map (view (robotLocation . planar) &&& (IS.singleton . view robotID)) rs) + groupRobotsByLocation = foldr f mempty + where + f r = MM.adjust (g r) (r ^. (robotLocation . subworld)) + g r = MM.adjust (IS.insert (r ^. robotID)) (r ^. (robotLocation . planar)) -- | Modify the 'viewCenter' by applying an arbitrary function to the -- current value. Note that this also modifies the 'viewCenterRule' diff --git a/src/swarm-engine/Swarm/Game/State/Runtime.hs b/src/swarm-engine/Swarm/Game/State/Runtime.hs --- a/src/swarm-engine/Swarm/Game/State/Runtime.hs +++ b/src/swarm-engine/Swarm/Game/State/Runtime.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -- | @@ -6,18 +8,18 @@ -- Runtime state and utility functions module Swarm.Game.State.Runtime ( RuntimeState, + RuntimeOptions (..), + initRuntimeState, -- ** Lenses webPort, upstreamRelease, eventLog, - scenarios, appData, stdGameConfigInputs, -- ** Utility initScenarioInputs, - initRuntimeState, initGameStateConfig, ) where @@ -29,24 +31,20 @@ import Data.Map (Map) import Data.Sequence (Seq) import Data.Text (Text) -import Network.Wai.Handler.Warp (Port) -import Swarm.Game.Failure (SystemFailure) +import Swarm.Failure (SystemFailure) import Swarm.Game.Land import Swarm.Game.Recipe (loadRecipes) -import Swarm.Game.ResourceLoading (initNameGenerator, readAppData) import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..)) -import Swarm.Game.ScenarioInfo (ScenarioCollection, loadScenarios) import Swarm.Game.State.Substate import Swarm.Game.World.Load (loadWorlds) import Swarm.Log +import Swarm.ResourceLoading (initNameGenerator, readAppData) import Swarm.Util.Lens (makeLensesNoSigs) -import Swarm.Version (NewReleaseFailure (..)) data RuntimeState = RuntimeState - { _webPort :: Maybe Port - , _upstreamRelease :: Either NewReleaseFailure String + { _webPort :: Maybe Int + , _upstreamRelease :: Either (Severity, Text) String , _eventLog :: Notifications LogEntry - , _scenarios :: ScenarioCollection , _stdGameConfigInputs :: GameStateConfig , _appData :: Map Text Text } @@ -78,29 +76,36 @@ , Has (Accum (Seq SystemFailure)) sig m , Has (Lift IO) sig m ) => + RuntimeOptions -> m GameStateConfig -initGameStateConfig = do - gsi <- initGameStateInputs - appDataMap <- readAppData - nameGen <- initNameGenerator appDataMap - return $ GameStateConfig appDataMap nameGen gsi +initGameStateConfig RuntimeOptions {..} = do + initAppDataMap <- readAppData + nameParts <- initNameGenerator initAppDataMap + initState <- initGameStateInputs + return $ GameStateConfig {..} +-- | Runtime state initialization options. +data RuntimeOptions = RuntimeOptions + { startPaused :: Bool + , pauseOnObjectiveCompletion :: Bool + , loadTestScenarios :: Bool + } + deriving (Eq, Show) + initRuntimeState :: ( Has (Throw SystemFailure) sig m , Has (Accum (Seq SystemFailure)) sig m , Has (Lift IO) sig m ) => + RuntimeOptions -> m RuntimeState -initRuntimeState = do - gsc <- initGameStateConfig - scenarios <- loadScenarios $ gsiScenarioInputs $ initState gsc - +initRuntimeState opts = do + gsc <- initGameStateConfig opts return $ RuntimeState { _webPort = Nothing - , _upstreamRelease = Left (NoMainUpstreamRelease []) + , _upstreamRelease = Left (Info, "No upstream release found.") , _eventLog = mempty - , _scenarios = scenarios , _appData = initAppDataMap gsc , _stdGameConfigInputs = gsc } @@ -108,10 +113,10 @@ makeLensesNoSigs ''RuntimeState -- | The port on which the HTTP debug service is running. -webPort :: Lens' RuntimeState (Maybe Port) +webPort :: Lens' RuntimeState (Maybe Int) -- | The upstream release version. -upstreamRelease :: Lens' RuntimeState (Either NewReleaseFailure String) +upstreamRelease :: Lens' RuntimeState (Either (Severity, Text) String) -- | A log of runtime events. -- @@ -119,9 +124,6 @@ -- If some error happens before a game is even selected, this is the -- place to log it. eventLog :: Lens' RuntimeState (Notifications LogEntry) - --- | The collection of scenarios that comes with the game. -scenarios :: Lens' RuntimeState ScenarioCollection -- | Built-in resources for loading games stdGameConfigInputs :: Lens' RuntimeState GameStateConfig diff --git a/src/swarm-engine/Swarm/Game/State/Substate.hs b/src/swarm-engine/Swarm/Game/State/Substate.hs --- a/src/swarm-engine/Swarm/Game/State/Substate.hs +++ b/src/swarm-engine/Swarm/Game/State/Substate.hs @@ -27,12 +27,14 @@ -- *** Temporal state TemporalState, + PauseOnObjective (..), initTemporalState, gameStep, runStatus, ticks, robotStepsPerTick, paused, + pauseOnObjective, -- *** Recipes Recipes, @@ -54,6 +56,7 @@ initiallyRunCode, replStatus, replNextValueIndex, + replListener, inputHandler, -- *** Discovery @@ -63,6 +66,7 @@ availableRecipes, availableCommands, knownEntities, + craftableDevices, gameAchievements, structureRecognition, tagMembers, @@ -101,15 +105,14 @@ outRecipeMap, ) import Swarm.Game.Robot -import Swarm.Game.Scenario (GameStateInputs (..), StructureCells) +import Swarm.Game.Scenario (GameStateInputs (..), RecognizableStructureContent) import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Topography.Structure.Recognition import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (emptyFoundStructures) -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (RecognizerAutomatons (..)) import Swarm.Game.State.Config import Swarm.Game.Tick (TickNumber (..)) import Swarm.Game.World.Gen (Seed) -import Swarm.Language.Syntax (Const, TSyntax) +import Swarm.Language.Syntax (Const, Syntax) import Swarm.Language.Types (Polytype) import Swarm.Language.Value (Value) import Swarm.Log @@ -128,7 +131,7 @@ -- entered. The @Maybe Value@ starts out as 'Nothing' and gets -- filled in with a result once the command completes. REPLWorking Polytype (Maybe Value) - deriving (Eq, Show, Generic, FromJSON, ToJSON) + deriving (Eq, Generic, ToJSON) data WinStatus = -- | There are one or more objectives remaining that the player @@ -144,7 +147,7 @@ -- The boolean indicates whether they have -- already been informed. Unwinnable Bool - deriving (Show, Generic, FromJSON, ToJSON) + deriving (Eq, Show, Generic, FromJSON, ToJSON) data WinCondition = -- | There is no winning condition. @@ -272,11 +275,15 @@ -- | Game step mode - we use the single step mode when debugging robot 'CESK' machine. data Step = WorldTick | RobotStep SingleStep +data PauseOnObjective = PauseOnWin | PauseOnAnyObjective + deriving (Eq, Ord, Show, Enum, Bounded) + data TemporalState = TemporalState { _gameStep :: Step , _runStatus :: RunStatus , _ticks :: TickNumber , _robotStepsPerTick :: Int + , _pauseOnObjective :: PauseOnObjective } makeLensesNoSigs ''TemporalState @@ -298,11 +305,15 @@ -- a single tick. robotStepsPerTick :: Lens' TemporalState Int +-- | Whether to pause the game after an objective is completed. +pauseOnObjective :: Lens' TemporalState PauseOnObjective + data GameControls = GameControls { _replStatus :: REPLStatus , _replNextValueIndex :: Integer + , _replListener :: Text -> IO () , _inputHandler :: Maybe (Text, Value) - , _initiallyRunCode :: Maybe TSyntax + , _initiallyRunCode :: Maybe Syntax } makeLensesNoSigs ''GameControls @@ -313,20 +324,25 @@ -- | The index of the next @it{index}@ value replNextValueIndex :: Lens' GameControls Integer +-- | The action to be run after transitioning to REPLDone. +-- This is used to tell Web API the result of run command. +replListener :: Lens' GameControls (Text -> IO ()) + -- | The currently installed input handler and hint text. inputHandler :: Lens' GameControls (Maybe (Text, Value)) -- | Code that is run upon scenario start, before any -- REPL interaction. -initiallyRunCode :: Lens' GameControls (Maybe TSyntax) +initiallyRunCode :: Lens' GameControls (Maybe Syntax) data Discovery = Discovery { _allDiscoveredEntities :: Inventory , _availableRecipes :: Notifications (Recipe Entity) , _availableCommands :: Notifications Const , _knownEntities :: S.Set EntityName + , _craftableDevices :: S.Set EntityName , _gameAchievements :: Map GameplayAchievement Attainment - , _structureRecognition :: StructureRecognizer StructureCells Entity + , _structureRecognition :: RecognitionState RecognizableStructureContent Entity , _tagMembers :: Map Text (NonEmpty EntityName) } @@ -345,11 +361,15 @@ -- robots know what they are without having to scan them. knownEntities :: Lens' Discovery (S.Set EntityName) +-- | The set of all entities that can be crafted in the current +-- scenario. +craftableDevices :: Lens' Discovery (S.Set EntityName) + -- | Map of in-game achievements that were obtained gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment) -- | Recognizer for robot-constructed structures -structureRecognition :: Lens' Discovery (StructureRecognizer StructureCells Entity) +structureRecognition :: Lens' Discovery (RecognitionState RecognizableStructureContent Entity) -- | Map from tags to entities that possess that tag tagMembers :: Lens' Discovery (Map Text (NonEmpty EntityName)) @@ -392,13 +412,14 @@ -- * Record initialization -initTemporalState :: TemporalState -initTemporalState = +initTemporalState :: Bool -> TemporalState +initTemporalState pausedAtStart = TemporalState { _gameStep = WorldTick - , _runStatus = Running + , _runStatus = if pausedAtStart then ManualPause else Running , _ticks = TickNumber 0 , _robotStepsPerTick = defaultRobotStepsPerTick + , _pauseOnObjective = PauseOnAnyObjective } initGameControls :: GameControls @@ -406,6 +427,7 @@ GameControls { _replStatus = REPLDone Nothing , _replNextValueIndex = 0 + , _replListener = const $ pure () , _inputHandler = Nothing , _initiallyRunCode = Nothing } @@ -425,10 +447,11 @@ , _availableCommands = mempty , _allDiscoveredEntities = empty , _knownEntities = mempty + , _craftableDevices = mempty , -- This does not need to be initialized with anything, -- since the master list of achievements is stored in UIState _gameAchievements = mempty - , _structureRecognition = StructureRecognizer (RecognizerAutomatons mempty mempty) emptyFoundStructures [] + , _structureRecognition = RecognitionState emptyFoundStructures [] , _tagMembers = mempty } diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs --- a/src/swarm-engine/Swarm/Game/Step.hs +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -19,7 +19,6 @@ -- See . module Swarm.Game.Step where -import Control.Applicative (Applicative (..)) import Control.Carrier.Error.Either (ErrorC, runError) import Control.Carrier.State.Lazy import Control.Carrier.Throw.Either (runThrow) @@ -28,6 +27,7 @@ import Control.Effect.Lift import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) import Control.Monad (foldM, forM_, unless, when) +import Data.Foldable.Extra (notNull) import Data.Functor (void) import Data.IntMap qualified as IM import Data.IntSet qualified as IS @@ -64,17 +64,18 @@ import Swarm.Game.Step.Util.Command import Swarm.Game.Tick import Swarm.Language.Capability -import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText) import Swarm.Language.Requirements qualified as R import Swarm.Language.Syntax +import Swarm.Language.TDVar (tdVarName) import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Value import Swarm.Log +import Swarm.Pretty (BulletList (BulletList, bulletListItems), prettyText) import Swarm.Util hiding (both) import Swarm.Util.WindowedCounter qualified as WC import System.Clock (TimeSpec) import Witch (From (from)) -import Prelude hiding (Applicative (..), lookup) +import Prelude hiding (lookup) -- | The main function to do one game tick. -- @@ -100,15 +101,12 @@ -- also save the current store into the robotContext so we can -- restore it the next time we start a computation. mr <- use (robotInfo . robotMap . at 0) - case mr of - Just r -> do - res <- use $ gameControls . replStatus - case res of - REPLWorking ty Nothing -> case getResult r of - Just v -> gameControls . replStatus .= REPLWorking ty (Just v) - Nothing -> pure () - _otherREPLStatus -> pure () - Nothing -> pure () + forM_ mr $ \r -> do + res <- use $ gameControls . replStatus + case res of + REPLWorking ty Nothing -> forM_ (getResult r) $ \v -> + gameControls . replStatus .= REPLWorking ty (Just v) + _otherREPLStatus -> pure () -- Possibly update the view center. modify recalcViewCenterAndRedraw @@ -338,8 +336,14 @@ Unwinnable _ -> grantAchievement LoseScenario _ -> return () - messageInfo . announcementQueue %= (>< Seq.fromList (map ObjectiveCompleted $ completionAnnouncementQueue finalAccumulator)) + queue <- messageInfo . announcementQueue Swarm.Util.<%= (>< Seq.fromList (map ObjectiveCompleted $ completionAnnouncementQueue finalAccumulator)) + shouldPause <- use $ temporal . pauseOnObjective + let gameFinished = newWinState /= Ongoing + let finishedObjectives = notNull queue + when (finishedObjectives && (gameFinished || shouldPause == PauseOnAnyObjective)) $ + temporal . runStatus .= AutoPause + mapM_ handleException $ exceptions finalAccumulator where getNextWinState ts completedObjs @@ -388,8 +392,6 @@ T.unwords [ "Non boolean value:" , prettyValue val - , "real:" - , T.pack (show val) ] -- Log exceptions in the message queue so we can check for them in tests @@ -554,14 +556,15 @@ In (TInt n) _ s k -> return $ Out (VInt n) s k In (TText str) _ s k -> return $ Out (VText str) s k In (TBool b) _ s k -> return $ Out (VBool b) s k + In (TType ty) _ s k -> return $ Out (VType ty) s k -- There should not be any antiquoted variables left at this point. In (TAntiText v) _ s k -> return $ Up (Fatal (T.append "Antiquoted variable found at runtime: $str:" v)) s k In (TAntiInt v) _ s k -> return $ Up (Fatal (T.append "Antiquoted variable found at runtime: $int:" v)) s k - -- Require and requireDevice just turn into no-ops. - In (TRequireDevice {}) e s k -> return $ In (TConst Noop) e s k + -- Require and Stock just turn into no-ops. In (TRequire {}) e s k -> return $ In (TConst Noop) e s k + In (TStock {}) e s k -> return $ In (TConst Noop) e s k In (TRequirements x t) e s k -> return $ Out (VRequirements x t e) s k -- Type ascriptions are ignored In (TAnnotate v _) e s k -> return $ In v e s k @@ -595,11 +598,40 @@ Out v2 s (FFst v1 : k) -> return $ Out (VPair v1 v2) s k -- Lambdas immediately turn into closures. In (TLam x _ t) e s k -> return $ Out (VClo x t e) s k + -- Special case for evaluating an application of Instant or Atomic: + -- set the runningAtomic flag and push a stack frame to unset it + -- when done evaluating. We do this here so that even /evaluating/ + -- the argument to instant/atomic will happen atomically (#2270). + -- Execution will also happen atomically; that is handled in + -- execConst. + In (TApp (TConst c) t2) e s k + | c `elem` [Atomic, Instant] -> do + runningAtomic .= True + case k of + -- In the (common) special case that we will immediately + -- execute the atomic/instant command next, don't bother + -- pushing an FFinishAtomic frame. That way, runningAtomic + -- will remain set, and evaluation + execution together will + -- all happen in a single tick. + FExec : _ -> return $ In t2 e s (FApp (VCApp c []) : k) + -- Otherwise, in general, other evaluation may take place in + -- between evaluating the argument to atomic/instant and + -- executing it, so we must push an FFinishAtomic frame so + -- that intermediate evaluation will not happen atomically. + -- For example, consider something like `f (instant c)`, + -- where `f : Cmd Unit -> Cmd Unit`. After evaluating `c` + -- atomically, `instant c` is then passed to `f`, which may + -- do some (non-atomic) computation before executing its + -- argument (if it is executed at all). + _ -> return $ In t2 e s (FApp (VCApp c []) : FFinishAtomic : k) -- To evaluate an application, start by focusing on the left-hand -- side and saving the argument for later. In (TApp t1 t2) e s k -> return $ In t1 e s (FArg t2 e : k) -- Once that's done, switch to evaluating the argument. Out v1 s (FArg t2 e : k) -> return $ In t2 e s (FApp v1 : k) + -- Or, if there is an FVArg frame, the argument is already + -- evaluated, so send it directly to an FApp. + Out v1 s (FVArg v2 : k) -> return $ Out v2 s (FApp v1 : k) -- We can evaluate an application of a closure in the usual way. Out v2 s (FApp (VClo x t e) : k) -> return $ In t (addValueBinding x v2 e) s k -- We can also evaluate an application of a constant by collecting @@ -633,10 +665,10 @@ _ -> badMachineState s "FProj frame with non-record value" -- To evaluate non-recursive let expressions, we start by focusing on the -- let-bound expression. - In (TLet _ False x mty mreq t1 t2) e s k -> + In (TLet _ False x _ mty mreq t1 t2) e s k -> return $ In t1 e s (FLet x ((,) <$> mty <*> mreq) t2 e : k) -- To evaluate a recursive let binding: - In (TLet _ True x mty mreq t1 t2) e s k -> do + In (TLet _ True x _ mty mreq t1 t2) e s k -> do -- First, allocate a cell for it in the store with the initial -- value of Blackhole. let (loc, s') = allocate VBlackhole s @@ -654,7 +686,7 @@ return $ In t2 e' s k -- To evaluate a tydef, insert it into the context and proceed to -- evaluate the body. - In (TTydef x _ tdInfo t1) e s k -> return $ In t1 (maybe id (addTydef x) tdInfo e) s k + In (TTydef x _ tdInfo t1) e s k -> return $ In t1 (maybe id (addTydef (tdVarName x)) tdInfo e) s k -- Bind expressions don't evaluate: just package it up as a value -- until such time as it is to be executed. In (TBind mx mty mreq t1 t2) e s k -> return $ Out (VBind mx mty mreq t1 t2 e) s k @@ -667,6 +699,8 @@ -- If we see a primitive application of suspend, package it up as -- a value until it's time to execute. In (TSuspend t) e s k -> return $ Out (VSuspend t e) s k + -- Ignore explicit parens. + In (TParens t) e s k -> return $ In t e s k ------------------------------------------------------------ -- Execution @@ -830,7 +864,7 @@ -- -- HOWEVER, we have to make sure to check that the robot has the -- 'log' capability which is required to collect and view logs. - h <- hasCapability CLog + h <- hasCapability $ CExecute Log em <- use $ landscape . terrainAndEntities . entityMap when h $ void $ traceLog RobotError (exnSeverity exn) (formatExn em exn) return $ case menv of diff --git a/src/swarm-engine/Swarm/Game/Step/Arithmetic.hs b/src/swarm-engine/Swarm/Game/Step/Arithmetic.hs --- a/src/swarm-engine/Swarm/Game/Step/Arithmetic.hs +++ b/src/swarm-engine/Swarm/Game/Step/Arithmetic.hs @@ -9,7 +9,6 @@ -- Arithmetic and Comparison commands module Swarm.Game.Step.Arithmetic where -import Control.Applicative (Applicative (..)) import Control.Carrier.State.Lazy import Control.Effect.Error import Control.Monad (zipWithM) @@ -21,7 +20,7 @@ import Swarm.Language.Syntax import Swarm.Language.Value import Witch (From (from)) -import Prelude hiding (Applicative (..), lookup) +import Prelude hiding (lookup) ------------------------------------------------------------ -- Comparison @@ -77,6 +76,7 @@ VSuspend {} -> incomparable v1 VExc {} -> incomparable v1 VBlackhole {} -> incomparable v1 + VType {} -> incomparable v1 -- | Values with different types were compared; this should not be -- possible since the type system should catch it. diff --git a/src/swarm-engine/Swarm/Game/Step/Combustion.hs b/src/swarm-engine/Swarm/Game/Step/Combustion.hs --- a/src/swarm-engine/Swarm/Game/Step/Combustion.hs +++ b/src/swarm-engine/Swarm/Game/Step/Combustion.hs @@ -16,7 +16,6 @@ -- well as to initiate the delayed combustion of its neighbors. module Swarm.Game.Step.Combustion where -import Control.Applicative (Applicative (..)) import Control.Carrier.State.Lazy import Control.Effect.Lens import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) @@ -46,7 +45,7 @@ import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Util hiding (both) import System.Clock (TimeSpec) -import Prelude hiding (Applicative (..), lookup) +import Prelude hiding (lookup) igniteCommand :: (HasRobotStepState sig m, Has Effect.Time sig m) => Const -> Direction -> m () igniteCommand c d = do @@ -67,7 +66,11 @@ let selfCombustibility = (e ^. entityCombustion) ? defaultCombustibility createdAt <- getNow combustionDurationRand <- addCombustionBot e selfCombustibility createdAt loc - forM_ (getNeighborLocs loc) $ igniteNeighbor createdAt combustionDurationRand + let warmup = delay selfCombustibility + let neighborAffectDuration = max 0 (combustionDurationRand - warmup) + when (neighborAffectDuration > 0) $ + forM_ (getNeighborLocs loc) $ + igniteNeighbor createdAt warmup neighborAffectDuration where verb = "ignite" verbed = "ignited" @@ -117,7 +120,7 @@ ts return combustionDurationRand where - Combustibility _ durationRange maybeCombustionProduct = combustibility + Combustibility _ durationRange _ maybeCombustionProduct = combustibility -- | A system program for a "combustion robot", to burn an entity -- after it is ignited. @@ -141,7 +144,7 @@ -- cells. This would avoid polluting the logic of the currently burning cell -- with logic to manage probabilities of combustion propagation. combustionProgram :: Integer -> Combustibility -> TSyntax -combustionProgram combustionDuration (Combustibility _ _ maybeCombustionProduct) = +combustionProgram combustionDuration (Combustibility _ _ _ maybeCombustionProduct) = [tmQ| wait $int:combustionDuration; if ($int:invQuantity > 0) { @@ -156,18 +159,25 @@ Nothing -> (0, "") Just p -> (1, p) --- | We treat the 'ignition' field in the 'Combustibility' record --- as a /rate/ in a Poisson distribution. --- Ignition of neighbors depends on that particular neighbor entity's --- combustion /rate/, but also on the duration --- that the current entity will burn. +-- | Possibly ignite a neighbor of a source entity that is combusting. +-- @creationTime@ is the time the source entity began to combust. +-- @warmup@ is the number of ticks of delay that the source entity +-- needs to burn before it will start affecting its neighbors; +-- @sourceDuration@ is the number of ticks that it will potentially +-- affect its neighbors. +-- +-- We treat the 'ignition' field in the 'Combustibility' record as a +-- /rate/ in a Poisson distribution. Ignition of neighbors depends +-- on that particular neighbor entity's combustion /rate/, but also +-- on the @sourceDuration@ time that the current entity will burn. igniteNeighbor :: Has (State GameState) sig m => TimeSpec -> Integer -> + Integer -> Cosmic Location -> m () -igniteNeighbor creationTime sourceDuration loc = do +igniteNeighbor creationTime warmup sourceDuration loc = do maybeEnt <- entityAt loc forM_ maybeEnt igniteEntity where @@ -177,7 +187,8 @@ when (probabilityOfIgnition >= threshold) $ do ignitionDelayRand <- uniform (0, 1) let ignitionDelay = - floor + (warmup +) + . floor . min (fromIntegral sourceDuration) . negate $ log ignitionDelayRand / rate diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -11,7 +11,6 @@ -- Implementation of robot commands module Swarm.Game.Step.Const where -import Control.Applicative (Applicative (..)) import Control.Arrow ((&&&)) import Control.Carrier.State.Lazy import Control.Effect.Error @@ -35,7 +34,9 @@ import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Map.NonEmpty qualified as NEM +import Data.Map.Strict qualified as MS import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) +import Data.MonoidMap qualified as MM import Data.Ord (Down (Down)) import Data.Sequence qualified as Seq import Data.Set (Set) @@ -45,26 +46,27 @@ import Data.Tuple (swap) import Linear (V2 (..), perp, zero) import Swarm.Effect as Effect (Time, getNow) +import Swarm.Failure import Swarm.Game.Achievement.Definitions import Swarm.Game.CESK import Swarm.Game.Display import Swarm.Game.Entity hiding (empty, lookup, singleton, union) import Swarm.Game.Entity qualified as E import Swarm.Game.Exception -import Swarm.Game.Failure import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Recipe -import Swarm.Game.ResourceLoading (getDataFileNameSafe) import Swarm.Game.Robot import Swarm.Game.Robot.Activity import Swarm.Game.Robot.Concrete import Swarm.Game.Robot.Walk (emptyExceptions) -import Swarm.Game.Scenario.Topography.Area (getAreaDimensions) +import Swarm.Game.Scenario (RecognizableStructureContent) +import Swarm.Game.Scenario.Topography.Area (getNEGridDimensions, rectHeight) import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.Navigation.Util import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..)) -import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons, foundStructures) +import Swarm.Game.Scenario.Topography.Structure.Named (StructureName (..)) +import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.State @@ -87,22 +89,25 @@ import Swarm.Game.Value import Swarm.Language.Capability import Swarm.Language.Key (parseKeyComboFull) +import Swarm.Language.Parser.Value (readValue) import Swarm.Language.Pipeline -import Swarm.Language.Pretty (prettyText) import Swarm.Language.Requirements qualified as R import Swarm.Language.Syntax import Swarm.Language.Syntax.Direction import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Language.Value import Swarm.Log +import Swarm.Pretty (prettyText) +import Swarm.ResourceLoading (getDataFileNameSafe) import Swarm.Util hiding (both) import Swarm.Util.Effect (throwToMaybe) import Swarm.Util.Lens (inherit) import Text.Megaparsec (runParser) import Witch (From (from), into) -import Prelude hiding (Applicative (..), lookup) +import Prelude hiding (lookup) --- | How to handle failure, for example when moving to blocked location +-- | How to handle failure, for example when moving into liquid or +-- attempting to move to a blocked location data RobotFailure = ThrowExn | Destroy | IgnoreFail -- | How to handle different types of failure when moving/teleporting @@ -134,12 +139,12 @@ when (isTangible c) $ activityCounts . tangibleCommandCount += 1 - activityCounts . commandsHistogram %= M.insertWith (+) c 1 + activityCounts . commandsHistogram %= MS.insertWith (+) c 1 -- Now proceed to actually carry out the operation. case c of Noop -> return $ mkReturn () - Return -> case vs of + Pure -> case vs of [v] -> return $ Out v s k _ -> badConst Wait -> case vs of @@ -210,22 +215,20 @@ -- If unobstructed, the robot will move even if -- there is nothing to push. maybeCurrentE <- entityAt nextLoc - case maybeCurrentE of - Just e -> do - -- Make sure there's nothing already occupying the destination - nothingHere <- isNothing <$> entityAt placementLoc - nothingHere `holdsOrFail` ["Something is in the way!"] + forM_ maybeCurrentE $ \e -> do + -- Make sure there's nothing already occupying the destination + nothingHere <- isNothing <$> entityAt placementLoc + nothingHere `holdsOrFail` ["Something is in the way!"] - let verbed = verbedGrabbingCmd Push' - -- Ensure it can be pushed. - omni <- isPrivilegedBot - (omni || e `hasProperty` Pushable || e `hasProperty` Pickable && not (e `hasProperty` Liquid)) - `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."] + let verbed = verbedGrabbingCmd Push' + -- Ensure it can be pushed. + omni <- isPrivilegedBot + (omni || e `hasProperty` Pushable || e `hasProperty` Pickable && not (e `hasProperty` Liquid)) + `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."] - -- Place the entity and remove it from previous loc - updateEntityAt nextLoc (const Nothing) - updateEntityAt placementLoc (const (Just e)) - Nothing -> return () + -- Place the entity and remove it from previous loc + updateEntityAt nextLoc (const Nothing) + updateEntityAt placementLoc (const (Just e)) updateRobotLocation loc nextLoc return $ mkReturn () @@ -272,35 +275,13 @@ _ -> badConst Teleport -> case vs of [VRobot rid, VPair (VInt x) (VInt y)] -> do - -- Make sure the other robot exists and is close - target <- getRobotWithinTouch rid - -- either change current robot or one in robot map - let oldLoc = target ^. robotLocation - nextLoc = fmap (const $ Location (fromIntegral x) (fromIntegral y)) oldLoc - - onTarget rid $ do - checkMoveAhead nextLoc $ \case - PathBlockedBy _ -> Destroy - PathLiquid _ -> Destroy - updateRobotLocation oldLoc nextLoc - - -- Privileged robots can teleport without causing any - -- improbable effects. Unprivileged robots must be using an - -- infinite improbability drive, which can cause a random entity - -- to spawn near the target location. - omni <- isPrivilegedBot - unless omni $ do - let area = map (<$ nextLoc) $ getLocsInArea (nextLoc ^. planar) 5 - emptyLocs <- filterM (fmap isNothing . entityAt) area - randomLoc <- weightedChoice (const 1) emptyLocs - es <- uses (landscape . terrainAndEntities . entityMap) allEntities - randomEntity <- weightedChoice (const 1) es - case (randomLoc, randomEntity) of - (Just loc, Just e) -> updateEntityAt loc (const (Just e)) - _ -> return () - - return $ mkReturn () + doTeleport rid (Location (fromIntegral x) (fromIntegral y) <$) _ -> badConst + Warp -> case vs of + [VRobot rid, VPair (VText swName) (VPair (VInt x) (VInt y))] -> do + doTeleport rid . const . Cosmic (SubworldName swName) $ + Location (fromIntegral x) (fromIntegral y) + _ -> badConst Grab -> mkReturn <$> doGrab Grab' PerformRemoval Harvest -> mkReturn <$> doGrab Harvest' PerformRemoval Sow -> case vs of @@ -367,8 +348,9 @@ -- Make sure the robot has the thing in its inventory e <- hasInInventoryOrFail name - -- Place the entity and remove it from the inventory - updateEntityAt loc (const (Just e)) + -- Place the entity (if it is not evanescent) and remove it from the inventory + unless (Evanescent `S.member` (e ^. entityProperties)) $ + updateEntityAt loc (const (Just e)) robotInventory %= delete e flagRedraw @@ -427,6 +409,13 @@ equippedDevices %= insert item robotInventory %= delete item + -- Check whether we should bestow the 'EquippedAllDevices' achievement + curScenario <- use currentScenarioPath + when (curScenario == Just "classic.yaml") $ do + equipped <- S.fromList . map (view entityName) . nonzeroEntities <$> use equippedDevices + equippable <- use $ discovery . craftableDevices + when (equippable `S.isSubsetOf` equipped) $ grantAchievementForRobot EquippedAllDevices + -- Flag the UI for a redraw if we are currently showing our inventory when (focusedID == myID) flagRedraw @@ -436,9 +425,33 @@ [VText itemName] -> do item <- ensureEquipped itemName myID <- use robotID + + -- Speculatively unequip the item focusedID <- use $ robotInfo . focusedRobotID equippedDevices %= delete item robotInventory %= insert item + + -- Now check whether being on the current cell would still be + -- allowed. + loc <- use robotLocation + mfail <- checkMoveFailure loc + forM_ mfail \case + PathBlockedBy _ -> do + -- If unequipping the device would somehow result in the + -- path being blocked, don't allow it; re-equip the device + -- and throw an exception. + robotInventory %= delete item + equippedDevices %= insert item + throwError . cmdExn Unequip $ + ["You can't unequip the", item ^. entityName, "right now!"] + PathLiquid _ -> do + -- Unequipping a device that gives the Float capability in + -- the middle of liquid results in drowning, EVEN for + -- base! This is currently the only (known) way to get + -- the `DestroyedBase` achievement. + selfDestruct .= True + when (myID == 0) $ grantAchievementForRobot DestroyedBase + -- Flag the UI for a redraw if we are currently showing our inventory when (focusedID == myID) flagRedraw return $ mkReturn () @@ -529,8 +542,8 @@ where excludeSelf = (`IS.difference` IS.singleton selfRid) botsHere (Cosmic swName loc) = - M.findWithDefault mempty loc $ - M.findWithDefault mempty swName botsByLocs + MM.get loc $ + MM.get swName botsByLocs botIsVisible = maybe False canSee . (`IM.lookup` rMap) canSee = not . (^. robotDisplay . invisible) @@ -557,36 +570,38 @@ Whereami -> do loc <- use robotLocation return $ mkReturn $ loc ^. planar - Waypoint -> case vs of - [VText name, VInt idx] -> do + LocateMe -> do + loc <- use robotLocation + return $ mkReturn (loc ^. subworld, loc ^. planar) + Waypoints -> case vs of + [VText name] -> do lm <- use $ landscape . worldNavigation Cosmic swName _ <- use robotLocation - case M.lookup (WaypointName name) $ M.findWithDefault mempty swName $ waypoints lm of - Nothing -> throwError $ CmdFailed Waypoint (T.unwords ["No waypoint named", name]) Nothing - Just wps -> return $ mkReturn (NE.length wps, indexWrapNonEmpty wps idx) + let mwps = M.lookup (WaypointName name) $ M.findWithDefault mempty swName $ waypoints lm + return $ mkReturn $ maybe [] NE.toList mwps _ -> badConst - Structure -> case vs of - [VText name, VInt idx] -> do + Structures -> case vs of + [VText name] -> do registry <- use $ discovery . structureRecognition . foundStructures - let maybeFoundStructures = M.lookup name $ foundByName registry - mkOutput mapNE = (NE.length xs, bottomLeftCorner) + let maybeFoundStructures = M.lookup (StructureName name) $ foundByName registry + structures :: [((Cosmic Location, AbsoluteDir), StructureWithGrid RecognizableStructureContent Entity)] + structures = maybe [] (NE.toList . NEM.toList) maybeFoundStructures + + bottomLeftCorner ((pos, _), struc) = topLeftCorner .+^ offsetHeight where - xs = NEM.toList mapNE - (pos, struc) = indexWrapNonEmpty xs idx topLeftCorner = pos ^. planar - offsetHeight = V2 0 $ -fromIntegral (length (entityGrid struc) - 1) - bottomLeftCorner :: Location - bottomLeftCorner = topLeftCorner .+^ offsetHeight - return $ mkReturn $ mkOutput <$> maybeFoundStructures + offsetHeight = V2 0 $ negate (rectHeight (getNEGridDimensions $ extractedGrid $ entityGrid struc) - 1) + + return $ mkReturn $ map bottomLeftCorner structures _ -> badConst Floorplan -> case vs of [VText name] -> do - structureTemplates <- use $ discovery . structureRecognition . automatons . originalStructureDefinitions - let maybeStructure = M.lookup name structureTemplates + structureTemplates <- use $ landscape . recognizerAutomatons . originalStructureDefinitions + let maybeStructure = M.lookup (StructureName name) structureTemplates structureDef <- maybeStructure `isJustOr` cmdExn Floorplan (pure $ T.unwords ["Unknown structure", quote name]) - return . mkReturn . getAreaDimensions $ entityProcessedGrid structureDef + return . mkReturn . getNEGridDimensions $ entityProcessedGrid structureDef _ -> badConst HasTag -> case vs of [VText eName, VText tName] -> do @@ -597,11 +612,11 @@ return $ mkReturn $ tName `S.member` (e ^. entityTags) _ -> badConst TagMembers -> case vs of - [VText tagName, VInt idx] -> do + [VText tagName] -> do tm <- use $ discovery . tagMembers case M.lookup tagName tm of Nothing -> throwError $ CmdFailed TagMembers (T.unwords ["No tag named", tagName]) Nothing - Just theMembers -> return $ mkReturn (NE.length theMembers, indexWrapNonEmpty theMembers idx) + Just theMembers -> return $ mkReturn theMembers _ -> badConst Detect -> case vs of [VText name, VRect x1 y1 x2 y2] -> do @@ -759,34 +774,16 @@ [VText msg] -> do isPrivileged <- isPrivilegedBot loc <- use robotLocation - -- current robot will be inserted into the robot set, so it needs the log m <- traceLog Said Info msg emitMessage m - let measureToLog robLoc = \case - RobotLog _ _ logLoc -> cosmoMeasure manhattan robLoc logLoc - SystemLog -> Measurable 0 - addLatestClosest rl = \case - Seq.Empty -> Seq.singleton m - es Seq.:|> e - | e `isEarlierThan` m -> es |> e |> m - | e `isFartherThan` m -> es |> m - | otherwise -> es |> e - where - isEarlierThan = (<) `on` (^. leTime) - isFartherThan = (>) `on` (measureToLog rl . view leSource) let addToRobotLog :: (Has (State GameState) sgn m) => Robot -> m () - addToRobotLog r = do - maybeRidLoc <- evalState r $ do - hasLog <- hasCapability CLog - hasListen <- hasCapability CListen - loc' <- use robotLocation - rid <- use robotID - return $ do - guard $ hasLog && hasListen - Just (rid, loc') - forM_ maybeRidLoc $ \(rid, loc') -> - robotInfo . robotMap . at rid . _Just . robotLog %= addLatestClosest loc' + addToRobotLog r = evalState r $ do + hasLog <- hasCapability $ CExecute Log + hasListen <- hasCapability $ CExecute Listen + rid <- use robotID + when (hasLog && hasListen) $ + robotInfo . robotMap . at rid . _Just . robotLog %= (|> m) robotsAround <- zoomRobots $ if isPrivileged @@ -811,7 +808,7 @@ mm = limitLast . Seq.filter (liftA2 (&&) notMine isClose) $ Seq.takeWhileR (messageIsRecent gs) mq return $ maybe - (In (TConst Listen) mempty s (FExec : k)) -- continue listening + (In (TConst Listen) emptyEnv s (FExec : k)) -- continue listening (\m -> Out (VText m) s k) -- return found message mm Log -> case vs of @@ -910,9 +907,10 @@ omni <- isPrivilegedBot case omni || not (target ^. systemRobot) of True -> zoomRobots $ do - -- Cancel its CESK machine, and put it to sleep. + -- Cancel its CESK machine, and wake it up to ensure + -- it can do cleanup + run to completion. robotMap . at targetID . _Just . machine %= cancel - sleepForever targetID + activateRobot targetID return $ mkReturn () False -> throwError $ cmdExn c ["You are not authorized to halt that robot."] _ -> badConst @@ -942,14 +940,15 @@ let neighbor = find ((/= rid) . (^. robotID)) -- pick one other than ourself . sortOn ((manhattan `on` view planar) loc . (^. robotLocation)) -- prefer closer - $ robotsInArea loc 1 + . filter isInteractive + . robotsInArea loc 1 $ g ^. robotInfo -- all robots within Manhattan distance 1 return $ mkReturn neighbor MeetAll -> do loc <- use robotLocation rid <- use robotID g <- get @GameState - let neighborIDs = filter ((/= rid) . (^. robotID)) . robotsInArea loc 1 $ g ^. robotInfo + let neighborIDs = filter ((/= rid) . (^. robotID)) . filter isInteractive . robotsInArea loc 1 $ g ^. robotInfo return $ mkReturn neighborIDs Whoami -> case vs of [] -> do @@ -977,11 +976,8 @@ Case -> case vs of [VInj side v, kl, kr] -> return $ Out v s (FApp (bool kl kr side) : k) _ -> badConst - Fst -> case vs of - [VPair v _] -> return $ Out v s k - _ -> badConst - Snd -> case vs of - [VPair _ v] -> return $ Out v s k + Match -> case vs of + [VPair v1 v2, kp] -> return $ Out v1 s (FApp kp : FVArg v2 : k) _ -> badConst Try -> case vs of [c1, c2] -> return $ Out c1 s (FApp (VCApp Force []) : FExec : FTry c2 : k) @@ -1169,7 +1165,7 @@ . at (target ^. robotID) . traverse . machine - .= In giveInventory mempty emptyStore [FExec] + .= In giveInventory emptyEnv emptyStore [FExec] activateRobot $ target ^. robotID @@ -1226,6 +1222,36 @@ Format -> case vs of [v] -> return $ mkReturn $ prettyValue v _ -> badConst + Read -> case vs of + [VType ty, VText txt] -> case readValue ty txt of + Nothing -> raise Read ["Could not read", showT txt, "at type", prettyText ty] + Just v -> return (mkReturn v) + _ -> badConst + Print -> case vs of + [VText printableName, VText txt] -> do + printable <- ensureItem printableName "print" + (printable `hasProperty` Printable) + `holdsOrFail` ["You cannot print on", indefinite printableName <> "!"] + let newEntityName = printableName <> ": " <> txt + robotInventory %= delete printable + robotInventory %= insert (printable & entityName .~ newEntityName) + return $ mkReturn newEntityName + _ -> badConst + Erase -> case vs of + [VText printableName] -> do + toErase <- ensureItem printableName "erase" + let (baseName, _) = T.break (== ':') printableName + em <- use $ landscape . terrainAndEntities . entityMap + erased <- + lookupEntityName baseName em + `isJustOrFail` ["I've never heard of", indefiniteQ baseName <> "."] + (erased `hasProperty` Printable) + `holdsOrFail` ["You cannot erase", indefinite baseName <> "!"] + + robotInventory %= delete toErase + robotInventory %= insert erased + return $ mkReturn baseName + _ -> badConst Chars -> case vs of [VText t] -> return $ mkReturn $ T.length t _ -> badConst @@ -1255,10 +1281,40 @@ let msg = "The operator '$' should only be a syntactic sugar and removed in elaboration:\n" in throwError . Fatal $ msg <> badConstMsg where + doTeleport rid locUpdateFunc = do + -- Make sure the other robot exists and is close + target <- getRobotWithinTouch rid + -- either change current robot or one in robot map + let oldLoc = target ^. robotLocation + nextLoc = locUpdateFunc oldLoc + + onTarget rid $ do + checkMoveAhead nextLoc $ \case + PathBlockedBy _ -> Destroy + PathLiquid _ -> Destroy + updateRobotLocation oldLoc nextLoc + + -- Privileged robots can teleport without causing any + -- improbable effects. Unprivileged robots must be using an + -- infinite improbability drive, which can cause a random entity + -- to spawn near the target location. + omni <- isPrivilegedBot + unless omni $ do + let area = map (<$ nextLoc) $ getLocsInArea (nextLoc ^. planar) 5 + emptyLocs <- filterM (fmap isNothing . entityAt) area + randomLoc <- weightedChoice (const 1) emptyLocs + es <- uses (landscape . terrainAndEntities . entityMap) allEntities + randomEntity <- weightedChoice (const 1) es + case (randomLoc, randomEntity) of + (Just loc, Just e) -> updateEntityAt loc (const (Just e)) + _ -> return () + + return $ mkReturn () + doDrill d = do ins <- use equippedDevices - let equippedDrills = extantElemsWithCapability CDrill ins + let equippedDrills = extantElemsWithCapability (CExecute Drill) ins -- Heuristic: choose the drill with the more elaborate name. -- E.g. "metal drill" vs. "drill" preferredDrill = listToMaybe $ sortOn (Down . T.length . (^. entityName)) equippedDrills @@ -1348,8 +1404,6 @@ badConstMsg = T.unlines [ "Bad application of execConst:" - , T.pack (show c) - , T.pack (show vs) , prettyText (Out (VCApp c (reverse vs)) s k) ] @@ -1415,7 +1469,7 @@ return $ Out v s k else do time <- use $ temporal . ticks - return . (if remTime <= 1 then id else Waiting (addTicks (fromIntegral remTime) time)) $ + return . applyWhen (remTime > 1) (Waiting (addTicks (fromIntegral remTime) time)) $ Out v s (FImmediate c wf rf : k) where remTime = r ^. recipeTime @@ -1445,7 +1499,7 @@ return item - -- Check the required devices and inventory for running the given + -- Check the required devices and stocked inventory for running the given -- command on a target robot. This function is used in common by -- both 'Build' and 'Reprogram'. -- @@ -1546,14 +1600,16 @@ `holdsOr` Incapable fixI (R.Requirements (S.fromList capsWithNoDevice) S.empty M.empty) cmd -- Now, ensure there is at least one device available to be - -- equipped for each requirement. - let missingDevices = map snd . filter (null . fst) $ partitionedDevices + -- equipped for each requirement, and minimize the resulting + -- sets of device alternatives by removing any set which is a + -- superset of another. + let missingDevices = removeSupersets . S.fromList . map snd . filter (null . fst) $ partitionedDevices let IncapableFixWords fVerb fNoun = formatIncapableFix fixI null missingDevices `holdsOrFail` ( singularSubjectVerb subject "do" : "not have required " <> fNoun <> ", please" : fVerb <> ":" - : (("\n - " <>) . formatDevices <$> missingDevices) + : (("\n - " <>) . formatDevices <$> S.toList missingDevices) ) let minimalEquipSet = smallHittingSet (filter (S.null . S.intersection alreadyEquipped) (map fst partitionedDevices)) @@ -1603,8 +1659,11 @@ (mAch False) selfDestruct .= True - maybe (return ()) grantAchievementForRobot (mAch True) + forM_ (mAch True) grantAchievementForRobot + -- Try to move the current robot once cell in a specific direction, + -- checking for and applying any relevant effects (e.g. throwing an + -- exception if blocked, drowning in water, etc.) moveInDirection :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Heading -> m CESK moveInDirection orientation = do -- Figure out where we're going @@ -1616,27 +1675,29 @@ updateRobotLocation loc nextLoc return $ mkReturn () + -- Given a possible movement failure, apply a movement failure + -- handler to generate the appropriate effect. applyMoveFailureEffect :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Maybe MoveFailureMode -> MoveFailureHandler -> m () applyMoveFailureEffect maybeFailure failureHandler = - case maybeFailure of - Nothing -> return () - Just failureMode -> case failureHandler failureMode of - IgnoreFail -> return () - Destroy -> destroyIfNotBase $ \b -> case (b, failureMode) of - (True, PathLiquid _) -> Just RobotIntoWater -- achievement for drowning - _ -> Nothing - ThrowExn -> throwError . cmdExn c $ - case failureMode of - PathBlockedBy ent -> case ent of - Just e -> ["There is a", e ^. entityName, "in the way!"] - Nothing -> ["There is nothing to travel on!"] - PathLiquid e -> ["There is a dangerous liquid", e ^. entityName, "in the way!"] + forM_ maybeFailure $ \failureMode -> case failureHandler failureMode of + IgnoreFail -> return () + Destroy -> destroyIfNotBase $ \b -> case (b, failureMode) of + (True, PathLiquid _) -> Just RobotIntoWater -- achievement for drowning + (False, _) -> Just AttemptSelfDestructBase + _ -> Nothing + ThrowExn -> throwError . cmdExn c $ + case failureMode of + PathBlockedBy ent -> case ent of + Just e -> ["There is a", e ^. entityName, "in the way!"] + Nothing -> ["There is nothing to travel on!"] + PathLiquid e -> ["There is a dangerous liquid", e ^. entityName, "in the way!"] - -- Determine the move failure mode and apply the corresponding effect. + -- Check whether there is any failure in moving to the given + -- location, and apply the corresponding effect if so. checkMoveAhead :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Cosmic Location -> diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs b/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs --- a/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs +++ b/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs @@ -44,6 +44,7 @@ import Swarm.Game.Location import Swarm.Game.Robot import Swarm.Game.Robot.Walk +import Swarm.Game.Scenario.Topography.Terraform import Swarm.Game.State import Swarm.Game.Step.Path.Cache.DistanceLimit import Swarm.Game.Step.Path.Type @@ -51,7 +52,6 @@ import Swarm.Game.Step.RobotStepState import Swarm.Game.Step.Util.Inspect (robotWithID) import Swarm.Game.Universe (Cosmic (..), SubworldName) -import Swarm.Game.World.Modify import Swarm.Util (prependList, tails1) import Swarm.Util.RingBuffer qualified as RB diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs b/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs --- a/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs +++ b/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs @@ -11,31 +11,41 @@ import Swarm.Language.Capability data MoveFailureMode - = -- | If the robot has a path Whitelist, - -- then the absence of an entity could prevent walkability (represented by `PathBlockedBy Nothing`). + = -- | Can't move due to something blocking the path. Note that if + -- the robot has a path Whitelist, then the /absence/ of an entity + -- could block the path (represented by `PathBlockedBy + -- Nothing`). PathBlockedBy (Maybe Entity) - | PathLiquid Entity + | -- | Some liquid entity is in the path. + PathLiquid Entity -- | Pure logic used inside of --- 'Swarm.Game.Step.Util.checkMoveFailureUnprivileged' +-- 'Swarm.Game.Step.Util.checkMoveFailureUnprivileged'. Given a +-- (possibly empty) walkable entity whitelist or blacklist, and the +-- entity (or lack thereof) in the cell we are trying to move to, +-- determine whether there is some kind of movement failure. checkUnwalkable :: WalkabilityContext -> Maybe Entity -> Maybe MoveFailureMode checkUnwalkable (WalkabilityContext _ walkExceptions) Nothing = + -- If there's no entity in the path, we are blocked only if a + -- whitelist of walkable entities is specified case walkExceptions of Whitelist _ -> Just $ PathBlockedBy Nothing Blacklist _ -> Nothing checkUnwalkable (WalkabilityContext caps walkExceptions) (Just e) - -- robots can not walk through walls | isUnwalkableEntity = Just $ PathBlockedBy $ Just e - -- robots drown if they walk over liquid without boat + -- Robots drown if they walk over liquid without the Float capability | e `hasProperty` Liquid && CFloat `S.notMember` caps = Just $ PathLiquid e | otherwise = Nothing where eName = e ^. entityName + -- An entity blocks a robot if... isUnwalkableEntity = case walkExceptions of + -- ...it's not one of the whitelisted entities... Whitelist onlyWalkables -> eName `S.notMember` onlyWalkables + -- ...OR if it is inherently unwalkable, or is blacklisted. Blacklist unwalkables -> e `hasProperty` Unwalkable || eName `S.member` unwalkables diff --git a/src/swarm-engine/Swarm/Game/Step/Util.hs b/src/swarm-engine/Swarm/Game/Step/Util.hs --- a/src/swarm-engine/Swarm/Game/Step/Util.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util.hs @@ -9,13 +9,13 @@ -- Utilities for implementing robot commands. module Swarm.Game.Step.Util where -import Control.Applicative (Applicative (..)) import Control.Carrier.State.Lazy import Control.Effect.Error import Control.Effect.Lens import Control.Monad (forM_, guard, when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Control.Monad.Trans.State.Strict qualified as TS import Data.Array (bounds, (!)) import Data.IntMap qualified as IM import Data.Set qualified as S @@ -26,10 +26,11 @@ import Swarm.Game.Entity hiding (empty, lookup, singleton, union) import Swarm.Game.Exception import Swarm.Game.Location -import Swarm.Game.ResourceLoading (NameGenerator (..)) import Swarm.Game.Robot +import Swarm.Game.Scenario.Topography.Modify qualified as WM import Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking qualified as SRT import Swarm.Game.State +import Swarm.Game.State.Landscape (recognizerAutomatons) import Swarm.Game.State.Robot import Swarm.Game.State.Substate import Swarm.Game.Step.Path.Cache @@ -39,14 +40,14 @@ import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.Game.World.Coords -import Swarm.Game.World.Modify qualified as WM import Swarm.Language.Capability import Swarm.Language.Requirements.Type qualified as R import Swarm.Language.Syntax import Swarm.Language.Syntax.Direction (Direction) +import Swarm.ResourceLoading (NameGenerator (..)) import Swarm.Util hiding (both) import System.Random (UniformRange, uniformR) -import Prelude hiding (Applicative (..), lookup) +import Prelude hiding (lookup) deriveHeading :: HasRobotStepState sig m => Direction -> m Heading deriveHeading d = do @@ -61,6 +62,15 @@ let nextLoc = loc `offsetBy` newHeading (nextLoc,) <$> entityAt nextLoc +adaptGameState :: + Has (State GameState) sig m => + TS.State GameState b -> + m b +adaptGameState f = do + (newRecognizer, newGS) <- TS.runState f <$> get + put newGS + return newRecognizer + -- | Modify the entity (if any) at a given location. updateEntityAt :: (Has (State Robot) sig m, Has (State GameState) sig m) => @@ -76,8 +86,12 @@ currentTick <- use $ temporal . ticks myID <- use robotID zoomRobots $ wakeWatchingRobots myID currentTick cLoc - SRT.entityModified modType cLoc + structureRecognizer <- use $ landscape . recognizerAutomatons + oldRecognition <- use $ discovery . structureRecognition + newRecognition <- adaptGameState $ SRT.entityModified mtlEntityAt modType cLoc structureRecognizer oldRecognition + discovery . structureRecognition .= newRecognition + pcr <- use $ pathCaching . pathCachingRobots mapM_ (revalidatePathCache cLoc modType) $ IM.toList pcr @@ -162,8 +176,9 @@ -- * Moving --- | Make sure nothing is in the way. --- No exception for system robots +-- | Raw check whether moving to the given location causes any kind of +-- failure, with no special checks for system robots (see also +-- 'checkMoveFailure'). checkMoveFailureUnprivileged :: HasRobotStepState sig m => Cosmic Location -> @@ -173,8 +188,10 @@ wc <- use walkabilityContext return $ checkUnwalkable wc me --- | Make sure nothing is in the way. Note that system robots implicitly ignore --- and base throws on failure. +-- | Check whether moving to the given location causes any kind of +-- failure. Note that system robots have unrestricted movement and +-- never fail, but non-system robots have restricted movement even +-- in creative mode. checkMoveFailure :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureMode) checkMoveFailure nextLoc = do systemRob <- use systemRobot diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs --- a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -12,7 +12,6 @@ -- Helper functions for "Swarm.Game.Step.Const" commands module Swarm.Game.Step.Util.Command where -import Control.Applicative (Applicative (..)) import Control.Carrier.State.Lazy import Control.Carrier.Throw.Either (ThrowC, runThrow) import Control.Effect.Error @@ -24,6 +23,7 @@ import Data.List (find) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M +import Data.MonoidMap qualified as MM import Data.Sequence qualified as Seq import Data.Set (Set) import Data.Set qualified as S @@ -47,6 +47,7 @@ import Swarm.Game.Robot import Swarm.Game.Robot.Concrete import Swarm.Game.Robot.Walk (emptyExceptions) +import Swarm.Game.Scenario.Status (getScenarioPath) import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation) import Swarm.Game.State import Swarm.Game.State.Landscape @@ -63,8 +64,9 @@ import Swarm.Language.Syntax import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Log +import Swarm.Util (applyWhen) import System.Clock (TimeSpec) -import Prelude hiding (Applicative (..), lookup) +import Prelude hiding (lookup) data GrabbingCmd = Grab' @@ -98,19 +100,17 @@ Const -> m () ensureCanExecute c = - gets @Robot (constCapsFor c) >>= \case - Nothing -> pure () - Just cap -> do - isPrivileged <- isPrivilegedBot - -- Privileged robots can execute commands regardless - -- of equipped devices, and without expending - -- a capability's exercise cost. - unless isPrivileged $ do - robotCaps <- use robotCapabilities - let capProviders = M.lookup cap $ getMap robotCaps - case capProviders of - Nothing -> throwError $ Incapable FixByEquip (R.singletonCap cap) (TConst c) - Just rawCosts -> payExerciseCost c rawCosts + gets @Robot (constCapsFor c) >>= mapM_ \cap -> do + isPrivileged <- isPrivilegedBot + -- Privileged robots can execute commands regardless + -- of equipped devices, and without expending + -- a capability's exercise cost. + unless isPrivileged $ do + robotCaps <- use robotCapabilities + let capProviders = M.lookup cap $ getMap robotCaps + case capProviders of + Nothing -> throwError $ Incapable FixByEquip (R.singletonCap cap) (TConst c) + Just rawCosts -> payExerciseCost c rawCosts payExerciseCost :: ( Has (State Robot) sig m @@ -156,11 +156,10 @@ let isNearby = isNearbyOrExempt privileged myLoc f loc = - if not $ isNearby loc - then IS.delete rid - else id + applyWhen (not $ isNearby loc) $ + IS.delete rid - robotInfo . robotsWatching %= M.filter (not . IS.null) . M.mapWithKey f + robotInfo . robotsWatching %= MM.mapWithKey f verbedGrabbingCmd :: GrabbingCmd -> Text verbedGrabbingCmd = \case @@ -185,6 +184,7 @@ newlocWithPortal <- applyPortal newLoc rid <- use robotID zoomRobots $ do + -- wakeWatchingRobots? removeRobotFromLocationMap oldLoc rid addRobotToLocation rid newlocWithPortal modify (unsafeSetRobotLocation newlocWithPortal) @@ -212,14 +212,12 @@ True -> act False -> do mtgt <- use (robotInfo . robotMap . at rid) - case mtgt of - Nothing -> return () - Just tgt -> do - tgt' <- execState @Robot tgt act - zoomRobots $ - if tgt' ^. selfDestruct - then deleteRobot rid - else robotMap . ix rid .= tgt' + forM_ mtgt $ \tgt -> do + tgt' <- execState @Robot tgt act + zoomRobots $ + if tgt' ^. selfDestruct + then deleteRobot rid + else robotMap . ix rid .= tgt' -- | Enforces validity of the robot's privileged status to receive -- an achievement. @@ -261,7 +259,7 @@ %= M.insertWith (<>) a - (Attainment (GameplayAchievement a) scenarioPath currentTime) + (Attainment (GameplayAchievement a) (getScenarioPath <$> scenarioPath) currentTime) -- | Capabilities needed for a specific robot to evaluate or execute a -- constant. Right now, the only difference is whether the robot is @@ -269,11 +267,11 @@ -- be other exceptions added in the future. constCapsFor :: Const -> Robot -> Maybe Capability constCapsFor Move r - | r ^. robotHeavy = Just CMoveheavy + | r ^. robotHeavy = Just CMoveHeavy constCapsFor Backup r - | r ^. robotHeavy = Just CMoveheavy + | r ^. robotHeavy = Just CMoveHeavy constCapsFor Stride r - | r ^. robotHeavy = Just CMoveheavy + | r ^. robotHeavy = Just CMoveHeavy constCapsFor c _ = constCaps c -- | Requires that the target location is within one cell. @@ -292,13 +290,11 @@ updateDiscoveredEntities :: (HasRobotStepState sig m) => Entity -> m () updateDiscoveredEntities e = do allDiscovered <- use $ discovery . allDiscoveredEntities - if E.contains0plus e allDiscovered - then pure () - else do - let newAllDiscovered = E.insertCount 1 e allDiscovered - updateAvailableRecipes (newAllDiscovered, newAllDiscovered) e - updateAvailableCommands e - discovery . allDiscoveredEntities .= newAllDiscovered + unless (E.contains0plus e allDiscovered) $ do + let newAllDiscovered = E.insertCount 1 e allDiscovered + updateAvailableRecipes (newAllDiscovered, newAllDiscovered) e + updateAvailableCommands e + discovery . allDiscoveredEntities .= newAllDiscovered -- | Update the availableRecipes list. -- This implementation is not efficient: @@ -341,7 +337,7 @@ m () addWatchedLocation loc = do rid <- use robotID - robotInfo . robotsWatching %= M.insertWith (<>) loc (IS.singleton rid) + robotInfo . robotsWatching %= MM.adjust (IS.insert rid) loc -- | Give some entities from a parent robot (the robot represented by -- the ambient @State Robot@ effect) to a child robot (represented diff --git a/src/swarm-engine/Swarm/Game/Tick.hs b/src/swarm-engine/Swarm/Game/Tick.hs --- a/src/swarm-engine/Swarm/Game/Tick.hs +++ b/src/swarm-engine/Swarm/Game/Tick.hs @@ -5,33 +5,49 @@ module Swarm.Game.Tick ( TickNumber (..), addTicks, + formatTicks, ) where import Data.Aeson (FromJSON, ToJSON (..)) import Data.Aeson qualified as A +import Data.Bits (Bits (..)) import Data.Int (Int64) +import Data.List (intersperse) import GHC.Generics (Generic) import Prettyprinter (Pretty (..)) import Swarm.Util.JSON (optionsUnwrapUnary) import Swarm.Util.WindowedCounter (Offsettable (..)) +import Text.Printf -- | A newtype representing a count of ticks (typically since the -- start of a game). newtype TickNumber = TickNumber {getTickNumber :: Int64} deriving (Eq, Ord, Show, Read, Generic) +-- | Add an offset to a 'TickNumber'. +addTicks :: Int -> TickNumber -> TickNumber +addTicks i (TickNumber n) = TickNumber $ n + fromIntegral i + +-- | Format a ticks count as a hexadecimal clock. +formatTicks :: Bool -> TickNumber -> String +formatTicks showTicks (TickNumber t) = + mconcat $ + intersperse + ":" + [ printf "%x" (t `shiftR` 20) + , printf "%02x" ((t `shiftR` 12) .&. ((1 `shiftL` 8) - 1)) + , printf "%02x" ((t `shiftR` 4) .&. ((1 `shiftL` 8) - 1)) + ] + ++ if showTicks then [".", printf "%x" (t .&. ((1 `shiftL` 4) - 1))] else [] + instance ToJSON TickNumber where toJSON = A.genericToJSON optionsUnwrapUnary instance FromJSON TickNumber where parseJSON = A.genericParseJSON optionsUnwrapUnary --- | Add an offset to a 'TickNumber'. -addTicks :: Int -> TickNumber -> TickNumber -addTicks i (TickNumber n) = TickNumber $ n + fromIntegral i - instance Offsettable TickNumber where offsetBy = addTicks instance Pretty TickNumber where - pretty (TickNumber i) = pretty i + pretty = pretty . formatTicks True diff --git a/src/swarm-engine/Swarm/Game/Value.hs b/src/swarm-engine/Swarm/Game/Value.hs --- a/src/swarm-engine/Swarm/Game/Value.hs +++ b/src/swarm-engine/Swarm/Game/Value.hs @@ -12,12 +12,14 @@ import Data.Either.Extra (maybeToEither) import Data.Int (Int32) import Data.List (uncons) +import Data.List.NonEmpty qualified as NE import Data.Text (Text) import Linear (V2 (..)) import Swarm.Game.Entity import Swarm.Game.Location import Swarm.Game.Robot import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..)) +import Swarm.Game.Universe import Swarm.Language.Syntax.Direction import Swarm.Language.Value @@ -37,6 +39,9 @@ class Valuable a where asValue :: a -> Value +instance Valuable Value where + asValue = id + instance Valuable Int32 where asValue = VInt . fromIntegral @@ -52,6 +57,9 @@ instance Valuable Text where asValue = VText +instance Valuable SubworldName where + asValue = asValue . renderWorldName + instance Valuable () where asValue = const VUnit @@ -82,6 +90,9 @@ instance Valuable a => Valuable [a] where asValue = asValue . uncons + +instance Valuable a => Valuable (NE.NonEmpty a) where + asValue = asValue . NE.toList instance Valuable AreaDimensions where asValue (AreaDimensions w h) = asValue (w, h) diff --git a/src/swarm-engine/Swarm/Version.hs b/src/swarm-engine/Swarm/Version.hs deleted file mode 100644 --- a/src/swarm-engine/Swarm/Version.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Query current and upstream Swarm version. -module Swarm.Version ( - -- * PVP version - isSwarmReleaseTag, - version, - - -- ** Upstream release - tagToVersion, - upstreamReleaseVersion, - getNewerReleaseVersion, - NewReleaseFailure (..), -) where - -import Control.Exception (catch, displayException) -import Data.Aeson (Array, Value (..), (.:)) -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.Maybe (listToMaybe) -import Data.Text qualified as T -import Data.Version (Version (..), parseVersion, showVersion) -import Data.Yaml (ParseException, Parser, decodeEither', parseEither) -import GitHash (GitInfo, giBranch) -import Network.HTTP.Client ( - HttpException, - Request (requestHeaders), - Response (responseBody), - httpLbs, - newManager, - parseRequest, - ) -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Network.HTTP.Types (hUserAgent) -import Paths_swarm qualified -import Swarm.Util (failT, quote) -import Text.ParserCombinators.ReadP (readP_to_S) - --- $setup --- >>> import Data.Bifunctor (first) --- >>> import Data.Version (Version (..), parseVersion) --- >>> import Text.ParserCombinators.ReadP (readP_to_S) - --- | 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 == '.') - -version :: String -version = - let v = showVersion Paths_swarm.version - in if v == "0.0.0.1" then "pre-alpha version" else v - --- | Get the current upstream release version if any. -upstreamReleaseVersion :: IO (Either NewReleaseFailure String) -upstreamReleaseVersion = - catch - (either parseFailure getRelease . decodeResp <$> sendRequest) - (return . Left . queryFailure) - where - -- ------------------------------ - -- send request to GitHub API - sendRequest :: IO (Response BSL.ByteString) - sendRequest = do - manager <- newManager tlsManagerSettings - request <- parseRequest "https://api.github.com/repos/swarm-game/swarm/releases" - httpLbs - request {requestHeaders = [(hUserAgent, "swarm-game/swarm-swarmversion")]} - manager - -- ------------------------------ - -- get the latest actual release - getRelease :: Array -> Either NewReleaseFailure String - getRelease rs = - let ts = parseReleases rs - maybeRel = listToMaybe $ rights ts - in case maybeRel of - Nothing -> Left $ NoMainUpstreamRelease (lefts ts) - Just rel -> Right rel - -- ------------------------------ - -- pretty print failures - parseFailure :: ParseException -> Either NewReleaseFailure String - parseFailure e = Left . FailedReleaseQuery $ "Failure during response parsing: " <> displayException e - queryFailure :: HttpException -> NewReleaseFailure - queryFailure e = FailedReleaseQuery $ "Failure requesting GitHub releases: " <> displayException e - -- ------------------------------ - -- parsing helpers - decodeResp :: Response BSL.ByteString -> Either ParseException Array - decodeResp resp = decodeEither' (BS.pack . BSL.unpack $ responseBody resp) - parseReleases :: Array -> [Either String String] - parseReleases = map (parseEither parseRelease) . toList - -parseRelease :: Value -> Parser String -parseRelease = \case - Object o -> do - pre <- o .: "prerelease" - if pre - then fail "Not a real release!" - else do - t <- o .: "tag_name" - if isSwarmReleaseTag t - then return t - else failT ["The release", quote $ T.pack t, "is not main Swarm release!"] - _otherValue -> fail "The JSON release is not an Object!" - -data NewReleaseFailure where - FailedReleaseQuery :: String -> NewReleaseFailure - NoMainUpstreamRelease :: [String] -> NewReleaseFailure - OnDevelopmentBranch :: String -> NewReleaseFailure - OldUpstreamRelease :: Version -> Version -> NewReleaseFailure - -instance Show NewReleaseFailure where - show = \case - FailedReleaseQuery e -> "Failed to query upstream release: " <> e - NoMainUpstreamRelease fs -> - "No upstream releases found." - <> if null fs - then "" - else " Rejected:\n" <> unlines (zipWith ((<>) . show @Int) [1 ..] fs) - OnDevelopmentBranch br -> "Currently on development branch '" <> br <> "', skipping release query." - OldUpstreamRelease up my -> - "Upstream release '" - <> showVersion up - <> "' is not newer than mine ('" - <> showVersion my - <> "')." - --- | Read Swarm tag as Version. --- --- Swarm tags follow the PVP versioning scheme, so comparing them makes sense. --- --- >>> map (first versionBranch) $ readP_to_S parseVersion "0.1.0.0" --- [([0],".1.0.0"),([0,1],".0.0"),([0,1,0],".0"),([0,1,0,0],"")] --- >>> Version [0,0,0,1] [] < tagToVersion "0.1.0.0" --- True -tagToVersion :: String -> Version -tagToVersion = fst . last . readP_to_S parseVersion - --- | Drop trailing zeros from versions so that we can compare them. -normalize :: Version -> Version -normalize (Version ns tags) = Version (dropTrailing0 ns) tags - where - dropTrailing0 = reverse . dropWhile (== 0) . reverse - --- | Get a newer upstream release version. --- --- This function can fail if the current branch is not main, --- if there is no Internet connection or no newer release. -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 - Nothing -> (>>= getUpVer) <$> upstreamReleaseVersion - Just gi -> - if giBranch gi /= "main" - then return . Left . OnDevelopmentBranch $ giBranch gi - else (>>= getUpVer) <$> upstreamReleaseVersion - where - myVer :: Version - myVer = Paths_swarm.version - getUpVer :: String -> Either NewReleaseFailure String - getUpVer upTag = - let upVer = tagToVersion upTag - in if normalize myVer >= normalize upVer - then Left $ OldUpstreamRelease upVer myVer - else Right upTag diff --git a/src/swarm-lang/Swarm/Effect/Unify.hs b/src/swarm-lang/Swarm/Effect/Unify.hs --- a/src/swarm-lang/Swarm/Effect/Unify.hs +++ b/src/swarm-lang/Swarm/Effect/Unify.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -13,7 +14,9 @@ import Control.Algebra import Data.Kind (Type) import Data.Set (Set) +import Prettyprinter import Swarm.Language.Types hiding (Type) +import Swarm.Pretty (PrettyPrec (..), ppr, reportBug) -- | Data type representing available unification operations. data Unification (m :: Type -> Type) k where @@ -56,3 +59,20 @@ -- should never happen. UnexpandedRecTy :: TypeF UType -> UnificationError deriving (Show) + +instance PrettyPrec UnificationError where + prettyPrec _ = \case + Infinite x uty -> + vsep + [ "Encountered infinite type" <+> ppr x <+> "=" <+> ppr uty <> "." + , "Swarm will not infer recursive types; if you want a recursive type, add an explicit type annotation." + ] + UnifyErr ty1 ty2 -> + "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2 + UndefinedUserType ty -> + "Undefined user type" <+> ppr ty + UnexpandedRecTy ty -> + vsep + [ "Unexpanded recursive type" <+> ppr ty <+> "encountered in unifyF." + , reportBug + ] diff --git a/src/swarm-lang/Swarm/Effect/Unify/Fast.hs b/src/swarm-lang/Swarm/Effect/Unify/Fast.hs --- a/src/swarm-lang/Swarm/Effect/Unify/Fast.hs +++ b/src/swarm-lang/Swarm/Effect/Unify/Fast.hs @@ -20,7 +20,7 @@ import Control.Algebra import Control.Applicative (Alternative) -import Control.Carrier.Accum.FixedStrict (AccumC, runAccum) +import Control.Carrier.Accum.Strict (AccumC, runAccum) import Control.Carrier.Reader (ReaderC, runReader) import Control.Carrier.State.Strict (StateC, evalState) import Control.Carrier.Throw.Either (ThrowC, runThrow) @@ -42,6 +42,7 @@ import Swarm.Effect.Unify import Swarm.Effect.Unify.Common import Swarm.Language.Types hiding (Type) +import Swarm.Util.Effect (withThrow) import Prelude hiding (lookup) ------------------------------------------------------------ @@ -130,8 +131,7 @@ (Subst IntVar UType) ( StateC FreshVarCounter - ( ThrowC UnificationError m - ) + (ThrowC UnificationError m) ) ) a @@ -253,7 +253,10 @@ (UTyRec x ty, _) -> unify (unfoldRec x ty) ty2 (_, UTyRec x ty) -> unify ty1 (unfoldRec x ty) (UTyUser x1 tys, _) -> do - ty1' <- expandTydef x1 tys + ty1' <- + withThrow + (\(UnexpandedUserType _) -> UndefinedUserType (UTyUser x1 tys)) + (expandTydef x1 tys) unify ty1' ty2 (_, UTyUser {}) -> unify ty2 ty1 (Free t1, Free t2) -> Free <$> unifyF t1 t2 @@ -312,7 +315,7 @@ (TyConF {}, _) -> unifyErr -- Note that *type variables* are not the same as *unification variables*. -- Type variables must match exactly. - (TyVarF v1, TyVarF v2) -> case v1 == v2 of + (TyVarF _ v1, TyVarF _ v2) -> case v1 == v2 of True -> pure t1 False -> unifyErr (TyVarF {}, _) -> unifyErr diff --git a/src/swarm-lang/Swarm/Effect/Unify/Naive.hs b/src/swarm-lang/Swarm/Effect/Unify/Naive.hs --- a/src/swarm-lang/Swarm/Effect/Unify/Naive.hs +++ b/src/swarm-lang/Swarm/Effect/Unify/Naive.hs @@ -155,7 +155,7 @@ True -> compose <$> zipWithM unify ts1 ts2 False -> unifyErr (TyConF {}, _) -> unifyErr - (TyVarF v1, TyVarF v2) -> case v1 == v2 of + (TyVarF _ v1, TyVarF _ v2) -> case v1 == v2 of True -> return idS False -> unifyErr (TyVarF {}, _) -> unifyErr diff --git a/src/swarm-lang/Swarm/Language/Capability.hs b/src/swarm-lang/Swarm/Language/Capability.hs --- a/src/swarm-lang/Swarm/Language/Capability.hs +++ b/src/swarm-lang/Swarm/Language/Capability.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -11,6 +12,7 @@ module Swarm.Language.Capability ( Capability (..), capabilityName, + parseCapability, constCaps, constByCaps, ) where @@ -19,7 +21,9 @@ import Data.Aeson (FromJSONKey, ToJSONKey) import Data.Char (toLower) import Data.Data (Data) +import Data.Foldable (find) import Data.Hashable (Hashable) +import Data.List.Extra (enumerate) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Maybe (mapMaybe) @@ -28,151 +32,32 @@ import Data.Tuple (swap) import Data.Yaml import GHC.Generics (Generic) -import Swarm.Language.Syntax.Constants (Const (..), allConst) -import Swarm.Util (binTuples, failT) -import Text.Read (readMaybe) +import Generic.Data (FiniteEnumeration (..)) +import Prettyprinter (pretty) +import Swarm.Language.Syntax.Constants (Const (..), allConst, constInfo, syntax) +import Swarm.Pretty (PrettyPrec (..)) +import Swarm.Util (binTuples, failT, showEnum) import Witch (from) import Prelude hiding (lookup) -- | Various capabilities which robots can have. data Capability - = -- | Be powered, i.e. execute anything at all + = -- | Execute the command or function. + CExecute Const + | -- | Be powered, i.e. execute anything at all CPower - | -- | Execute the 'Move' command - CMove - | -- | Execute the 'Backup' command - CBackup - | -- | Execute the 'Volume' command - CVolume - | -- | Execute the 'Path' command - CPath - | -- | Execute the 'Push' command - CPush - | -- | Execute the 'Stride' command - CMovemultiple - | -- | Execute the 'Move' command for a heavy robot - CMoveheavy - | -- | Execute the 'Turn' command - -- - -- NOTE: using cardinal directions is separate 'COrient' capability - CTurn - | -- | Execute the 'Selfdestruct' command - CSelfdestruct - | -- | Execute the 'Grab' command - CGrab - | -- | Execute the 'Harvest' command - CHarvest - | -- | Execute the 'Sow' command - CSow - | -- | Execute the 'Ignite' command - CIgnite - | -- | Execute the 'Place' command - CPlace - | -- | Execute the 'Ping' command - CPing - | -- | Execute the 'Give' command - CGive - | -- | Execute the 'Equip' command - CEquip - | -- | Execute the 'Unequip' command - CUnequip - | -- | Execute the 'Make' command - CMake - | -- | Execute the 'Count' command - CCount - | -- | Execute the 'Scout' command. Reconnaissance along a line in a direction. - CRecondir - | -- | Execute the 'Build' command - CBuild - | -- | Execute the 'Salvage' command - CSalvage - | -- | Execute the 'Drill' command - CDrill - | -- | Execute the 'Waypoint' command - CWaypoint - | -- | Execute the 'Structure' and 'Floorplan' commands - CStructure - | -- | Execute the 'HasTag' command - CHastag - | -- | Execute the 'TagMembers' command - CTagmembers - | -- | Execute the 'Whereami' command - CSenseloc - | -- | Execute the 'Blocked' command - CSensefront - | -- | Execute the 'Ishere' and 'Isempty' commands - CSensehere - | -- | Execute the 'Detect' command - CDetectloc - | -- | Execute the 'Resonate' and 'Density' commands - CDetectcount - | -- | Execute the 'Sniff' command - CDetectdistance - | -- | Execute the 'Chirp' command - CDetectdirection - | -- | Execute the 'Watch' command - CWakeself - | -- | Execute the 'Scan' command - CScan - | -- | Execute the 'Random' command - CRandom - | -- | Execute the 'Appear' command - CAppear - | -- | Execute the 'Create' command - CCreate - | -- | Execute the 'Listen' command and passively log messages if also has 'CLog' - CListen - | -- | Execute the 'Log' command - CLog - | -- | Format values as text - CFormat - | -- | Split text into two pieces - CConcat - | -- | Join two text values into one - CSplit - | -- | Count the characters in a text value - CCharcount - | -- | Convert between characters/text and Unicode values - CCode - | -- | Don't drown in liquid + | -- | Allow a heavy robot to perform movements (e.g. move, backup and stride). + CMoveHeavy + | -- | Don't drown in liquid. CFloat - | -- | Evaluate conditional expressions - CCond - | -- | Negate boolean value - CNegation - | -- | Evaluate comparison operations - CCompare - | -- | Use cardinal direction constants. + | -- | Allow using absolute directions. COrient - | -- | Evaluate arithmetic operations - CArith | -- | Store and look up definitions in an environment CEnv | -- | Interpret lambda abstractions CLambda | -- | Enable recursive definitions CRecursion - | -- | Execute the 'Reprogram' command - CReprogram - | -- | Execute the `meet` and `meetAll` commands. - CMeet - | -- | Capability to introspect and see its own name - CWhoami - | -- | Capability to set its own name - CSetname - | -- | Capability to move unrestricted to any place - CTeleport - | -- | Capability to run commands atomically - CAtomic - | -- | Capability to execute swap (grab and place atomically at the same time). - CSwap - | -- | Capability to obtain absolute time, namely via the `time` command. - CTimeabs - | -- | Capability to utilize relative passage of time, namely via the `wait` command. - -- This is strictly weaker than "CTimeAbs". - CTimerel - | -- | Capability to execute `try`. - CTry | -- | Capability for working with sum types. CSum | -- | Capability for working with product types. @@ -181,21 +66,35 @@ CRecord | -- | Debug capability. CDebug - | -- | Capability to handle keyboard input. - CHandleinput - | -- | Capability to make other robots halt. - CHalt | -- | Capability to handle recursive types. CRectype | -- | God-like capabilities. For e.g. commands intended only for -- checking challenge mode win conditions, and not for use by -- players. CGod - deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data, FromJSONKey, ToJSONKey) + deriving (Eq, Ord, Show, Generic, Hashable, Data, FromJSONKey, ToJSONKey) + deriving (Enum, Bounded) via (FiniteEnumeration Capability) +instance PrettyPrec Capability where + prettyPrec _ c = pretty $ T.toLower (from (NE.tail $ showEnum c)) + +-- | Get the name of the capability for use in UI and YAML. capabilityName :: Capability -> Text -capabilityName = from @String . map toLower . drop 1 . show +capabilityName = \case + CExecute con -> case con of + Neg -> "neg" + _ -> syntax $ constInfo con + CMoveHeavy -> "move heavy robot" + cap -> from @String . map toLower . drop 1 $ show cap +-- | Parse the capability name - inverse of 'capabilityName'. +-- +-- >>> import Data.List.Extra (enumerate) +-- >>> all (\c -> Just c == parseCapability (capabilityName c)) enumerate +-- True +parseCapability :: Text -> Maybe Capability +parseCapability t = find (\c -> capabilityName c == T.toLower t) enumerate + instance ToJSON Capability where toJSON = String . capabilityName @@ -203,7 +102,7 @@ parseJSON = withText "Capability" tryRead where tryRead :: Text -> Parser Capability - tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of + tryRead t = case parseCapability t of Just c -> return c Nothing -> failT ["Unknown capability", t] @@ -212,141 +111,40 @@ constCaps = \case -- ---------------------------------------------------------------- -- Some built-in constants that don't require any special capability. - Noop -> Nothing AppF -> Nothing + Base -> Nothing + Equipped -> Nothing + Fail -> Nothing Force -> Nothing - Return -> Nothing + Has -> Nothing + Knows -> Nothing + Noop -> Nothing Parent -> Nothing - Base -> Nothing + Pure -> Nothing + Say -> Nothing -- speaking is natural to robots (unlike listening) Setname -> Nothing Undefined -> Nothing - Fail -> Nothing - Has -> Nothing - Equipped -> Nothing - -- speaking is natural to robots (unlike listening) - Say -> Nothing + Use -> Nothing -- Recipes alone shall dictate whether things can be "used" + View -> Nothing -- TODO: #17 should require equipping an antenna -- TODO: #495 -- the require command will be inlined once the Issue is fixed -- so the capabilities of the run commands will be checked instead Run -> Nothing - -- ---------------------------------------------------------------- - -- Some straightforward ones. - Listen -> Just CListen - Log -> Just CLog - Selfdestruct -> Just CSelfdestruct - Move -> Just CMove - Backup -> Just CBackup - Volume -> Just CVolume - Path -> Just CPath - Push -> Just CPush - Stride -> Just CMovemultiple - Turn -> Just CTurn - Grab -> Just CGrab - Harvest -> Just CHarvest - Sow -> Just CSow - Ignite -> Just CIgnite - Place -> Just CPlace - Ping -> Just CPing - Give -> Just CGive - Equip -> Just CEquip - Unequip -> Just CUnequip - Make -> Just CMake - Count -> Just CCount - If -> Just CCond - Blocked -> Just CSensefront - Scan -> Just CScan - Ishere -> Just CSensehere - Isempty -> Just CSensehere - Upload -> Just CScan - Build -> Just CBuild - Salvage -> Just CSalvage - Reprogram -> Just CReprogram - Meet -> Just CMeet - MeetAll -> Just CMeet - Drill -> Just CDrill - Use -> Nothing -- Recipes alone shall dictate whether things can be "used" - Neg -> Just CArith - Add -> Just CArith - Sub -> Just CArith - Mul -> Just CArith - Div -> Just CArith - Exp -> Just CArith - Whoami -> Just CWhoami - Self -> Just CWhoami - Swap -> Just CSwap - Atomic -> Just CAtomic - Instant -> Just CGod - Time -> Just CTimeabs - Wait -> Just CTimerel - Scout -> Just CRecondir - Whereami -> Just CSenseloc - Waypoint -> Just CWaypoint - Structure -> Just CStructure - Floorplan -> Just CStructure - HasTag -> Just CHastag - TagMembers -> Just CTagmembers - Detect -> Just CDetectloc - Resonate -> Just CDetectcount - Density -> Just CDetectcount - Sniff -> Just CDetectdistance - Chirp -> Just CDetectdirection - Watch -> Just CWakeself - Heading -> Just COrient - Key -> Just CHandleinput - InstallKeyHandler -> Just CHandleinput - Halt -> Just CHalt - -- ---------------------------------------------------------------- - -- Text operations - Format -> Just CFormat - Concat -> Just CConcat - Split -> Just CSplit - Chars -> Just CCharcount - CharAt -> Just CCode - ToChar -> Just CCode - -- ---------------------------------------------------------------- -- Some God-like abilities. As -> Just CGod + Create -> Just CGod + Instant -> Just CGod RobotNamed -> Just CGod RobotNumbered -> Just CGod - Create -> Just CGod Surveil -> Just CGod -- ---------------------------------------------------------------- - -- arithmetic - Eq -> Just CCompare - Neq -> Just CCompare - Lt -> Just CCompare - Gt -> Just CCompare - Leq -> Just CCompare - Geq -> Just CCompare - -- ---------------------------------------------------------------- - -- boolean logic - And -> Just CCond - Or -> Just CCond - Not -> Just CNegation - -- ---------------------------------------------------------------- - -- exceptions - Try -> Just CTry - -- ---------------------------------------------------------------- -- type-level arithmetic Inl -> Just CSum Inr -> Just CSum Case -> Just CSum - Fst -> Just CProd - Snd -> Just CProd -- TODO: #563 pair syntax (1,2,3...) should require CProd too - - -- ---------------------------------------------------------------- - -- Some additional straightforward ones, which however currently - -- cannot be used in classic mode since there is no craftable item - -- which conveys their capability. TODO: #26 - Teleport -> Just CTeleport -- Some space-time machine like Tardis? - Appear -> Just CAppear -- paint? - Random -> Just CRandom -- randomness device (with bitcoins)? - -- ---------------------------------------------------------------- - -- Some more constants which *ought* to have their own capability but - -- currently don't. - View -> Nothing -- TODO: #17 should require equipping an antenna - Knows -> Nothing + Match -> Just CProd + c -> Just (CExecute c) -- | Inverts the 'constCaps' mapping. constByCaps :: Map Capability (NE.NonEmpty Const) diff --git a/src/swarm-lang/Swarm/Language/Context.hs b/src/swarm-lang/Swarm/Language/Context.hs --- a/src/swarm-lang/Swarm/Language/Context.hs +++ b/src/swarm-lang/Swarm/Language/Context.hs @@ -1,91 +1,343 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- SPDX-License-Identifier: BSD-3-Clause -- -- Generic contexts (mappings from variables to other things, such as -- types, values, or capability sets) used throughout the codebase. +-- For example, while typechecking we use a context to store a mapping +-- from variables in scope to their types. As another example, at +-- runtime, robots store an 'Env' which contains several contexts, +-- mapping variables to things like their current value, any +-- requirements associated with using the variable, and so on. +-- +-- The implementation here goes to some effort to make it possible to +-- serialize and deserialize contexts so that sharing is preserved and +-- the encoding of serialized contexts does not blow up due to +-- repeated values. module Swarm.Language.Context where -import Control.Algebra (Has) +import Control.Algebra (Has, run) +import Control.Carrier.State.Strict (execState) import Control.Effect.Reader (Reader, ask, local) +import Control.Effect.State (State, get, modify) import Control.Lens.Empty (AsEmpty (..)) import Control.Lens.Prism (prism) -import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) +import Control.Monad (unless) +import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey, genericParseJSON, genericToJSON, withText) import Data.Data (Data) +import Data.Function (on) +import Data.Hashable +import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M -import Data.Text (Text) +import Data.Semigroup (Sum (..)) +import Data.Text qualified as T import GHC.Generics (Generic) -import Swarm.Util.JSON (optionsUnwrapUnary) +import Swarm.Pretty (PrettyPrec (..)) +import Swarm.Util (failT, showT) +import Swarm.Util.JSON (optionsMinimize) +import Swarm.Util.Yaml (FromJSONE, getE, liftE, parseJSONE) +import Text.Printf (printf) +import Text.Read (readMaybe) import Prelude hiding (lookup) --- | We use 'Text' values to represent variables. -type Var = Text +------------------------------------------------------------ +-- Context hash --- | A context is a mapping from variable names to things. -newtype Ctx t = Ctx {unCtx :: Map Var t} +-- | A context hash is a hash value used to identify contexts without +-- having to compare them for equality. Hash values are computed +-- homomorphically, so that two equal contexts will be guaranteed to +-- have the same hash value, even if they were constructed with a +-- different sequence of operations. +-- +-- The downside of this approach is that, /in theory/, there could +-- be hash collisions, that is, two different contexts which +-- nonetheless have the same hash value. However, this is extremely +-- unlikely. The benefit is that everything can be purely +-- functional, without the need to thread around some kind of +-- globally unique ID generation effect. +newtype CtxHash = CtxHash {getCtxHash :: Int} + deriving (Eq, Ord, Data, Generic, ToJSONKey, FromJSONKey) + deriving (Semigroup, Monoid) via Sum Int + deriving (Num) via Int + +instance Show CtxHash where + show (CtxHash h) = printf "%016x" h + +instance ToJSON CtxHash where + toJSON h = toJSON (show h) + +instance FromJSON CtxHash where + parseJSON = withText "hash" $ \t -> case readMaybe ("0x" ++ T.unpack t) of + Nothing -> fail "Could not parse CtxHash" + Just h -> pure (CtxHash h) + +-- | The hash for a single variable -> value binding. +singletonHash :: (Hashable v, Hashable t) => v -> t -> CtxHash +singletonHash x t = CtxHash $ hashWithSalt (hash x) t + +-- | The hash for an entire Map's worth of bindings. +mapHash :: (Hashable v, Hashable t) => Map v t -> CtxHash +mapHash = M.foldMapWithKey singletonHash + +------------------------------------------------------------ +-- Context structure + +-- | 'CtxF' represents one level of structure of a context: a context +-- is either empty, a singleton, or built via deletion or union. +data CtxF f v t + = CtxEmpty + | CtxSingle v t + | CtxDelete v t (f v t) + | CtxUnion (f v t) (f v t) deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic) -instance ToJSON t => ToJSON (Ctx t) where - toJSON = genericToJSON optionsUnwrapUnary +instance (ToJSON v, ToJSON t, ToJSON (f v t)) => ToJSON (CtxF f v t) where + toJSON = genericToJSON optionsMinimize -instance FromJSON t => FromJSON (Ctx t) where - parseJSON = genericParseJSON optionsUnwrapUnary +instance (FromJSON v, FromJSON t, FromJSON (f v t)) => FromJSON (CtxF f v t) where + parseJSON = genericParseJSON optionsMinimize +-- | Map over the recursive structure stored in a 'CtxF'. +restructureCtx :: (f v t -> g v t) -> CtxF f v t -> CtxF g v t +restructureCtx _ CtxEmpty = CtxEmpty +restructureCtx _ (CtxSingle x t) = CtxSingle x t +restructureCtx h (CtxDelete x t f1) = CtxDelete x t (h f1) +restructureCtx h (CtxUnion f1 f2) = CtxUnion (h f1) (h f2) + +-- | A 'CtxTree' is one possible representation of a context, +-- consisting of a structured record of the process by which a +-- context was constructed. This representation would be terrible +-- for doing efficient variable lookups, but it can be used to +-- efficiently serialize/deserialize the context while recovering +-- sharing. +-- +-- It stores a top-level hash of the context, along with a recursive +-- tree built via 'CtxF'. +data CtxTree v t = CtxTree CtxHash (CtxF CtxTree v t) + deriving (Eq, Functor, Foldable, Traversable, Data, Generic, ToJSON, FromJSON, Show) + +------------------------------------------------------------ +-- Contexts + +-- | A context is a mapping from variable names to things. We store +-- both a 'Map' (for efficient lookup) as well as a 'CtxTree' (for +-- sharing-aware serializing/deserializing). +data Ctx v t = Ctx {unCtx :: Map v t, ctxStruct :: CtxTree v t} + deriving (Functor, Traversable, Data, Generic) + +-- | Get the top-level hash of a context. +ctxHash :: Ctx v t -> CtxHash +ctxHash (Ctx _ (CtxTree h _)) = h + +instance Show (Ctx v t) where + -- An auto-derived, naive Show instance blows up as it loses all + -- sharing, so have `show` simply output a placeholder. + show _ = "" + +-- | Compare contexts for equality just by comparing their hashes. +instance Eq (Ctx v t) where + (==) = (==) `on` ctxHash + +instance (Hashable v, Hashable t) => Hashable (Ctx v t) where + hash = getCtxHash . ctxHash + hashWithSalt s = hashWithSalt s . getCtxHash . ctxHash + +instance Foldable (Ctx v) where + foldMap f = foldMap f . unCtx + +-- | Rebuild a complete 'Ctx' from a 'CtxTree'. +ctxFromTree :: Ord v => CtxTree v t -> Ctx v t +ctxFromTree tree = Ctx (varMap tree) tree + where + varMap (CtxTree _ s) = case s of + CtxEmpty -> M.empty + CtxSingle x t -> M.singleton x t + CtxDelete x _ s1 -> M.delete x (varMap s1) + CtxUnion s1 s2 -> varMap s2 `M.union` varMap s1 + +-- | "Roll up" one level of context structure while building a new +-- top-level Map and computing an appropriate top-level hash. +-- +-- In other words, the input of type @CtxF Ctx t@ represents a +-- context where the topmost level of structure is split out by +-- itself as 'CtxF', with the rest of the recursive structure stored +-- in the embedded 'Ctx' values. 'rollCtx' takes the single level +-- of structure with recursive subtrees and "rolls them up" into one +-- recursive tree. +rollCtx :: (Ord v, Hashable v, Hashable t) => CtxF Ctx v t -> Ctx v t +rollCtx s = Ctx m (CtxTree h (restructureCtx ctxStruct s)) + where + (m, h) = case s of + CtxEmpty -> (M.empty, 0) + CtxSingle x t -> (M.singleton x t, singletonHash x t) + CtxDelete x _ (Ctx m1 (CtxTree h1 _)) -> case M.lookup x m1 of + Nothing -> (m1, h1) + Just t' -> (M.delete x m1, h1 - singletonHash x t') + CtxUnion (Ctx m1 (CtxTree h1 _)) (Ctx m2 (CtxTree h2 _)) -> (m2 `M.union` m1, h') + where + -- `Data.Map.intersection l r` returns a map with common keys, + -- but values from `l`. The values in m1 are the ones we want + -- to subtract from the hash, since they are the ones that will + -- be overwritten. + overwritten = M.intersection m1 m2 + h' = h1 + h2 - mapHash overwritten + +------------------------------------------------------------ +-- Context instances + +-- | Serialize a context simply as its hash; we assume that a +-- top-level CtxMap has been seralized somewhere, from which we can +-- recover this context by looking it up. +instance ToJSON (Ctx v t) where + toJSON = toJSON . ctxHash + +-- | Deserialize a context. We expect to see a hash, and look it up +-- in the provided CtxMap. +instance Ord v => FromJSONE (CtxMap CtxTree v t) (Ctx v t) where + parseJSONE v = do + h <- liftE $ parseJSON @CtxHash v + m <- getE + case getCtx h m of + Nothing -> failT ["Encountered unknown context hash", showT h] + Just ctx -> pure ctx + +instance (PrettyPrec t) => PrettyPrec (Ctx v t) where + prettyPrec _ _ = "" + -- | The semigroup operation for contexts is /right/-biased union. -instance Semigroup (Ctx t) where +instance (Ord v, Hashable v, Hashable t) => Semigroup (Ctx v t) where (<>) = union -instance Monoid (Ctx t) where +instance (Ord v, Hashable v, Hashable t) => Monoid (Ctx v t) where mempty = empty mappend = (<>) -instance AsEmpty (Ctx t) where +instance AsEmpty (Ctx v t) where _Empty = prism (const empty) isEmpty where - isEmpty (Ctx c) - | M.null c = Right () - | otherwise = Left (Ctx c) + isEmpty c + | M.null (unCtx c) = Right () + | otherwise = Left c +------------------------------------------------------------ +-- Context operations + -- | The empty context. -empty :: Ctx t -empty = Ctx M.empty +empty :: Ctx v t +-- We could also define empty = rollCtx CtxEmpty but that would introduce an +-- unnecessary Hashable t constraint. +empty = Ctx M.empty (CtxTree mempty CtxEmpty) -- | A singleton context. -singleton :: Var -> t -> Ctx t -singleton x t = Ctx (M.singleton x t) +singleton :: (Ord v, Hashable v, Hashable t) => v -> t -> Ctx v t +singleton x t = rollCtx $ CtxSingle x t +-- | Create a 'Ctx' from a 'Map'. +fromMap :: (Ord v, Hashable v, Hashable t) => Map v t -> Ctx v t +fromMap m = case NE.nonEmpty (M.assocs m) of + Nothing -> empty + Just ne -> foldr1 union (NE.map (uncurry singleton) ne) + -- | Look up a variable in a context. -lookup :: Var -> Ctx t -> Maybe t -lookup x (Ctx c) = M.lookup x c +lookup :: Ord v => v -> Ctx v t -> Maybe t +lookup x = M.lookup x . unCtx -- | Look up a variable in a context in an ambient Reader effect. -lookupR :: Has (Reader (Ctx t)) sig m => Var -> m (Maybe t) +lookupR :: (Ord v, Has (Reader (Ctx v t)) sig m) => v -> m (Maybe t) lookupR x = lookup x <$> ask -- | Delete a variable from a context. -delete :: Var -> Ctx t -> Ctx t -delete x (Ctx c) = Ctx (M.delete x c) +delete :: (Ord v, Hashable v, Hashable t) => v -> Ctx v t -> Ctx v t +delete x ctx@(Ctx m _) = case M.lookup x m of + Nothing -> ctx + Just t -> rollCtx $ CtxDelete x t ctx -- | Get the list of key-value associations from a context. -assocs :: Ctx t -> [(Var, t)] +assocs :: Ctx v t -> [(v, t)] assocs = M.assocs . unCtx +-- | Get the list of bound variables from a context. +vars :: Ctx v t -> [v] +vars = M.keys . unCtx + -- | Add a key-value binding to a context (overwriting the old one if -- the key is already present). -addBinding :: Var -> t -> Ctx t -> Ctx t -addBinding x t (Ctx c) = Ctx (M.insert x t c) +addBinding :: (Ord v, Hashable v, Hashable t) => v -> t -> Ctx v t -> Ctx v t +addBinding x t ctx = ctx `union` singleton x t -- | /Right/-biased union of contexts. -union :: Ctx t -> Ctx t -> Ctx t -union (Ctx c1) (Ctx c2) = Ctx (c2 `M.union` c1) +union :: (Ord v, Hashable v, Hashable t) => Ctx v t -> Ctx v t -> Ctx v t +union ctx1 ctx2 = rollCtx $ CtxUnion ctx1 ctx2 -- | Locally extend the context with an additional binding. -withBinding :: Has (Reader (Ctx t)) sig m => Var -> t -> m a -> m a +withBinding :: (Has (Reader (Ctx v t)) sig m, Ord v, Hashable v, Hashable t) => v -> t -> m a -> m a withBinding x ty = local (addBinding x ty) -- | Locally extend the context with an additional context of -- bindings. -withBindings :: Has (Reader (Ctx t)) sig m => Ctx t -> m a -> m a +withBindings :: (Has (Reader (Ctx v t)) sig m, Ord v, Hashable v, Hashable t) => Ctx v t -> m a -> m a withBindings ctx = local (`union` ctx) + +------------------------------------------------------------ +-- Context serializing/deserializing + +-- | A 'CtxMap' maps context hashes to context structures. Those +-- structures could either be complete context trees, or just a +-- single level of structure containing more hashes. +type CtxMap f v t = Map CtxHash (CtxF f v t) + +-- | Reconstitute the context corresponding to a particular hash, by +-- looking it up in a context map. +getCtx :: Ord v => CtxHash -> CtxMap CtxTree v t -> Maybe (Ctx v t) +getCtx h m = ctxFromTree . CtxTree h <$> M.lookup h m + +-- | Turn a context into a context map containing every subtree of its +-- structure. +toCtxMap :: Ord v => Ctx v t -> CtxMap CtxTree v t +toCtxMap (Ctx m s) = run $ execState M.empty (buildCtxMap m s) + +-- | Build a context map by keeping track of the incrementally built +-- map in a state effect, and traverse the given context structure +-- to add all subtrees to the map---but, of course, stopping without +-- recursing further whenever we see a hash that is already in the +-- map. +buildCtxMap :: + forall v t m sig. + (Ord v, Has (State (CtxMap CtxTree v t)) sig m) => + Map v t -> + CtxTree v t -> + m () +buildCtxMap m (CtxTree h s) = do + cm <- get @(CtxMap CtxTree v t) + unless (h `M.member` cm) $ do + modify (M.insert h s) + case s of + CtxEmpty -> pure () + CtxSingle {} -> pure () + CtxDelete x t s1 -> buildCtxMap (M.insert x t m) s1 + CtxUnion s1 s2 -> buildCtxMap m s1 *> buildCtxMap m s2 + +newtype ConstHash v t = ConstHash CtxHash + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | "Dehydrate" a context map by replacing the actual context trees +-- with single structure layers containing only hashes. A +-- dehydrated context map is very suitable for serializing, since it +-- makes sharing completely explicit---even if a given context is +-- referenced multiple times, the references are simply hash values, +-- and the context is stored only once, under its hash. +dehydrate :: CtxMap CtxTree v t -> CtxMap ConstHash v t +dehydrate = M.map (restructureCtx (\(CtxTree h1 _) -> ConstHash h1)) + +-- | "Rehydrate" a dehydrated context map by replacing every hash with +-- an actual context structure. We do this by building the result +-- as a lazy, recursive map, replacing each hash by the result we +-- get when looking it up in the map being built. A context which +-- is referenced multiple times will thus be shared in memory. +rehydrate :: CtxMap ConstHash v t -> CtxMap CtxTree v t +rehydrate m = m' + where + m' = M.map (restructureCtx (\(ConstHash h) -> CtxTree h (m' M.! h))) m diff --git a/src/swarm-lang/Swarm/Language/Elaborate.hs b/src/swarm-lang/Swarm/Language/Elaborate.hs --- a/src/swarm-lang/Swarm/Language/Elaborate.hs +++ b/src/swarm-lang/Swarm/Language/Elaborate.hs @@ -6,7 +6,6 @@ -- Term elaboration which happens after type checking. module Swarm.Language.Elaborate where -import Control.Applicative ((<|>)) import Control.Lens (transform, (^.)) import Swarm.Language.Syntax @@ -46,11 +45,11 @@ -- Eventually, once requirements analysis is part of typechecking, -- we'll infer them both at typechecking time then fill them in -- during elaboration here. - SLet ls r x mty mreq t1 t2 -> - let mty' = case ls of - LSDef -> mty <|> Just (t1 ^. sType) + SLet ls r x mty _ mreq t1 t2 -> + let mpty = case ls of + LSDef -> Just (t1 ^. sType) LSLet -> Nothing - in SLet ls r x mty' mreq t1 t2 + in SLet ls r x mty mpty mreq t1 t2 SBind x (Just ty) _ mreq c1 c2 -> SBind x Nothing (Just ty) mreq c1 c2 -- Rewrite @f $ x@ to @f x@. SApp (Syntax' _ (SApp (Syntax' _ (TConst AppF) _ _) l) _ _) r -> SApp l r @@ -62,16 +61,16 @@ insertSuspend :: Term -> Term insertSuspend t = case t of -- Primitive things which have type Cmd Unit: p => (p ; suspend ()) - TRequireDevice {} -> thenSuspend TRequire {} -> thenSuspend + TStock {} -> thenSuspend TRequirements {} -> thenSuspend -- Recurse through def, tydef, bind, and annotate. - TLet ls r x mty mreq t1 t2 -> TLet ls r x mty mreq t1 (insertSuspend t2) + TLet ls r x mty mpty mreq t1 t2 -> TLet ls r x mty mpty mreq t1 (insertSuspend t2) TTydef x pty mtd t1 -> TTydef x pty mtd (insertSuspend t1) TBind mx mty mreq c1 c2 -> TBind mx mty mreq c1 (insertSuspend c2) TAnnotate t1 ty -> TAnnotate (insertSuspend t1) ty - -- Replace return or noop with suspend - TApp (TConst Return) t1 -> TSuspend t1 + -- Replace pure or noop with suspend + TApp (TConst Pure) t1 -> TSuspend t1 TConst Noop -> TSuspend TUnit -- Anything else: p => (__res__ <- p; suspend __res__) -- diff --git a/src/swarm-lang/Swarm/Language/Format.hs b/src/swarm-lang/Swarm/Language/Format.hs --- a/src/swarm-lang/Swarm/Language/Format.hs +++ b/src/swarm-lang/Swarm/Language/Format.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -8,20 +10,26 @@ import Control.Applicative ((<|>)) import Control.Lens ((&), (.~)) +import Data.Foldable (foldl') +import Data.Set qualified as S +import Data.Set.Lens (setOf) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Prettyprinter import Prettyprinter.Render.Text qualified as RT import Swarm.Language.Parser (readTerm') -import Swarm.Language.Parser.Core (LanguageVersion, defaultParserConfig, languageVersion) -import Swarm.Language.Pretty +import Swarm.Language.Parser.Core (LanguageVersion (..), defaultParserConfig, languageVersion) +import Swarm.Language.Parser.QQ (astQ) +import Swarm.Language.Syntax +import Swarm.Pretty (ppr) import Swarm.Util ((?)) import System.Console.Terminal.Size qualified as Term import System.Exit (exitFailure) import System.IO (stderr) import Text.Megaparsec.Error (errorBundlePretty) import Witch (into) +import Prelude hiding (Foldable (..)) -- | From where should the input be taken? data FormatInput = Stdin | InputFile FilePath @@ -67,9 +75,27 @@ formatSwarm (FormatConfig _ _ mWidth ver) content = case readTerm' cfg content of Right Nothing -> Right "" Right (Just ast) -> - let mkOpt w = LayoutOptions (AvailablePerLine w 1.0) + let ast' = case ver of + SwarmLang0_6 -> addProjections_v7 ast + _ -> ast + mkOpt w = LayoutOptions (AvailablePerLine w 1.0) opt = (mkOpt <$> mWidth) ? defaultLayoutOptions - in Right . RT.renderStrict . layoutPretty opt $ ppr ast + in Right . RT.renderStrict . layoutPretty opt $ ppr ast' Left e -> Left (into @Text $ errorBundlePretty e) where cfg = defaultParserConfig & languageVersion .~ ver + +-- | Version 0.6 of Swarm had keywords 'fst' and 'snd'; version 0.7 +-- has 'match' instead. Add definitions of 'fst' and 'snd' if the AST +-- contains free variables with those names. +addProjections_v7 :: Syntax -> Syntax +addProjections_v7 ast = foldl' addDefn ast (reverse $ S.toList freeProjs) + where + -- Any free occurrences of 'fst' or 'snd'? + freeProjs = setOf freeVarsV ast `S.intersection` S.fromList ["fst", "snd"] + + addDefn :: Syntax -> Var -> Syntax + addDefn rest = \case + "fst" -> [astQ| def fst = \p. match p (\a. \_. a) end; $syn:rest |] + "snd" -> [astQ| def snd = \p. match p (\_. \b. b) end; $syn:rest |] + _ -> rest diff --git a/src/swarm-lang/Swarm/Language/JSON.hs b/src/swarm-lang/Swarm/Language/JSON.hs --- a/src/swarm-lang/Swarm/Language/JSON.hs +++ b/src/swarm-lang/Swarm/Language/JSON.hs @@ -11,10 +11,10 @@ import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON, withText) import Data.Aeson qualified as Ae import Swarm.Language.Pipeline (processTermEither) -import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax (Term) import Swarm.Language.Syntax.Pattern (Syntax, TSyntax) -import Swarm.Language.Value (Env, Value) +import Swarm.Language.Value (Env, Value (..)) +import Swarm.Pretty (prettyText) import Swarm.Util.JSON (optionsMinimize) import Witch (into) @@ -24,16 +24,56 @@ instance ToJSON TSyntax where toJSON = Ae.String . prettyText -instance FromJSON Term -instance FromJSON Syntax -instance ToJSON Term -instance ToJSON Syntax +instance FromJSON Term where + parseJSON = genericParseJSON optionsMinimize +instance FromJSON Syntax where + parseJSON = genericParseJSON optionsMinimize + +instance ToJSON Term where + toJSON = genericToJSON optionsMinimize + +instance ToJSON Syntax where + toJSON = genericToJSON optionsMinimize + instance ToJSON Value where toJSON = genericToJSON optionsMinimize -instance FromJSON Value where - parseJSON = genericParseJSON optionsMinimize +-- TODO (#2213): Craft some appropriate FromJSONE instances for things +-- like Value and Env. Below is an early experiment. -deriving instance FromJSON Env -deriving instance ToJSON Env +-- instance FromJSONE (CtxMap CtxTree t) Value where +-- parseJSONE = withObjectE "Value" $ \v -> case Ae.toList v of +-- [("VUnit", _)] -> pure VUnit +-- [("VInt", n)] -> VInt <$> liftE (parseJSON n) +-- [("VText", t)] -> VText <$> liftE (parseJSON t) +-- [("VInj", Ae.Array (V.toList -> [i, x]))] -> VInj <$> liftE (parseJSON i) <*> parseJSONE x +-- [("VPair", Ae.Array (V.toList -> [v1, v2]))] -> VPair <$> parseJSONE v1 <*> parseJSONE v2 +-- [("VClo", Ae.Array (V.toList -> [x, t, e]))] -> +-- VClo <$> liftE (parseJSON x) <*> liftE (parseJSON t) <*> parseJSONE e +-- [("VCApp", Ae.Array (V.toList -> [c, vs]))] -> +-- VCApp <$> liftE (parseJSON c) <*> parseJSONE vs +-- [("VBind", Ae.Array (V.toList -> [x, ty, r, t1, t2, e]))] -> +-- VBind +-- <$> liftE (parseJSON x) +-- <*> liftE (parseJSON ty) +-- <*> liftE (parseJSON r) +-- <*> liftE (parseJSON t1) +-- <*> liftE (parseJSON t2) +-- <*> parseJSONE e +-- [("VDelay", Ae.Array (V.toList -> [t, e]))] -> +-- VDelay <$> liftE (parseJSON t) <*> parseJSONE e +-- [("VRef", n)] -> VRef <$> liftE (parseJSON n) +-- [("VIndir", n)] -> VIndir <$> liftE (parseJSON n) +-- [("VRcd", m)] -> VRcd <$> parseJSONE m +-- [("VKey", k)] -> VKey <$> liftE (parseJSON k) +-- [("VRequirements", Ae.Array (V.toList -> [txt, t, e]))] -> +-- VRequirements <$> liftE (parseJSON txt) <*> liftE (parseJSON t) <*> parseJSONE e +-- [("VSuspend", Ae.Array (V.toList -> [t, e]))] -> +-- VSuspend <$> liftE (parseJSON t) <*> parseJSONE e +-- [("VExc", _)] -> pure VExc +-- [("VBlackhole", _)] -> pure VBlackhole +-- _ -> fail "parseJSONE: Unable to parse Value" + +instance ToJSON Env where + toJSON = genericToJSON optionsMinimize diff --git a/src/swarm-lang/Swarm/Language/Key.hs b/src/swarm-lang/Swarm/Language/Key.hs --- a/src/swarm-lang/Swarm/Language/Key.hs +++ b/src/swarm-lang/Swarm/Language/Key.hs @@ -20,6 +20,7 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Foldable (asum) +import Data.Hashable (Hashable) import Data.Kind qualified import Data.List (sort, (\\)) import Data.Set (Set) @@ -37,10 +38,13 @@ ------------------------------------------------------------ -- Parsing +deriving instance Hashable V.Modifier +deriving instance Hashable V.Key + -- | A keyboard input, represented as a key + modifiers. Invariant: -- the modifier list is always sorted. data KeyCombo = KeyCombo V.Key [V.Modifier] - deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + deriving (Eq, Ord, Show, Generic, Hashable, FromJSON, ToJSON) deriving instance FromJSON V.Key deriving instance FromJSON V.Modifier diff --git a/src/swarm-lang/Swarm/Language/Kindcheck.hs b/src/swarm-lang/Swarm/Language/Kindcheck.hs --- a/src/swarm-lang/Swarm/Language/Kindcheck.hs +++ b/src/swarm-lang/Swarm/Language/Kindcheck.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- Kind checking for the Swarm language. +-- Kind checking + type name resolution for the Swarm language. module Swarm.Language.Kindcheck ( KindError (..), - checkPolytypeKind, - checkKind, + processPolytype, + processType, ) where import Control.Algebra (Has) @@ -13,8 +16,53 @@ import Control.Effect.Throw (Throw, throwError) import Control.Monad.Extra (unlessM) import Data.Fix (Fix (..)) +import Prettyprinter (hsep, nest, pretty, vsep, (<+>)) import Swarm.Language.Types +import Swarm.Pretty (PrettyPrec (..), ppr) +import Swarm.Util (number) +import Swarm.Util.Effect (withThrow) +------------------------------------------------------------ +-- Type processing + +-- | Process a polytype, by doing name resolution and kind checking, +-- and returning an appropriate 'TydefInfo' record to be used in the +-- case of a type definition. +processPolytype :: (Has (Reader TDCtx) sig m, Has (Throw KindError) sig m) => Polytype -> m TydefInfo +processPolytype pty@(unPoly -> (xs, _)) = do + pty' <- traverse processType pty + pure $ TydefInfo pty' (Arity $ length xs) + +-- | Process a type by doing name resolution and kind checking. +processType :: (Has (Reader TDCtx) sig m, Has (Throw KindError) sig m) => Type -> m Type +processType ty = do + ty' <- resolveTydefs ty + checkKind ty' + pure ty' + +------------------------------------------------------------ +-- Tydef name resolution + +-- | Name resolution for user-defined type names: for each +-- user-defined type name found anywhere in the type, resolve it to +-- the correct version number depending on what is in scope, by +-- calling 'resolveUserTy'. +resolveTydefs :: Has (Reader TDCtx) sig m => Type -> m Type +resolveTydefs (Fix tyF) = + Fix <$> case tyF of + TyConF tc tys -> do + tc' <- case tc of + TCUser u -> TCUser <$> resolveUserTy u + _ -> pure tc + TyConF tc' <$> mapM resolveTydefs tys + TyRcdF m -> TyRcdF <$> mapM resolveTydefs m + TyRecF x t -> TyRecF x <$> resolveTydefs t + TyVarF {} -> pure tyF + TyRecVarF {} -> pure tyF + +------------------------------------------------------------ +-- Kind checking + -- | Kind checking errors that can occur. data KindError = -- | A type constructor expects n arguments, but was given these @@ -30,9 +78,33 @@ VacuousRecTy Var Type deriving (Eq, Show) --- | Check that a polytype is well-kinded. -checkPolytypeKind :: (Has (Reader TDCtx) sig m, Has (Throw KindError) sig m) => Polytype -> m TydefInfo -checkPolytypeKind pty@(Forall xs t) = TydefInfo pty (Arity $ length xs) <$ checkKind t +instance PrettyPrec KindError where + prettyPrec _ = \case + ArityMismatch c a tys -> + nest 2 . vsep $ + [ "Kind error:" + , hsep + [ ppr c + , "requires" + , pretty a + , "type" + , pretty (number a "argument" <> ",") + , "but was given" + , pretty (length tys) + ] + ] + ++ ["in the type:" <+> ppr (TyConApp c tys) | not (null tys)] + UndefinedTyCon tc _ty -> "Undefined type" <+> ppr tc + TrivialRecTy x ty -> + nest 2 . vsep $ + [ "Encountered trivial recursive type" <+> ppr (TyRec x ty) + , "Did you forget to use" <+> ppr x <+> "in the body of the type?" + ] + VacuousRecTy x ty -> + nest 2 . vsep $ + [ "Encountered vacuous recursive type" <+> ppr (TyRec x ty) + , "Recursive types must be productive, i.e. must not expand to themselves." + ] -- | Check that a type is well-kinded. For now, we don't allow -- higher-kinded types, *i.e.* all kinds will be of the form @Type @@ -57,7 +129,7 @@ Just a -> case compare (length tys) a of EQ -> mapM_ checkKind tys _ -> throwError $ ArityMismatch c a tys - TyVarF _ -> return () + TyVarF _ _ -> return () TyRcdF m -> mapM_ checkKind m TyRecF x t -> do -- It's important to call checkKind first, to rule out undefined @@ -66,7 +138,7 @@ -- index 0 in the body. This doesn't affect the checking but it -- does ensure that error messages will use the variable name and -- not de Bruijn indices. - checkKind (substRec (TyVarF x) t NZ) + checkKind (substRec (TyVarF x x) t NZ) -- Now check that the recursive type is well-formed. We call this -- with the *unsubstituted* t because the check will be looking -- for de Bruijn variables specifically. @@ -89,16 +161,23 @@ -- | Check whether a type contains a specific bound recursive type -- variable. -containsVar :: Has (Reader TDCtx) sig m => Nat -> Type -> m Bool -containsVar i (Fix tyF) = case tyF of +containsVar :: + (Has (Reader TDCtx) sig m, Has (Throw KindError) sig m) => + Nat -> + Type -> + m Bool +containsVar i ty@(Fix tyF) = case tyF of TyRecVarF j -> pure (i == j) TyVarF {} -> pure False TyConF (TCUser u) tys -> do - ty' <- expandTydef u tys + ty' <- + withThrow + (\(UnexpandedUserType _) -> UndefinedTyCon (TCUser u) ty) + (expandTydef u tys) containsVar i ty' TyConF _ tys -> or <$> mapM (containsVar i) tys TyRcdF m -> or <$> mapM (containsVar i) m - TyRecF _ ty -> containsVar (NS i) ty + TyRecF _ ty' -> containsVar (NS i) ty' -- | @nonVacuous ty@ checks that the recursive type @rec x. ty@ is -- non-vacuous, /i.e./ that it doesn't look like @rec x. x@. Put @@ -109,18 +188,25 @@ -- like @rec x. x@ since we must also (1) expand type aliases and -- (2) ignore additional intervening @rec@s. For example, given -- @tydef Id a = a@, the type @rec x. rec y. Id x@ is also vacuous. -nonVacuous :: (Has (Reader TDCtx) sig m) => Nat -> Type -> m Bool -nonVacuous i (Fix tyF) = case tyF of +nonVacuous :: + (Has (Reader TDCtx) sig m, Has (Throw KindError) sig m) => + Nat -> + Type -> + m Bool +nonVacuous i ty@(Fix tyF) = case tyF of -- The type simply consists of a variable bound by some @rec@. -- Check if it's the variable we're currently looking for. TyRecVarF j -> pure (i /= j) -- Expand a user-defined type and keep looking. TyConF (TCUser u) tys -> do - ty' <- expandTydef u tys + ty' <- + withThrow + (\(UnexpandedUserType _) -> UndefinedTyCon (TCUser u) ty) + (expandTydef u tys) nonVacuous i ty' -- Increment the variable we're looking for when going under a @rec@ -- binder. - TyRecF _ ty -> nonVacuous (NS i) ty + TyRecF _ ty' -> nonVacuous (NS i) ty' -- If we encounter any other kind of type constructor or record -- type, rejoice! TyConF {} -> pure True diff --git a/src/swarm-lang/Swarm/Language/LSP.hs b/src/swarm-lang/Swarm/Language/LSP.hs --- a/src/swarm-lang/Swarm/Language/LSP.hs +++ b/src/swarm-lang/Swarm/Language/LSP.hs @@ -26,9 +26,10 @@ import Swarm.Language.Parser.Core (defaultParserConfig) import Swarm.Language.Parser.Util (getLocRange, showErrorPos) import Swarm.Language.Pipeline (processParsedTerm') -import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax (SrcLoc (..)) import Swarm.Language.Typecheck (ContextualTypeErr (..)) +import Swarm.Language.Value (emptyEnv) +import Swarm.Pretty (prettyText) import System.IO (stderr) import Witch @@ -89,7 +90,7 @@ VU.Usage _ problems = VU.getUsage mempty term unusedWarnings = mapMaybe (VU.toErrPos content) problems - parsingErrors = case processParsedTerm' mempty term of + parsingErrors = case processParsedTerm' emptyEnv term of Right _ -> [] Left e -> pure $ showTypeErrorPos content e Left e -> (pure $ showErrorPos e, []) diff --git a/src/swarm-lang/Swarm/Language/LSP/Hover.hs b/src/swarm-lang/Swarm/Language/LSP/Hover.hs --- a/src/swarm-lang/Swarm/Language/LSP/Hover.hs +++ b/src/swarm-lang/Swarm/Language/LSP/Hover.hs @@ -23,21 +23,21 @@ import Data.Graph import Data.List.NonEmpty (NonEmpty (..)) import Data.Map qualified as M -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isNothing) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lines qualified as R import Data.Text.Utf16.Rope.Mixed qualified as R import Language.LSP.Protocol.Types qualified as J import Language.LSP.VFS -import Swarm.Language.Context as Ctx import Swarm.Language.Parser (readTerm') import Swarm.Language.Parser.Core (defaultParserConfig) import Swarm.Language.Pipeline (processParsedTerm) -import Swarm.Language.Pretty (prettyText, prettyTextLine) import Swarm.Language.Syntax +import Swarm.Language.TDVar (tdVarName) import Swarm.Language.Typecheck (inferConst) import Swarm.Language.Types +import Swarm.Pretty (prettyText, prettyTextLine) import Swarm.Util qualified as U withinBound :: Int -> SrcLoc -> Bool @@ -111,14 +111,16 @@ narrowToPosition s0@(Syntax' _ t _ ty) pos = fromMaybe s0 $ case t of SLam lv _ s -> d (locVarToSyntax' lv $ getInnerType ty) <|> d s SApp s1 s2 -> d s1 <|> d s2 - SLet _ _ lv _ _ s1@(Syntax' _ _ _ lty) s2 -> d (locVarToSyntax' lv lty) <|> d s1 <|> d s2 + SLet _ _ lv _ _ _ s1@(Syntax' _ _ _ lty) s2 -> d (locVarToSyntax' lv lty) <|> d s1 <|> d s2 SBind mlv _ _ _ s1@(Syntax' _ _ _ lty) s2 -> (mlv >>= d . flip locVarToSyntax' (getInnerType lty)) <|> d s1 <|> d s2 + STydef typ typBody _ti s1 -> d s1 <|> Just (locVarToSyntax' (tdVarName <$> typ) $ fromPoly typBody) SPair s1 s2 -> d s1 <|> d s2 SDelay s -> d s SRcd m -> asum . map d . catMaybes . M.elems $ m SProj s1 _ -> d s1 SAnnotate s _ -> d s SRequirements _ s -> d s + SParens s -> d s -- atoms - return their position and end recursion TUnit -> Nothing TConst {} -> Nothing @@ -127,14 +129,15 @@ TText {} -> Nothing TBool {} -> Nothing TVar {} -> Nothing + TStock {} -> Nothing TRequire {} -> Nothing - TRequireDevice {} -> Nothing - STydef {} -> Nothing + TType {} -> Nothing -- these should not show up in surface language TRef {} -> Nothing TRobot {} -> Nothing TAntiInt {} -> Nothing TAntiText {} -> Nothing + TAntiSyn {} -> Nothing SSuspend {} -> Nothing where d = descend pos @@ -151,6 +154,8 @@ T.unlines $ renderDoc d t : map (treeToMarkdown $ d + 1) children class Show t => ExplainableType t where + fromPoly :: Polytype -> t + -- | Pretty print the type. prettyType :: t -> Text @@ -166,11 +171,13 @@ eq :: t -> Polytype -> Bool instance ExplainableType () where + fromPoly = const () prettyType = const "?" getInnerType = id eq _ _ = False instance ExplainableType Polytype where + fromPoly = id prettyType = prettyTextLine getInnerType = fmap $ \case (l :->: _r) -> l @@ -178,6 +185,15 @@ t -> t eq = (==) +instance ExplainableType RawPolytype where + fromPoly = forgetQ + prettyType = prettyTextLine + getInnerType = fmap $ \case + (l :->: _r) -> l + (TyCmd t) -> t + t -> t + eq r t = r == forgetQ t + explain :: ExplainableType ty => Syntax' ty -> Tree Text explain trm = case trm ^. sTerm of TUnit -> literal "The unit value." @@ -190,6 +206,8 @@ SRcd {} -> literal "A record literal." SProj {} -> literal "A record projection." STydef {} -> literal "A type synonym definition." + TType {} -> literal "A type literal." + SParens s -> explain s -- type ascription SAnnotate lhs typeAnn -> Node @@ -197,11 +215,11 @@ [explain lhs] -- special forms (function application will show for `$`, but really should be rare) SApp {} -> explainFunction trm - TRequireDevice {} -> pure "Require a specific device to be equipped." - TRequire {} -> pure "Require a certain number of an entity." + TRequire {} -> pure "Require a specific device to be equipped." + TStock {} -> pure "Stock a certain number of an entity." SRequirements {} -> pure "Query the requirements of a term." -- definition or bindings - SLet ls isRecursive var mTypeAnn _ rhs _b -> pure $ explainDefinition ls isRecursive var (rhs ^. sType) mTypeAnn + SLet ls isRecursive var mTypeAnn _ _ rhs _b -> pure $ explainDefinition ls isRecursive var (rhs ^. sType) mTypeAnn SLam (LV _s v) _mType _syn -> pure $ typeSignature v ty $ @@ -230,6 +248,7 @@ TRef {} -> internal "A memory reference." TAntiInt {} -> internal "An antiquoted Haskell variable name of type Integer." TAntiText {} -> internal "An antiquoted Haskell variable name of type Text." + TAntiSyn {} -> internal "An antiquoted Haskell variable name of type Syntax." TRobot {} -> internal "A robot reference." SSuspend {} -> internal "A suspension." where @@ -238,7 +257,7 @@ internal description = literal $ description <> "\n**These should never show up in surface syntax.**" constGenSig c = let ity = inferConst c - in if ty `eq` ity then id else typeSignature (prettyText c) ity + in U.applyWhen (not $ ty `eq` ity) $ typeSignature (prettyText c) ity -- | Helper function to explain function application. -- @@ -260,7 +279,7 @@ (map explain params) ] -explainDefinition :: ExplainableType ty => LetSyntax -> Bool -> LocVar -> ty -> Maybe Polytype -> Text +explainDefinition :: ExplainableType ty => LetSyntax -> Bool -> LocVar -> ty -> Maybe RawPolytype -> Text explainDefinition ls isRecursive (LV _s var) ty maybeTypeAnnotation = typeSignature var ty $ T.unwords @@ -268,7 +287,7 @@ , (if isRecursive then "" else "non-") <> "recursive" , if ls == LSDef then "definition" else "let" , "expression" - , if null maybeTypeAnnotation then "without" else "with" + , if isNothing maybeTypeAnnotation then "without" else "with" , "a type annotation on the variable." ] diff --git a/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs b/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs --- a/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs +++ b/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs @@ -101,13 +101,35 @@ SLam v _ s -> checkOccurrences bindings v Lambda [s] SApp s1 s2 -> getUsage bindings s1 <> getUsage bindings s2 -- Warn on unused 'let' bindings... - SLet LSLet _ v _ _ s1 s2 -> getUsage bindings s1 <> checkOccurrences bindings v Let [s2] + SLet LSLet _ v _ _ _ s1 s2 -> getUsage bindings s1 <> checkOccurrences bindings v Let [s2] -- But don't warn on unused 'def' bindings, because they may be -- intended to be used at a later REPL input. - SLet LSDef _ _ _ _ s1 s2 -> getUsage bindings s1 <> getUsage bindings s2 + SLet LSDef _ _ _ _ _ s1 s2 -> getUsage bindings s1 <> getUsage bindings s2 SPair s1 s2 -> getUsage bindings s1 <> getUsage bindings s2 SBind maybeVar _ _ _ s1 s2 -> case maybeVar of Just v -> checkOccurrences bindings v Bind [s1, s2] Nothing -> getUsage bindings s1 <> getUsage bindings s2 SDelay s -> getUsage bindings s - _ -> mempty + SRcd m -> M.foldMapWithKey (\x -> maybe (getUsage bindings (STerm (TVar x))) (getUsage bindings)) m + SProj s _ -> getUsage bindings s + SAnnotate s _ -> getUsage bindings s + SSuspend s -> getUsage bindings s + SParens s -> getUsage bindings s + -- Explicitly enumerate the cases with no variables, instead of a + -- catch-all, so that we get a warning when adding new constructors. + TUnit {} -> mempty + TConst {} -> mempty + TDir {} -> mempty + TInt {} -> mempty + TAntiInt {} -> mempty + TText {} -> mempty + TAntiText {} -> mempty + TAntiSyn {} -> mempty + TBool {} -> mempty + TRobot {} -> mempty + TRef {} -> mempty + TRequire {} -> mempty + TStock {} -> mempty + SRequirements {} -> mempty + STydef {} -> mempty + TType {} -> mempty diff --git a/src/swarm-lang/Swarm/Language/Parser.hs b/src/swarm-lang/Swarm/Language/Parser.hs --- a/src/swarm-lang/Swarm/Language/Parser.hs +++ b/src/swarm-lang/Swarm/Language/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -10,10 +11,13 @@ -- typechecks, elaborates, and capability checks a term all at once. module Swarm.Language.Parser ( readTerm, + readNonemptyTerm, readTerm', ) where +import Control.Monad ((>=>)) import Data.Bifunctor (first, second) +import Data.Either.Extra (maybeToEither) import Data.Sequence (Seq) import Data.Text (Text) import Swarm.Language.Parser.Comment (populateComments) @@ -24,6 +28,13 @@ import Swarm.Language.Syntax (Comment, Syntax) import Text.Megaparsec.Error (errorBundlePretty) import Witch (from) + +-- | Parse some input 'Text' completely as a 'Term', consuming leading +-- whitespace and ensuring the parsing extends all the way to the +-- end of the input 'Text'. Returns an error if the term was only +-- whitespace. +readNonemptyTerm :: Text -> Either Text Syntax +readNonemptyTerm = readTerm >=> maybeToEither "Empty term" -- | Parse some input 'Text' completely as a 'Term', consuming leading -- whitespace and ensuring the parsing extends all the way to the diff --git a/src/swarm-lang/Swarm/Language/Parser/Comment.hs b/src/swarm-lang/Swarm/Language/Parser/Comment.hs --- a/src/swarm-lang/Swarm/Language/Parser/Comment.hs +++ b/src/swarm-lang/Swarm/Language/Parser/Comment.hs @@ -39,7 +39,7 @@ -- -- (3) For each suffix comment (i.e. comments after something else -- at the end of a line, or in the middle of a line), attach --- them to the latest node in a postorder traversal which begins +-- them to the latest node in a postorder traversal which ends -- before the comment. -- | Re-insert parsed comments into an AST. Prerequisite: the sequence of comments @@ -74,15 +74,15 @@ populateStandaloneComments :: [Comment] -> Syntax -> Syntax populateStandaloneComments cmts = flip evalState cmts - . preorder (insertComments srcLocBefore (\c -> beforeComments %~ (|> c))) + . preorder (insertComments srcLocStartsBefore (\c -> beforeComments %~ (|> c))) -- | Given a list of suffix comments sorted by 'SrcLoc', insert -- them into the given AST, attaching each comment to the latest --- node in a postorder traversal which begins before it. +-- node in a postorder traversal which ends before it. populateSuffixComments :: [Comment] -> Syntax -> Syntax populateSuffixComments cmts = flip evalState (reverse cmts) - . revpostorder (insertComments (flip srcLocBefore) (\c -> afterComments %~ (c <|))) + . revpostorder (insertComments (flip srcLocEndsBefore) (\c -> afterComments %~ (c <|))) ------------------------------------------------------------ -- Traversals @@ -108,12 +108,12 @@ go = g >=> mapMOf plate go -- | Reverse postorder traversal of a 'Plated' structure with a --- monadic transformation. Apply the transformation recursively to --- all the children in reverse order, then transform the root. +-- monadic transformation. Transform the root, then apply the +-- transformation recursively to all the children in reverse order. -- -- >>> showTree (evalState (revpostorder next exampleTree) 0) --- "7(6 5(4 3 2) 1(0))" +-- "0(7 3(6 5 4) 1(2))" revpostorder :: (Plated a, Monad m) => (a -> m a) -> (a -> m a) revpostorder g = go where - go = mapMOf (backwards plate) go >=> g + go = g >=> mapMOf (backwards plate) go diff --git a/src/swarm-lang/Swarm/Language/Parser/Core.hs b/src/swarm-lang/Swarm/Language/Parser/Core.hs --- a/src/swarm-lang/Swarm/Language/Parser/Core.hs +++ b/src/swarm-lang/Swarm/Language/Parser/Core.hs @@ -15,8 +15,9 @@ languageVersion, -- * Comment parsing state - CommentState (..), + WSState (..), freshLine, + preWSLoc, comments, -- * Parser type @@ -37,6 +38,7 @@ import Data.Sequence qualified as Seq import Data.Text (Text) import Data.Void (Void) +import Language.Haskell.TH qualified as TH import Swarm.Language.Syntax (Comment) import Text.Megaparsec hiding (runParser, runParser') import Text.Megaparsec qualified as MP @@ -57,7 +59,7 @@ -- | Which version of the Swarm language are we parsing? As a general -- rule, we want to support one older version in addition to the -- current version, to allow for upgrading code via @swarm format@. -data LanguageVersion = SwarmLang0_5 | SwarmLangLatest +data LanguageVersion = SwarmLang0_6 | SwarmLangLatest deriving (Eq, Ord, Show, Enum, Bounded) -- | Read-only parser configuration. @@ -75,25 +77,30 @@ , _languageVersion = SwarmLangLatest } -data CommentState = CS +-- | Miscellaneous state relating to parsing whitespace + comments +data WSState = WS { _freshLine :: Bool -- ^ Are we currently on a (so far) blank line, i.e. have there been -- no nontrivial tokens since the most recent newline? This field -- is updated every time we parse a lexeme or symbol (set to -- false), or a newline (set to true). + , _preWSLoc :: Int + -- ^ The last source location before we started consuming + -- whitespace. We use this to assign more accurate source spans + -- to AST nodes, which do *not* include any trailing whitespace. , _comments :: Seq Comment -- ^ The actual sequence of comments, in the order they were encountered } -makeLenses ''CommentState +makeLenses ''WSState -initCommentState :: CommentState -initCommentState = CS {_freshLine = True, _comments = Seq.empty} +initWSState :: WSState +initWSState = WS {_freshLine = True, _preWSLoc = 0, _comments = Seq.empty} ------------------------------------------------------------ -- Parser types -type Parser = ReaderT ParserConfig (StateT CommentState (Parsec Void Text)) +type Parser = ReaderT ParserConfig (StateT WSState (Parsec Void Text)) type ParserError = ParseErrorBundle Text Void @@ -111,22 +118,24 @@ runParser' cfg p t = (\pt -> parse pt "" t) . fmap (second (^. comments)) - . flip runStateT initCommentState + . flip runStateT initWSState . flip runReaderT cfg $ p -- | A utility for running a parser in an arbitrary 'MonadFail' (which -- is going to be the TemplateHaskell 'Language.Haskell.TH.Q' monad --- see -- "Swarm.Language.Parser.QQ"), with a specified source position. -runParserTH :: (Monad m, MonadFail m) => (String, Int, Int) -> Parser a -> String -> m a -runParserTH (file, line, col) p s = +runParserTH :: (Monad m, MonadFail m) => TH.Loc -> Parser a -> String -> m a +runParserTH loc p s = either (fail . errorBundlePretty) (return . fst) . snd . flip MP.runParser' initState - . flip runStateT initCommentState + . flip runStateT initWSState . flip runReaderT defaultParserConfig {_antiquoting = AllowAntiquoting} $ p where + file = TH.loc_filename loc + (line, col) = TH.loc_start loc initState :: State Text Void initState = (initialState file (from s)) diff --git a/src/swarm-lang/Swarm/Language/Parser/Lex.hs b/src/swarm-lang/Swarm/Language/Parser/Lex.hs --- a/src/swarm-lang/Swarm/Language/Parser/Lex.hs +++ b/src/swarm-lang/Swarm/Language/Parser/Lex.hs @@ -45,7 +45,7 @@ brackets, ) where -import Control.Lens (use, view, (%=), (.=)) +import Control.Lens (use, (%=), (.=)) import Control.Monad (void) import Data.Char (isLower, isUpper) import Data.Containers.ListUtils (nubOrd) @@ -58,6 +58,7 @@ import Swarm.Language.Parser.Core import Swarm.Language.Syntax import Swarm.Language.Syntax.Direction +import Swarm.Language.TDVar (TDVar, mkTDVar) import Swarm.Language.Types (baseTyName) import Swarm.Util (failT, squote) import Text.Megaparsec @@ -71,9 +72,14 @@ -- | Add 'SrcLoc' to a parser parseLocG :: Parser a -> Parser (SrcLoc, a) parseLocG pa = do + -- Remember the start location. start <- getOffset a <- pa - end <- getOffset + -- Instead of using 'getOffset' to get the end location, which would + -- include any whitespace consumed at the end of @pa@, get the + -- @preWSLoc@ which was set by 'sc' at the /beginning/ of the + -- consumed whitespace. + end <- use preWSLoc pure (SrcLoc start end, a) -- | Add 'SrcLoc' to a 'Term' parser @@ -98,23 +104,34 @@ lineComment :: Text -> Parser () lineComment start = do cs <- getCommentSituation - (loc, t) <- parseLocG $ do - string start *> takeWhileP (Just "character") (/= '\n') - comments %= (Seq.|> Comment loc LineComment cs t) + -- Note we must manually get the start and end offset rather than + -- using parseLocG, since parseLocG explicitly does not include the + -- source span of trailing whitespace. + s <- getOffset + t <- string start *> takeWhileP (Just "character") (/= '\n') + e <- getOffset + comments %= (Seq.|> Comment (SrcLoc s e) LineComment cs t) -- | Parse a block comment, while appending it out-of-band to the list of -- comments saved in the custom state. blockComment :: Text -> Text -> Parser () blockComment start end = do cs <- getCommentSituation - (loc, t) <- parseLocG $ do - void $ string start - manyTill anySingle (string end) - comments %= (Seq.|> Comment loc BlockComment cs (into @Text t)) + -- Note we must manually get the start and end offset rather than + -- using parseLocG, since parseLocG explicitly does not include the + -- source span of trailing whitespace. + s <- getOffset + void $ string start + t <- manyTill anySingle (string end) + e <- getOffset + comments %= (Seq.|> Comment (SrcLoc s e) BlockComment cs (into @Text t)) -- | Skip spaces and comments. sc :: Parser () -sc = +sc = do + -- Remember where we were before we started consuming whitespace. + l <- getOffset + preWSLoc .= l -- Typically we would use L.space here, but we have to inline its -- definition and use our own slight variant, since we need to treat -- end-of-line specially. @@ -165,7 +182,7 @@ -- | List of keywords built into the language. keywords :: [Text] -keywords = T.words "let in def tydef end true false forall require requirements rec" +keywords = T.words "let in def tydef end true false forall require stock requirements rec" -- | List of reserved words that cannot be used as variable names. reservedWords :: Set Text @@ -176,12 +193,6 @@ ++ primitiveTypeNames ++ keywords --- | Cached version of the reserved words list with everything --- lowercase, for use in parsing version 0.5 of the language, where --- types were lowercase instead of uppercase. -lowerReservedWords :: Set Text -lowerReservedWords = S.map T.toLower reservedWords - -- | Parse a reserved word, given a string recognizer (which can -- /e.g./ be case sensitive or not), making sure it is not a prefix -- of a longer variable name, and allowing the parser to backtrack @@ -203,32 +214,26 @@ -- | Parse an identifier together with its source location info. locIdentifier :: IdentifierType -> Parser LocVar -locIdentifier idTy = do - ver <- view languageVersion - uncurry LV <$> parseLocG ((lexeme . try) (p >>= check ver) "variable name") +locIdentifier idTy = + uncurry LV <$> parseLocG ((lexeme . try) (p >>= check) "variable name") where p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'') - check ver (into @Text -> t) = case ver of - SwarmLang0_5 - | T.toLower t `S.member` lowerReservedWords -> - failT ["reserved word", squote t, "cannot be used as variable name"] - | otherwise -> return t - SwarmLangLatest - | IDTyVar <- idTy - , T.toTitle t `S.member` reservedWords -> - failT ["Reserved type name", squote t, "cannot be used as a type variable name; perhaps you meant", squote (T.toTitle t) <> "?"] - | IDTyName <- idTy - , t `S.member` reservedWords -> - failT ["Reserved type name", squote t, "cannot be redefined."] - | t `S.member` reservedWords || T.toLower t `S.member` reservedWords -> - failT ["Reserved word", squote t, "cannot be used as a variable name"] - | IDTyName <- idTy - , isLower (T.head t) -> - failT ["Type synonym names must start with an uppercase letter"] - | IDTyVar <- idTy - , isUpper (T.head t) -> - failT ["Type variable names must start with a lowercase letter"] - | otherwise -> return t + check (into @Text -> t) + | IDTyVar <- idTy + , T.toTitle t `S.member` reservedWords = + failT ["Reserved type name", squote t, "cannot be used as a type variable name; perhaps you meant", squote (T.toTitle t) <> "?"] + | IDTyName <- idTy + , t `S.member` reservedWords = + failT ["Reserved type name", squote t, "cannot be redefined."] + | t `S.member` reservedWords || T.toLower t `S.member` reservedWords = + failT ["Reserved word", squote t, "cannot be used as a variable name"] + | IDTyName <- idTy + , isLower (T.head t) = + failT ["Type synonym names must start with an uppercase letter"] + | IDTyVar <- idTy + , isUpper (T.head t) = + failT ["Type variable names must start with a lowercase letter"] + | otherwise = pure t -- | Parse a term variable together with its source location info. locTmVar :: Parser LocVar @@ -236,8 +241,8 @@ -- | Parse a user-defined type name together with its source location -- info. -locTyName :: Parser LocVar -locTyName = locIdentifier IDTyName +locTyName :: Parser (Located TDVar) +locTyName = (fmap . fmap) mkTDVar (locIdentifier IDTyName) -- | Parse an identifier, i.e. any non-reserved string containing -- alphanumeric characters and underscores, not starting with a @@ -253,8 +258,14 @@ -- | Parse a (user-defined) type constructor name, which must start -- with an uppercase letter. -tyName :: Parser Var -tyName = identifier IDTyName +-- +-- Note that this always produces a variable with version number 0, +-- via 'mkTDVar'. We cannot properly version variables at parsing +-- time since we don't know what else is in scope. There is a +-- separate name resolution pass later that assigns correct version +-- numbers to user type names. +tyName :: Parser TDVar +tyName = mkTDVar <$> identifier IDTyName -- | Parse a term variable, which can start in any case and just -- cannot be the same (case-insensitively) as a lowercase reserved diff --git a/src/swarm-lang/Swarm/Language/Parser/QQ.hs b/src/swarm-lang/Swarm/Language/Parser/QQ.hs --- a/src/swarm-lang/Swarm/Language/Parser/QQ.hs +++ b/src/swarm-lang/Swarm/Language/Parser/QQ.hs @@ -1,17 +1,20 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- A quasiquoter for Swarm polytypes. -module Swarm.Language.Parser.QQ (tyQ) where +-- A quasiquoter for Swarm polytypes + untyped terms. +module Swarm.Language.Parser.QQ (tyQ, astQ) where import Data.Generics import Language.Haskell.TH qualified as TH import Language.Haskell.TH.Quote import Swarm.Language.Parser.Core (runParserTH) import Swarm.Language.Parser.Lex (sc) +import Swarm.Language.Parser.Term (parseTerm) import Swarm.Language.Parser.Type (parsePolytype) import Swarm.Language.Parser.Util (fully) +import Swarm.Language.Syntax import Swarm.Util (liftText) +import Witch (from) ------------------------------------------------------------ -- Quasiquoters @@ -25,7 +28,10 @@ tyQ = QuasiQuoter { quoteExp = quoteTypeExp - , quotePat = error "quotePat not implemented for polytypes" + , -- Using `error` is OK here since a quasiquoter will only ever run + -- at compile time; hence it can only make compilation fail, not + -- crash the game at runtime. + quotePat = error "quotePat not implemented for polytypes" , quoteType = error "quoteType not implemented for polytypes" , quoteDec = error "quoteDec not implemented for polytypes" } @@ -33,10 +39,24 @@ quoteTypeExp :: String -> TH.ExpQ quoteTypeExp s = do loc <- TH.location - let pos = - ( TH.loc_filename loc - , fst (TH.loc_start loc) - , snd (TH.loc_start loc) - ) - parsed <- runParserTH pos (fully sc parsePolytype) s + parsed <- runParserTH loc (fully sc parsePolytype) s dataToExpQ (fmap liftText . cast) parsed + +astQ :: QuasiQuoter +astQ = + QuasiQuoter + { quoteExp = quoteASTExp + , quotePat = error "quotePat not implemented for ASTs" + , quoteType = error "quoteType not implemented for ASTs" + , quoteDec = error "quoteDec not implemented for ASTs" + } + +quoteASTExp :: String -> TH.ExpQ +quoteASTExp s = do + loc <- TH.location + parsed <- runParserTH loc (fully sc parseTerm) s + dataToExpQ ((fmap liftText . cast) `extQ` antiASTExp) parsed + +antiASTExp :: Syntax -> Maybe TH.ExpQ +antiASTExp (STerm (TAntiSyn v)) = Just $ TH.varE (TH.mkName (from v)) +antiASTExp _ = Nothing diff --git a/src/swarm-lang/Swarm/Language/Parser/Record.hs b/src/swarm-lang/Swarm/Language/Parser/Record.hs --- a/src/swarm-lang/Swarm/Language/Parser/Record.hs +++ b/src/swarm-lang/Swarm/Language/Parser/Record.hs @@ -10,14 +10,14 @@ import Data.Map (Map) import Data.Map qualified as M -import Swarm.Language.Context (Var) import Swarm.Language.Parser.Core (Parser) import Swarm.Language.Parser.Lex (symbol, tmVar) +import Swarm.Language.Var (Var) import Swarm.Util (failT, findDup, squote) import Text.Megaparsec (sepBy) --- | Parse something using record syntax of the form @{x1 v1, x2 v2, --- ...}@. The same parser is used both in parsing record types and +-- | Parse something using record syntax of the form @x1 v1, x2 v2, +-- ...@. The same parser is used both in parsing record types and -- record values, so it is factored out into its own module. -- -- The @Parser a@ argument is the parser to use for the RHS of each diff --git a/src/swarm-lang/Swarm/Language/Parser/Term.hs b/src/swarm-lang/Swarm/Language/Parser/Term.hs --- a/src/swarm-lang/Swarm/Language/Parser/Term.hs +++ b/src/swarm-lang/Swarm/Language/Parser/Term.hs @@ -9,14 +9,14 @@ import Control.Lens (view, (^.)) import Control.Monad (guard, join) import Control.Monad.Combinators.Expr -import Data.Foldable (asum) +import Data.Foldable (Foldable (..), asum) import Data.Functor (($>)) -import Data.List (foldl') import Data.Map (Map) import Data.Map qualified as M import Data.Maybe (mapMaybe) import Data.Set qualified as S import Data.Set.Lens (setOf) +import Data.Text qualified as T import Swarm.Language.Parser.Core import Swarm.Language.Parser.Lex import Swarm.Language.Parser.Record (parseRecord) @@ -27,6 +27,7 @@ import Swarm.Util (failT, findDup) import Text.Megaparsec hiding (runParser) import Text.Megaparsec.Char +import Prelude hiding (Foldable (..)) -- Imports for doctests (cabal-docspec needs this) @@ -43,11 +44,18 @@ -- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@) parseConst :: Parser Const -parseConst = asum (map alternative consts) "built-in user function" +parseConst = do + ver <- view languageVersion + asum (map (alternative ver) consts) "built-in user function" where consts = filter isUserFunc allConst - alternative c = c <$ reserved (syntax $ constInfo c) + alternative ver c = c <$ reserved (syntax $ constInfo' ver c) + -- Version 0.6 of the language had a constant named @return@, which + -- is now renamed to @pure@ + constInfo' SwarmLang0_6 Pure = (constInfo Pure) {syntax = "return"} + constInfo' _ c = constInfo c + -- | Parse an atomic term, optionally trailed by record projections like @t.x.y.z@. -- Record projection binds more tightly than function application. parseTermAtom :: Parser Syntax @@ -67,14 +75,8 @@ <|> TInt <$> integer <|> TText <$> textLiteral <|> TBool <$> ((True <$ reserved "true") <|> (False <$ reserved "false")) - <|> reserved "require" - *> ( ( TRequireDevice - <$> (textLiteral "device name in double quotes") - ) - <|> ( (TRequire . fromIntegral <$> integer) - <*> (textLiteral "entity name in double quotes") - ) - ) + <|> reserved "require" *> parseRequire + <|> reserved "stock" *> parseStock <|> uncurry SRequirements <$> (reserved "requirements" *> match parseTerm) <|> SLam <$> (symbol "\\" *> locTmVar) @@ -85,27 +87,47 @@ <*> optional (symbol ":" *> parsePolytype) <*> (symbol "=" *> parseTerm) <*> (reserved "in" *> parseTerm) - <|> sLet LSDef - <$> (reserved "def" *> locTmVar) - <*> optional (symbol ":" *> parsePolytype) - <*> (symbol "=" *> parseTerm <* reserved "end") - <*> (optional (symbol ";") *> (parseTerm <|> (eof $> sNoop))) + <|> do + reserved "def" + locVar@(LV _srcLoc nameText) <- locTmVar + mTy <- optional (symbol ":" *> parsePolytype) + _ <- symbol "=" + body <- parseTerm + reserved "end" ("'end' keyword for definition of '" <> T.unpack nameText <> "'") + rest <- optional (symbol ";") *> (parseTerm <|> (eof $> sNoop)) + return $ sLet LSDef locVar mTy body rest <|> STydef <$> (reserved "tydef" *> locTyName) <*> join (bindTydef <$> many tyVar <*> (symbol "=" *> parseType <* reserved "end")) <*> pure Nothing <*> (optional (symbol ";") *> (parseTerm <|> (eof $> sNoop))) <|> SRcd <$> brackets (parseRecord (optional (symbol "=" *> parseTerm))) - <|> parens (view sTerm . mkTuple <$> (parseTerm `sepBy` symbol ",")) + <|> TType <$> (symbol "@" *> parseTypeAtom) ) + <|> parseLoc (mkTuple <$> parens (parseTerm `sepBy` symbol ",")) <|> parseLoc (TDelay (TConst Noop) <$ try (symbol "{" *> symbol "}")) <|> parseLoc (SDelay <$> braces parseTerm) <|> parseLoc (view antiquoting >>= (guard . (== AllowAntiquoting)) >> parseAntiquotation) +-- | Parse the contents of a @require@ statement: either requiring a device, or +-- (if parsing v0.6) requiring inventory stock. +parseRequire :: Parser Term +parseRequire = do + ver <- view languageVersion + asum + [ TRequire <$> (textLiteral "device name in double quotes") + , guard (ver == SwarmLang0_6) *> parseStock + ] + +parseStock :: Parser Term +parseStock = + (TStock . fromIntegral <$> integer) + <*> (textLiteral "entity name in double quotes") + -- | Construct an 'SLet', automatically filling in the Boolean field -- indicating whether it is recursive. -sLet :: LetSyntax -> LocVar -> Maybe Polytype -> Syntax -> Syntax -> Term -sLet ls x ty t1 = SLet ls (lvVar x `S.member` setOf freeVarsV t1) x ty mempty t1 +sLet :: LetSyntax -> LocVar -> Maybe RawPolytype -> Syntax -> Syntax -> Term +sLet ls x ty t1 = SLet ls (lvVar x `S.member` setOf freeVarsV t1) x ty Nothing mempty t1 sNoop :: Syntax sNoop = STerm (TConst Noop) @@ -121,7 +143,7 @@ | not (S.null free) = failT $ "Undefined type variable(s) on right-hand side of tydef:" : S.toList free - | otherwise = return $ Forall xs ty + | otherwise = return . absQuantify $ mkPoly xs ty where free = tyVars ty `S.difference` S.fromList xs @@ -129,6 +151,7 @@ parseAntiquotation = TAntiText <$> (lexeme . try) (symbol "$str:" *> tmVar) <|> TAntiInt <$> (lexeme . try) (symbol "$int:" *> tmVar) + <|> TAntiSyn <$> (lexeme . try) (symbol "$syn:" *> tmVar) -- | Parse a Swarm language term. parseTerm :: Parser Syntax @@ -136,7 +159,7 @@ mkBindChain :: [Stmt] -> Parser Syntax mkBindChain stmts = case last stmts of - Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Return) (TVar (lvVar x)))) stmts + Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Pure) (TVar (lvVar x)))) stmts BareTerm t -> return $ foldr mkBind t (init stmts) where mkBind (BareTerm t1) t2 = loc Nothing t1 t2 $ SBind Nothing Nothing Nothing Nothing t1 t2 @@ -160,7 +183,7 @@ parseExpr = parseLoc $ ascribe <$> parseExpr' <*> optional (symbol ":" *> parsePolytype) where - ascribe :: Syntax -> Maybe Polytype -> Term + ascribe :: Syntax -> Maybe RawPolytype -> Term ascribe s Nothing = s ^. sTerm ascribe s (Just ty) = SAnnotate s ty @@ -199,7 +222,7 @@ pure $ M.singleton (fixity ci) - [assI (mkOp c <$ operator (syntax ci))] + [assI (mkOp c <$> parseLocG (operator (syntax ci)))] -- | Precedences and parsers of unary operators (currently only 'Neg'). -- diff --git a/src/swarm-lang/Swarm/Language/Parser/Type.hs b/src/swarm-lang/Swarm/Language/Parser/Type.hs --- a/src/swarm-lang/Swarm/Language/Parser/Type.hs +++ b/src/swarm-lang/Swarm/Language/Parser/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -12,15 +13,12 @@ parseTyCon, ) where -import Control.Lens (view) -import Control.Monad (join) import Control.Monad.Combinators (many) import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) import Data.Fix (Fix (..), foldFix) import Data.List.Extra (enumerate) import Data.Maybe (fromMaybe) -import Data.Set qualified as S -import Swarm.Language.Parser.Core (LanguageVersion (..), Parser, languageVersion) +import Swarm.Language.Parser.Core (Parser) import Swarm.Language.Parser.Lex ( braces, brackets, @@ -34,34 +32,16 @@ import Swarm.Language.Parser.Record (parseRecord) import Swarm.Language.Types import Text.Megaparsec (choice, optional, some, (<|>)) -import Witch (from) -- | Parse a Swarm language polytype, which starts with an optional -- quanitifation (@forall@ followed by one or more variables and a -- period) followed by a type. Note that anything accepted by -- 'parseType' is also accepted by 'parsePolytype'. -parsePolytype :: Parser Polytype +parsePolytype :: Parser RawPolytype parsePolytype = - join $ - ( quantify . fromMaybe [] - <$> optional ((reserved "forall" <|> reserved "∀") *> some tyVar <* symbol ".") - ) - <*> parseType - where - quantify :: [Var] -> Type -> Parser Polytype - quantify xs ty - -- Iplicitly quantify over free type variables if the user didn't write a forall - | null xs = return $ Forall (S.toList free) ty - -- Otherwise, require all variables to be explicitly quantified - | S.null free = return $ Forall xs ty - | otherwise = - fail $ - unlines - [ " Type contains free variable(s): " ++ unwords (map from (S.toList free)) - , " Try adding them to the 'forall'." - ] - where - free = tyVars ty `S.difference` S.fromList xs + mkPoly . fromMaybe [] + <$> optional ((reserved "forall" <|> reserved "∀") *> some tyVar <* symbol ".") + <*> parseType -- | Parse a Swarm language (mono)type. parseType :: Parser Type @@ -97,14 +77,8 @@ -- | A type constructor. parseTyCon :: Parser TyCon parseTyCon = do - ver <- view languageVersion - let reservedCase = case ver of - -- Version 0.5 of the language accepted type names in any case - SwarmLang0_5 -> reserved - -- The latest version requires them to be uppercase - SwarmLangLatest -> reservedCS - choice (map (\b -> TCBase b <$ reservedCase (baseTyName b)) enumerate) - <|> TCCmd <$ reservedCase "Cmd" + choice (map (\b -> TCBase b <$ reservedCS (baseTyName b)) enumerate) + <|> TCCmd <$ reservedCS "Cmd" <|> TCUser <$> tyName -- | Close over a recursive type, replacing any bound occurrences @@ -127,7 +101,7 @@ s :: TypeF (Nat -> Type) -> Nat -> Type s = \case TyRecF y ty -> Fix . TyRecF y . ty . NS - TyVarF y + TyVarF orig y | x == y -> Fix . TyRecVarF - | otherwise -> const (Fix (TyVarF y)) + | otherwise -> const (Fix (TyVarF orig y)) fty -> \i -> Fix (fmap ($ i) fty) diff --git a/src/swarm-lang/Swarm/Language/Parser/Value.hs b/src/swarm-lang/Swarm/Language/Parser/Value.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/Value.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parse values of the Swarm language, indexed by type, by running the +-- full swarm-lang parser and then checking that the result is a value +-- of the proper type. +module Swarm.Language.Parser.Value (readValue) where + +import Control.Lens ((^.)) +import Data.Either.Extra (eitherToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Language.Context qualified as Ctx +import Swarm.Language.Key (parseKeyComboFull) +import Swarm.Language.Parser (readNonemptyTerm) +import Swarm.Language.Syntax +import Swarm.Language.Typecheck (checkTop) +import Swarm.Language.Types (Type, emptyTDCtx) +import Swarm.Language.Value +import Text.Megaparsec qualified as MP + +readValue :: Type -> Text -> Maybe Value +readValue ty txt = do + -- Try to strip off a prefix representing a printable entity. Look + -- for the first colon or double quote. We will ignore a colon if a + -- double quote comes before it, because a colon could legitimately + -- occur in a formatted Text value, e.g. "\"hi: there\"". Otherwise, + -- strip off anything occurring before the first colon. + -- + -- Note, this would break if we ever had a printable entity whose + -- name contains a colon; printing on such an entity would yield + -- entity names like "Magic: The Gathering: 6" for which `read`, as + -- implemented here, would not work correctly. However, that seems + -- unlikely. + let firstUnquotedColon = T.dropWhile (\c -> c /= ':' && c /= '"') txt + let txt' = case T.uncons firstUnquotedColon of + Nothing -> txt + Just ('"', _) -> txt + Just (':', t) -> t + _ -> txt + s <- eitherToMaybe $ readNonemptyTerm txt' + _ <- eitherToMaybe $ checkTop Ctx.empty Ctx.empty emptyTDCtx s ty + toValue $ s ^. sTerm + +toValue :: Term -> Maybe Value +toValue = \case + TUnit -> Just VUnit + TDir d -> Just $ VDir d + TInt n -> Just $ VInt n + TText t -> Just $ VText t + TBool b -> Just $ VBool b + TApp (TConst c) t2 -> case c of + Neg -> toValue t2 >>= negateInt + Inl -> VInj False <$> toValue t2 + Inr -> VInj True <$> toValue t2 + Key -> do + VText k <- toValue t2 + VKey <$> eitherToMaybe (MP.runParser parseKeyComboFull "" k) + _ -> Nothing + TPair t1 t2 -> VPair <$> toValue t1 <*> toValue t2 + TRcd m -> VRcd <$> traverse (>>= toValue) m + TParens t -> toValue t + -- List the other cases explicitly, instead of a catch-all, so that + -- we will get a warning if we ever add new constructors in the + -- future + TConst {} -> Nothing + TAntiInt {} -> Nothing + TAntiText {} -> Nothing + TRequire {} -> Nothing + TStock {} -> Nothing + TRequirements {} -> Nothing + TVar {} -> Nothing + TLam {} -> Nothing + TApp {} -> Nothing + TLet {} -> Nothing + TTydef {} -> Nothing + TBind {} -> Nothing + TDelay {} -> Nothing + TProj {} -> Nothing + TAnnotate {} -> Nothing + TSuspend {} -> Nothing + +-- TODO(#2232): in order to get `read` to work for delay, function, +-- and/or command types, we will need to handle a few more of the +-- above cases, e.g. TConst, TLam, TApp, TLet, TBind, TDelay. + +negateInt :: Value -> Maybe Value +negateInt = \case + VInt n -> Just (VInt (-n)) + _ -> Nothing diff --git a/src/swarm-lang/Swarm/Language/Pipeline.hs b/src/swarm-lang/Swarm/Language/Pipeline.hs --- a/src/swarm-lang/Swarm/Language/Pipeline.hs +++ b/src/swarm-lang/Swarm/Language/Pipeline.hs @@ -28,12 +28,11 @@ import Swarm.Language.Context qualified as Ctx import Swarm.Language.Elaborate import Swarm.Language.Parser (readTerm) -import Swarm.Language.Pretty import Swarm.Language.Requirements.Type (ReqCtx) import Swarm.Language.Syntax import Swarm.Language.Typecheck import Swarm.Language.Types (TCtx) -import Swarm.Language.Value (Env, envReqs, envTydefs, envTypes) +import Swarm.Language.Value (Env, emptyEnv, envReqs, envTydefs, envTypes) processTermEither :: Text -> Either Text TSyntax processTermEither t = case processTerm t of @@ -50,11 +49,11 @@ -- Return either the end result (or @Nothing@ if the input was only -- whitespace) or a pretty-printed error message. processTerm :: Text -> Either Text (Maybe TSyntax) -processTerm = processTerm' mempty +processTerm = processTerm' emptyEnv -- | Like 'processTerm', but use a term that has already been parsed. processParsedTerm :: Syntax -> Either ContextualTypeErr TSyntax -processParsedTerm = processParsedTerm' mempty +processParsedTerm = processParsedTerm' emptyEnv -- | Like 'processTerm', but use explicit starting contexts. processTerm' :: Env -> Text -> Either Text (Maybe TSyntax) @@ -78,7 +77,7 @@ extractTCtx (Syntax' _ t _ _) = extractTCtxTerm t where extractTCtxTerm = \case - SLet _ _ (LV _ x) mty _ _ t2 -> maybe id (Ctx.addBinding x) mty (extractTCtx t2) + SLet _ _ (LV _ x) _ mty _ _ t2 -> maybe id (Ctx.addBinding x) mty (extractTCtx t2) SBind mx _ mty _ c1 c2 -> maybe id @@ -95,7 +94,7 @@ extractReqCtx (Syntax' _ t _ _) = extractReqCtxTerm t where extractReqCtxTerm = \case - SLet _ _ (LV _ x) _ mreq _ t2 -> maybe id (Ctx.addBinding x) mreq (extractReqCtx t2) + SLet _ _ (LV _ x) _ _ mreq _ t2 -> maybe id (Ctx.addBinding x) mreq (extractReqCtx t2) SBind mx _ _ mreq c1 c2 -> maybe id diff --git a/src/swarm-lang/Swarm/Language/Pipeline/QQ.hs b/src/swarm-lang/Swarm/Language/Pipeline/QQ.hs --- a/src/swarm-lang/Swarm/Language/Pipeline/QQ.hs +++ b/src/swarm-lang/Swarm/Language/Pipeline/QQ.hs @@ -12,8 +12,8 @@ import Swarm.Language.Parser.Term (parseTerm) import Swarm.Language.Parser.Util (fully) import Swarm.Language.Pipeline -import Swarm.Language.Pretty import Swarm.Language.Syntax +import Swarm.Language.Typecheck (prettyTypeErrText) import Swarm.Language.Types (Polytype) import Swarm.Util (failT, liftText) import Witch (from) @@ -38,12 +38,7 @@ quoteTermExp :: String -> TH.ExpQ quoteTermExp s = do loc <- TH.location - let pos = - ( TH.loc_filename loc - , fst (TH.loc_start loc) - , snd (TH.loc_start loc) - ) - parsed <- runParserTH pos (fully sc parseTerm) s + parsed <- runParserTH loc (fully sc parseTerm) s case processParsedTerm parsed of Left err -> failT [prettyTypeErrText (from s) err] Right ptm -> dataToExpQ ((fmap liftText . cast) `extQ` antiTermExp) ptm diff --git a/src/swarm-lang/Swarm/Language/Pretty.hs b/src/swarm-lang/Swarm/Language/Pretty.hs deleted file mode 100644 --- a/src/swarm-lang/Swarm/Language/Pretty.hs +++ /dev/null @@ -1,603 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Pretty-printing for the Swarm language. -module Swarm.Language.Pretty where - -import Control.Lens.Combinators (pattern Empty) -import Control.Monad.Free (Free (..)) -import Data.Bool (bool) -import Data.Fix -import Data.Foldable qualified as F -import Data.List.NonEmpty ((<|)) -import Data.List.NonEmpty qualified as NE -import Data.Map.Strict qualified as M -import Data.Sequence qualified as Seq -import Data.Set (Set) -import Data.Set qualified as S -import Data.String (fromString) -import Data.Text (Text) -import Data.Text qualified as T -import Prettyprinter -import Prettyprinter.Render.String qualified as RS -import Prettyprinter.Render.Text qualified as RT -import Swarm.Effect.Unify (UnificationError (..)) -import Swarm.Language.Capability -import Swarm.Language.Context -import Swarm.Language.Kindcheck (KindError (..)) -import Swarm.Language.Parser.Util (getLocRange) -import Swarm.Language.Syntax -import Swarm.Language.Syntax.Direction -import Swarm.Language.Typecheck -import Swarm.Language.Types -import Swarm.Util (number, showEnum, showLowT, unsnocNE) -import Text.Show.Unicode (ushow) -import Witch - ------------------------------------------------------------- --- PrettyPrec class + utilities - --- | Type class for things that can be pretty-printed, given a --- precedence level of their context. -class PrettyPrec a where - prettyPrec :: Int -> a -> Doc ann -- can replace with custom ann type later if desired - --- | Pretty-print a thing, with a context precedence level of zero. -ppr :: (PrettyPrec a) => a -> Doc ann -ppr = prettyPrec 0 - --- | Render a pretty-printed document as @Text@. -docToText :: Doc a -> Text -docToText = RT.renderStrict . layoutPretty defaultLayoutOptions - --- | Render a pretty-printed document as @Text@. --- This function consumes number of allowed characters in a --- line before introducing a line break. In other words, it --- expects the space of the layouter to be supplied. -docToTextWidth :: Doc a -> Int -> Text -docToTextWidth doc layoutWidth = - RT.renderStrict $ layoutPretty (LayoutOptions (AvailablePerLine layoutWidth 1.0)) doc - --- | Pretty-print something and render it as @Text@. -prettyText :: (PrettyPrec a) => a -> Text -prettyText = docToText . ppr - --- | Pretty-print something and render it as @Text@. --- This is different than @prettyText@ in the sense that it also --- consumes number of allowed characters in a line before introducing --- a line break. -prettyTextWidth :: (PrettyPrec a) => a -> Int -> Text -prettyTextWidth = docToTextWidth . ppr - --- | Pretty-print something and render it as (preferably) one line @Text@. -prettyTextLine :: (PrettyPrec a) => a -> Text -prettyTextLine = RT.renderStrict . layoutPretty (LayoutOptions Unbounded) . group . ppr - --- | Render a pretty-printed document as a @String@. -docToString :: Doc a -> String -docToString = RS.renderString . layoutPretty defaultLayoutOptions - --- | Pretty-print something and render it as a @String@. -prettyString :: (PrettyPrec a) => a -> String -prettyString = docToString . ppr - --- | Optionally surround a document with parentheses depending on the --- @Bool@ argument and if it does not fit on line, indent the lines, --- with the parens on separate lines. -pparens :: Bool -> Doc ann -> Doc ann -pparens True = group . encloseWithIndent 2 lparen rparen -pparens False = id - --- | Same as pparens but does not indent the lines. Only encloses --- the document with parantheses. -pparens' :: Bool -> Doc ann -> Doc ann -pparens' True = group . enclose lparen rparen -pparens' False = id - -encloseWithIndent :: Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann -encloseWithIndent i l r = nest i . enclose (l <> line') (nest (-2) $ line' <> r) - --- | Surround a document with backticks. -bquote :: Doc ann -> Doc ann -bquote = group . enclose "`" "`" - --- | Turn a 'Show' instance into a @Doc@, lowercasing it in the --- process. -prettyShowLow :: Show a => a -> Doc ann -prettyShowLow = pretty . showLowT - --- | An invitation to report an error as a bug. -reportBug :: Doc ann -reportBug = "This should never happen; please report this as a bug: https://github.com/swarm-game/swarm/issues/new" - --------------------------------------------------- --- Bullet lists - -data Prec a = Prec Int a - -data BulletList i = BulletList - { bulletListHeader :: forall a. Doc a - , bulletListItems :: [i] - } - -instance (PrettyPrec i) => PrettyPrec (BulletList i) where - prettyPrec _ (BulletList hdr items) = - nest 2 . vcat $ hdr : map (("-" <+>) . ppr) items - ------------------------------------------------------------- --- PrettyPrec instances for terms, types, etc. - -instance PrettyPrec Text where - prettyPrec _ = pretty - -instance PrettyPrec BaseTy where - prettyPrec _ = pretty . drop 1 . show - -instance PrettyPrec IntVar where - prettyPrec _ = pretty . mkVarName "u" - --- | We can use the 'Wildcard' value to replace unification variables --- when we don't care about them, e.g. to print out the shape of a --- type like @(_ -> _) * _@ -data Wildcard = Wildcard - deriving (Eq, Ord, Show) - -instance PrettyPrec Wildcard where - prettyPrec _ _ = "_" - -instance PrettyPrec TyCon where - prettyPrec _ = \case - TCBase b -> ppr b - TCCmd -> "Cmd" - TCDelay -> "Delay" - TCSum -> "Sum" - TCProd -> "Prod" - TCFun -> "Fun" - TCUser t -> pretty t - --- | Split a function type chain, so that we can pretty print --- the type parameters aligned on each line when they don't fit. -class UnchainableFun t where - unchainFun :: t -> NE.NonEmpty t - -instance UnchainableFun Type where - unchainFun (a :->: ty) = a <| unchainFun ty - unchainFun ty = pure ty - -instance UnchainableFun (Free TypeF ty) where - unchainFun (Free (TyConF TCFun [ty1, ty2])) = ty1 <| unchainFun ty2 - unchainFun ty = pure ty - -instance (PrettyPrec (t (Fix t))) => PrettyPrec (Fix t) where - prettyPrec p = prettyPrec p . unFix - -instance (PrettyPrec (t (Free t v)), PrettyPrec v) => PrettyPrec (Free t v) where - prettyPrec p (Free t) = prettyPrec p t - prettyPrec p (Pure v) = prettyPrec p v - -instance (UnchainableFun t, PrettyPrec t, SubstRec t) => PrettyPrec (TypeF t) where - prettyPrec p = \case - TyVarF v -> pretty v - TyRcdF m -> brackets $ hsep (punctuate "," (map prettyBinding (M.assocs m))) - -- Special cases for type constructors with special syntax. - -- Always use parentheses around sum and product types, see #1625 - TyConF TCSum [ty1, ty2] -> - pparens (p > 0) $ - prettyPrec 2 ty1 <+> "+" <+> prettyPrec 2 ty2 - TyConF TCProd [ty1, ty2] -> - pparens (p > 0) $ - prettyPrec 2 ty1 <+> "*" <+> prettyPrec 2 ty2 - TyConF TCDelay [ty] -> braces $ ppr ty - TyConF TCFun [ty1, ty2] -> - let (iniF, lastF) = unsnocNE $ ty1 <| unchainFun ty2 - funs = (prettyPrec 2 <$> iniF) <> [prettyPrec 1 lastF] - inLine l r = l <+> "->" <+> r - multiLine l r = l <+> "->" <> softline <> r - in pparens' (p > 1) . align $ - flatAlt (concatWith multiLine funs) (concatWith inLine funs) - TyRecF x ty -> - pparens (p > 0) $ - "rec" <+> pretty x <> "." <+> prettyPrec 0 (substRec (TyVarF x) ty NZ) - -- This case shouldn't be possible, since TyRecVar should only occur inside a TyRec, - -- and pretty-printing the TyRec (above) will substitute a variable name for - -- any bound TyRecVars before recursing. - TyRecVarF i -> pretty (show (natToInt i)) - -- Fallthrough cases for type constructor application. Handles base - -- types, Cmd, user-defined types, or ill-kinded things like 'Int - -- Bool'. - TyConF c [] -> ppr c - TyConF c tys -> pparens (p > 9) $ ppr c <+> hsep (map (prettyPrec 10) tys) - -instance PrettyPrec Polytype where - prettyPrec _ (Forall [] t) = ppr t - prettyPrec _ (Forall xs t) = hsep ("∀" : map pretty xs) <> "." <+> ppr t - -instance PrettyPrec UPolytype where - prettyPrec _ (Forall [] t) = ppr t - prettyPrec _ (Forall xs t) = hsep ("∀" : map pretty xs) <> "." <+> ppr t - -instance (PrettyPrec t) => PrettyPrec (Ctx t) where - prettyPrec _ Empty = emptyDoc - prettyPrec _ (assocs -> bs) = brackets (hsep (punctuate "," (map prettyBinding bs))) - -prettyBinding :: (Pretty a, PrettyPrec b) => (a, b) -> Doc ann -prettyBinding (x, ty) = pretty x <> ":" <+> ppr ty - -instance PrettyPrec Direction where - prettyPrec _ = pretty . directionSyntax - -instance PrettyPrec Capability where - prettyPrec _ c = pretty $ T.toLower (from (NE.tail $ showEnum c)) - -instance PrettyPrec Const where - prettyPrec p c = pparens (p > fixity (constInfo c)) $ pretty . syntax . constInfo $ c - --- | Pretty-print a syntax node with comments. -instance PrettyPrec (Syntax' ty) where - prettyPrec p (Syntax' _ t (Comments before after) _) = case before of - Empty -> t' - _ -> - -- Print out any comments before the node, with a blank line before - mconcat - [ hardline - , vsep (map ppr (F.toList before)) - , hardline - , t' - ] - where - -- Print the node itself, possibly with suffix comments on the same line - t' = case Seq.viewr after of - Seq.EmptyR -> prettyPrec p t - _ Seq.:> lst -> case commentType lst of - -- Output a newline after a line comment, but not after a block comment - BlockComment -> tWithComments - LineComment -> tWithComments <> hardline - where - -- The pretty-printed node with suffix comments - tWithComments = prettyPrec p t <+> hsep (map ppr (F.toList after)) - -instance PrettyPrec Comment where - prettyPrec _ (Comment _ LineComment _ txt) = "//" <> pretty txt - prettyPrec _ (Comment _ BlockComment _ txt) = "/*" <> pretty txt <> "*/" - -instance PrettyPrec (Term' ty) where - prettyPrec p = \case - TUnit -> "()" - TConst c -> prettyPrec p c - TDir d -> ppr d - TInt n -> pretty n - TAntiInt v -> "$int:" <> pretty v - TText s -> fromString (ushow s) - TAntiText v -> "$str:" <> pretty v - TBool b -> bool "false" "true" b - TRobot r -> " pretty r <> ">" - TRef r -> "@" <> pretty r - TRequireDevice d -> pparens (p > 10) $ "require" <+> ppr @Term (TText d) - TRequire n e -> pparens (p > 10) $ "require" <+> pretty n <+> ppr @Term (TText e) - SRequirements _ e -> pparens (p > 10) $ "requirements" <+> ppr e - TVar s -> pretty s - SDelay (Syntax' _ (TConst Noop) _ _) -> "{}" - SDelay t -> group . encloseWithIndent 2 lbrace rbrace $ ppr t - t@SPair {} -> prettyTuple t - t@SLam {} -> - pparens (p > 9) $ - prettyLambdas t - -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3 - SApp t@(Syntax' _ (SApp (Syntax' _ (TConst c) _ _) l) _ _) r -> - let ci = constInfo c - pC = fixity ci - in case constMeta ci of - ConstMBinOp assoc -> - pparens (p > pC) $ - hsep - [ prettyPrec (pC + fromEnum (assoc == R)) l - , ppr c - , prettyPrec (pC + fromEnum (assoc == L)) r - ] - _ -> prettyPrecApp p t r - SApp t1 t2 -> case t1 of - Syntax' _ (TConst c) _ _ -> - let ci = constInfo c - pC = fixity ci - in case constMeta ci of - ConstMUnOp P -> pparens (p > pC) $ ppr t1 <> prettyPrec (succ pC) t2 - ConstMUnOp S -> pparens (p > pC) $ prettyPrec (succ pC) t2 <> ppr t1 - _ -> prettyPrecApp p t1 t2 - _ -> prettyPrecApp p t1 t2 - SLet LSLet _ (LV _ x) mty _ t1 t2 -> - sep - [ prettyDefinition "let" x mty t1 <+> "in" - , ppr t2 - ] - SLet LSDef _ (LV _ x) mty _ t1 t2 -> - mconcat $ - prettyDefinition "def" x mty t1 <+> "end" - : case t2 of - Syntax' _ (TConst Noop) _ _ -> [] - _ -> [hardline, hardline, ppr t2] - STydef (LV _ x) pty _ t1 -> - mconcat $ - prettyTydef x pty - : case t1 of - Syntax' _ (TConst Noop) _ _ -> [] - _ -> [hardline, hardline, ppr t1] - SBind Nothing _ _ _ t1 t2 -> - pparens (p > 0) $ - prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2 - SBind (Just (LV _ x)) _ _ _ t1 t2 -> - pparens (p > 0) $ - pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2 - SRcd m -> brackets $ hsep (punctuate "," (map prettyEquality (M.assocs m))) - SProj t x -> prettyPrec 11 t <> "." <> pretty x - SAnnotate t pt -> - pparens (p > 0) $ - prettyPrec 1 t <+> ":" <+> ppr pt - SSuspend t -> - pparens (p > 10) $ - "suspend" <+> prettyPrec 11 t - -prettyEquality :: (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann -prettyEquality (x, Nothing) = pretty x -prettyEquality (x, Just t) = pretty x <+> "=" <+> ppr t - -prettyDefinition :: Doc ann -> Var -> Maybe Polytype -> Syntax' ty -> Doc ann -prettyDefinition defName x mty t1 = - nest 2 . sep $ - [ flatAlt - (defHead <> group defType <+> eqAndLambdaLine) - (defHead <> group defType' <+> defEqLambdas) - , ppr defBody - ] - where - (defBody, defLambdaList) = unchainLambdas t1 - defHead = defName <+> pretty x - defType = maybe "" (\ty -> ":" <+> flatAlt (line <> indent 2 (ppr ty)) (ppr ty)) mty - defType' = maybe "" (\ty -> ":" <+> ppr ty) mty - defEqLambdas = hsep ("=" : map prettyLambda defLambdaList) - eqAndLambdaLine = if null defLambdaList then "=" else line <> defEqLambdas - -prettyTydef :: Var -> Polytype -> Doc ann -prettyTydef x (Forall [] ty) = "tydef" <+> pretty x <+> "=" <+> ppr ty <+> "end" -prettyTydef x (Forall xs ty) = "tydef" <+> pretty x <+> hsep (map pretty xs) <+> "=" <+> ppr ty <+> "end" - -prettyPrecApp :: Int -> Syntax' ty -> Syntax' ty -> Doc a -prettyPrecApp p t1 t2 = - pparens (p > 10) $ - prettyPrec 10 t1 <+> prettyPrec 11 t2 - -appliedTermPrec :: Term -> Int -appliedTermPrec (TApp f _) = case f of - TConst c -> fixity $ constInfo c - _ -> appliedTermPrec f -appliedTermPrec _ = 10 - -prettyTuple :: Term' ty -> Doc a -prettyTuple = tupled . map ppr . unTuple . STerm . erase - -prettyLambdas :: Term' ty -> Doc a -prettyLambdas t = hsep (prettyLambda <$> lms) <> softline <> ppr rest - where - (rest, lms) = unchainLambdas (STerm (erase t)) - -unchainLambdas :: Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)]) -unchainLambdas = \case - Syntax' _ (SLam (LV _ x) mty body) _ _ -> ((x, mty) :) <$> unchainLambdas body - body -> (body, []) - -prettyLambda :: (Pretty a1, PrettyPrec a2) => (a1, Maybe a2) -> Doc ann -prettyLambda (x, mty) = "\\" <> pretty x <> maybe "" ((":" <>) . ppr) mty <> "." - ------------------------------------------------------------- --- Error messages - --- | Format a 'ContextualTypeError' for the user and render it as --- @Text@. -prettyTypeErrText :: Text -> ContextualTypeErr -> Text -prettyTypeErrText code = docToText . prettyTypeErr code - --- | Format a 'ContextualTypeError' for the user. -prettyTypeErr :: Text -> ContextualTypeErr -> Doc ann -prettyTypeErr code (CTE l tcStack te) = - vcat - [ teLoc <> ppr te - , ppr (BulletList "" (filterTCStack tcStack)) - ] - where - teLoc = case l of - SrcLoc s e -> (showLoc . fst $ getLocRange code (s, e)) <> ": " - NoLoc -> emptyDoc - showLoc (r, c) = pretty r <> ":" <> pretty c - --- | Filter the TCStack of extravagant Binds. -filterTCStack :: TCStack -> TCStack -filterTCStack tcStack = case tcStack of - [] -> [] - t@(LocatedTCFrame _ (TCLet _)) : _ -> [t] - t@(LocatedTCFrame _ TCBindR) : xs -> t : filterTCStack xs - t@(LocatedTCFrame _ TCBindL) : xs -> t : filterTCStack xs - -instance PrettyPrec TypeErr where - prettyPrec _ = \case - UnificationErr ue -> ppr ue - KindErr ke -> ppr ke - Mismatch Nothing (getJoin -> (ty1, ty2)) -> - "Type mismatch: expected" <+> ppr ty1 <> ", but got" <+> ppr ty2 - Mismatch (Just t) (getJoin -> (ty1, ty2)) -> - nest 2 . vcat $ - [ "Type mismatch:" - , "From context, expected" <+> pprCode t <+> "to" <+> typeDescription Expected ty1 <> "," - , "but it" <+> typeDescription Actual ty2 - ] - LambdaArgMismatch (getJoin -> (ty1, ty2)) -> - "Lambda argument has type annotation" <+> pprCode ty2 <> ", but expected argument type" <+> pprCode ty1 - FieldsMismatch (getJoin -> (expFs, actFs)) -> - fieldMismatchMsg expFs actFs - EscapedSkolem x -> - "Skolem variable" <+> pretty x <+> "would escape its scope" - UnboundVar x -> - "Unbound variable" <+> pretty x - DefNotTopLevel t -> - "Definitions may only be at the top level:" <+> pprCode t - CantInfer t -> - vsep - [ "Couldn't infer the type of term:" <+> pprCode t - , reportBug - ] - CantInferProj t -> - "Can't infer the type of a record projection:" <+> pprCode t - UnknownProj x t -> - "Record does not have a field with name" <+> pretty x <> ":" <+> pprCode t - InvalidAtomic reason t -> - "Invalid atomic block:" <+> ppr reason <> ":" <+> pprCode t - Impredicative -> - "Unconstrained unification type variables encountered, likely due to an impredicative type. This is a known bug; for more information see https://github.com/swarm-game/swarm/issues/351 ." - where - pprCode :: PrettyPrec a => a -> Doc ann - pprCode = bquote . ppr - -instance PrettyPrec UnificationError where - prettyPrec _ = \case - Infinite x uty -> - vsep - [ "Encountered infinite type" <+> ppr x <+> "=" <+> ppr uty <> "." - , "Swarm will not infer recursive types; if you want a recursive type, add an explicit type annotation." - ] - UnifyErr ty1 ty2 -> - "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2 - UndefinedUserType ty -> - "Undefined user type" <+> ppr ty - UnexpandedRecTy ty -> - vsep - [ "Unexpanded recursive type" <+> ppr ty <+> "encountered in unifyF." - , reportBug - ] - -instance PrettyPrec Arity where - prettyPrec _ (Arity a) = pretty a - -instance PrettyPrec KindError where - prettyPrec _ = \case - ArityMismatch c a tys -> - nest 2 . vsep $ - [ "Kind error:" - , hsep - [ ppr c - , "requires" - , pretty a - , "type" - , pretty (number a "argument" <> ",") - , "but was given" - , pretty (length tys) - ] - ] - ++ ["in the type:" <+> ppr (TyConApp c tys) | not (null tys)] - UndefinedTyCon tc _ty -> "Undefined type" <+> ppr tc - TrivialRecTy x ty -> - nest 2 . vsep $ - [ "Encountered trivial recursive type" <+> ppr (TyRec x ty) - , "Did you forget to use" <+> pretty x <+> "in the body of the type?" - ] - VacuousRecTy x ty -> - nest 2 . vsep $ - [ "Encountered vacuous recursive type" <+> ppr (TyRec x ty) - , "Recursive types must be productive, i.e. must not expand to themselves." - ] - --- | Given a type and its source, construct an appropriate description --- of it to go in a type mismatch error message. -typeDescription :: Source -> UType -> Doc a -typeDescription src ty - | not (hasAnyUVars ty) = - withSource src "have" "actually has" <+> "type" <+> bquote (ppr ty) - | Just f <- isTopLevelConstructor ty = - withSource src "be" "is actually" <+> tyNounPhrase f - | otherwise = - withSource src "have" "actually has" <+> "a type like" <+> bquote (ppr (fmap (const Wildcard) ty)) - --- | Check whether a type contains any unification variables at all. -hasAnyUVars :: UType -> Bool -hasAnyUVars = ucata (const True) or - --- | Check whether a type consists of a top-level type constructor --- immediately applied to unification variables. -isTopLevelConstructor :: UType -> Maybe (TypeF ()) -isTopLevelConstructor = \case - Free (TyRcdF m) | all isPure m -> Just (TyRcdF M.empty) - UTyConApp c ts | all isPure ts -> Just (TyConF c []) - _ -> Nothing - -isPure :: Free f a -> Bool -isPure (Pure {}) = True -isPure _ = False - --- | Return an English noun phrase describing things with the given --- top-level type constructor. -tyNounPhrase :: TypeF () -> Doc a -tyNounPhrase = \case - TyConF c _ -> tyConNounPhrase c - TyVarF {} -> "a type variable" - TyRcdF {} -> "a record" - TyRecF {} -> "a recursive type" - TyRecVarF {} -> "a recursive type variable" - -tyConNounPhrase :: TyCon -> Doc a -tyConNounPhrase = \case - TCBase b -> baseTyNounPhrase b - TCCmd -> "a command" - TCDelay -> "a delayed expression" - TCSum -> "a sum" - TCProd -> "a pair" - TCFun -> "a function" - TCUser t -> pretty t - --- | Return an English noun phrase describing things with the given --- base type. -baseTyNounPhrase :: BaseTy -> Doc a -baseTyNounPhrase = \case - BVoid -> "void" - BUnit -> "the unit value" - BInt -> "an integer" - BText -> "text" - BDir -> "a direction" - BBool -> "a boolean" - BActor -> "an actor" - BKey -> "a key" - --- | Generate an appropriate message when the sets of fields in two --- record types do not match, explaining which fields are extra and --- which are missing. -fieldMismatchMsg :: Set Var -> Set Var -> Doc a -fieldMismatchMsg expFs actFs = - nest 2 . vcat $ - ["Field mismatch; record literal has:"] - ++ ["- Extra field(s)" <+> prettyFieldSet extraFs | not (S.null extraFs)] - ++ ["- Missing field(s)" <+> prettyFieldSet missingFs | not (S.null missingFs)] - where - extraFs = actFs `S.difference` expFs - missingFs = expFs `S.difference` actFs - prettyFieldSet = hsep . punctuate "," . map (bquote . pretty) . S.toList - -instance PrettyPrec InvalidAtomicReason where - prettyPrec _ = \case - TooManyTicks n -> "block could take too many ticks (" <> pretty n <> ")" - AtomicDupingThing -> "def, let, and lambda are not allowed" - NonSimpleVarType _ ty -> - "reference to variable with non-simple type" <+> ppr (prettyTextLine ty) - NestedAtomic -> "nested atomic block" - LongConst -> "commands that can take multiple ticks to execute are not allowed" - AtomicSuspend -> - "encountered a suspend command inside an atomic block" <> hardline <> reportBug - -instance PrettyPrec LocatedTCFrame where - prettyPrec p (LocatedTCFrame _ f) = prettyPrec p f - -instance PrettyPrec TCFrame where - prettyPrec _ = \case - TCLet x -> "While checking the definition of" <+> pretty x - TCBindL -> "While checking the left-hand side of a semicolon" - TCBindR -> "While checking the right-hand side of a semicolon" diff --git a/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs b/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs --- a/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs +++ b/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs @@ -14,6 +14,7 @@ import Control.Algebra (Has, run) import Control.Carrier.Accum.Strict (execAccum) import Control.Carrier.Reader (runReader) +import Control.Carrier.Throw.Either (runThrow) import Control.Effect.Accum (Accum, add) import Control.Effect.Reader (Reader, ask, local) import Control.Monad (when) @@ -25,7 +26,9 @@ import Swarm.Language.Requirements.Type import Swarm.Language.Syntax import Swarm.Language.Syntax.Direction (isCardinal) +import Swarm.Language.TDVar (tdVarName) import Swarm.Language.Types +import Swarm.Util (applyWhen) -- | Infer the requirements to execute/evaluate a term in a given -- context. @@ -63,6 +66,7 @@ TAntiText _ -> pure () TBool _ -> pure () TSuspend {} -> pure () + TType {} -> pure () -- It doesn't require any special capability to *inquire* about -- the requirements of a term. TRequirements _ _ -> pure () @@ -70,8 +74,8 @@ -- constants using 'constCaps'. TConst c -> forM_ (constCaps c) (add . singletonCap) -- Simply record device or inventory requirements. - TRequireDevice d -> add (singletonDev d) - TRequire n e -> add (singletonInv n e) + TRequire d -> add (singletonDev d) + TStock n e -> add (singletonInv n e) -- Note that a variable might not show up in the context, and -- that's OK; if not, it just means using the variable requires -- no special capabilities. @@ -100,15 +104,18 @@ add (singletonCap CLambda) mapM_ typeRequirements mty local @ReqCtx (Ctx.delete x) $ go t - -- An application simply requires the union of the capabilities - -- from the left- and right-hand sides. This assumes that the - -- argument will be used at least once by the function. + -- Special case for 'use' with a device literal. + TApp t1@(TConst Use) t2@(TText device) -> + add (singletonDev device) *> go t1 *> go t2 + -- In general, an application simply requires the union of the + -- capabilities from the left- and right-hand sides. This assumes + -- that the argument will be used at least once by the function. TApp t1 t2 -> go t1 *> go t2 -- Similarly, for a let, we assume that the let-bound expression -- will be used at least once in the body. We delete the let-bound -- name from the context when recursing for the same reason as -- lambda. - TLet LSLet r x mty _ t1 t2 -> do + TLet LSLet r x mty _ _ t1 t2 -> do when r $ add (singletonCap CRecursion) add (singletonCap CEnv) mapM_ polytypeRequirements mty @@ -116,14 +123,14 @@ -- However, for def, we do NOT assume that the defined expression -- will be used at least once in the body; it may not be executed -- until later on, when the base robot has more capabilities. - TLet LSDef r x mty _ t1 t2 -> do + TLet LSDef r x mty _ _ t1 t2 -> do add (singletonCap CEnv) mapM_ polytypeRequirements mty localReqCtx <- ask @ReqCtx localTDCtx <- ask @TDCtx let bodyReqs = - (if r then (singletonCap CRecursion <>) else id) - (requirements localTDCtx localReqCtx t1) + applyWhen r (singletonCap CRecursion <>) $ + requirements localTDCtx localReqCtx t1 local @ReqCtx (Ctx.addBinding x bodyReqs) $ go t2 -- Using tydef requires CEnv, plus whatever the requirements are -- for the type itself. @@ -140,7 +147,7 @@ -- symptom of the fact that typechecking, kind checking, and -- requirements checking really all need to be done at the same -- time during a single traversal of the term (see #231). - local @TDCtx (Ctx.addBinding x (TydefInfo ty (Arity . length . ptVars $ ty))) (go t2) + local @TDCtx (addBindingTD (tdVarName x) (TydefInfo ty (Arity . length . ptVars $ ty))) (go t2) -- We also delete the name in a TBind, if any, while recursing on -- the RHS. TBind mx _ _ t1 t2 -> do @@ -156,12 +163,13 @@ TProj t _ -> add (singletonCap CRecord) *> go t -- A type ascription doesn't change requirements TAnnotate t ty -> go t *> polytypeRequirements ty + TParens t -> go t polytypeRequirements :: (Has (Accum Requirements) sig m, Has (Reader TDCtx) sig m) => - Polytype -> + Poly q Type -> m () -polytypeRequirements (Forall _ ty) = typeRequirements ty +polytypeRequirements = typeRequirements . ptBody typeRequirements :: (Has (Accum Requirements) sig m, Has (Reader TDCtx) sig m) => @@ -172,11 +180,19 @@ go (Fix tyF) = goF tyF goF = \case - TyVarF _ -> pure () + TyVarF _ _ -> pure () TyConF (TCUser u) tys -> do mapM_ go tys - ty' <- expandTydef u tys - go ty' + res <- runThrow @ExpandTydefErr (expandTydef u tys) + case res of + -- If the user tycon is undefined, just return 0 requirements. + -- This is not really correct---it should be some kind of + -- error---but in theory it should be impossible for a user + -- tycon to be undefined, and adding error propagation here + -- would be annoying. The undefined tycon can be caught + -- somewhere else. + Left _ -> pure () + Right ty' -> go ty' TyConF c tys -> do case c of TCSum -> add (singletonCap CSum) diff --git a/src/swarm-lang/Swarm/Language/Requirements/Type.hs b/src/swarm-lang/Swarm/Language/Requirements/Type.hs --- a/src/swarm-lang/Swarm/Language/Requirements/Type.hs +++ b/src/swarm-lang/Swarm/Language/Requirements/Type.hs @@ -30,13 +30,14 @@ import GHC.Generics (Generic) import Swarm.Language.Capability (Capability (..)) import Swarm.Language.Context (Ctx) +import Swarm.Language.Var -- | A /requirement/ is something a robot must have when it is -- built. There are three types: -- - A robot can require a certain 'Capability', which should be fulfilled -- by equipping an appropriate device. -- - A robot can require a specific /device/, which should be equipped. --- - A robot can require some number of a specific entity in its inventory. +-- - A robot can stock some number of a specific entity in its inventory. data Requirement = -- | Require a specific capability. This must be fulfilled by -- equipping an appropriate device. Requiring the same @@ -53,7 +54,7 @@ -- Requiring the same device multiple times is the same as -- requiring it once. ReqDev Text - | -- | Require a certain number of a specific entity to be available + | -- | Stock a certain number of a specific entity to be available -- in the inventory. The same comments apply re: resolving the -- entity name to an actual 'Swarm.Game.Entity.Entity'. -- @@ -61,7 +62,7 @@ -- of entity @"e"@ and later requiring 7 is the same as requiring -- 12. ReqInv Int Text - deriving (Eq, Ord, Show, Read, Generic, Hashable, Data, FromJSON, ToJSON) + deriving (Eq, Ord, Show, Generic, Hashable, Data, FromJSON, ToJSON) -- | It is tempting to define @Requirements = Set Requirement@, but -- that would be wrong, since two identical 'ReqInv' should have @@ -75,7 +76,7 @@ , devReqs :: Set Text , invReqs :: Map Text Int } - deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON) + deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON, Hashable) instance Semigroup Requirements where Requirements c1 d1 i1 <> Requirements c2 d2 i2 = @@ -110,4 +111,4 @@ -- | A requirement context records the requirements for the -- definitions bound to variables. -type ReqCtx = Ctx Requirements +type ReqCtx = Ctx Var Requirements diff --git a/src/swarm-lang/Swarm/Language/Syntax.hs b/src/swarm-lang/Swarm/Language/Syntax.hs --- a/src/swarm-lang/Swarm/Language/Syntax.hs +++ b/src/swarm-lang/Swarm/Language/Syntax.hs @@ -31,7 +31,8 @@ -- * SrcLoc SrcLoc (..), - srcLocBefore, + srcLocStartsBefore, + srcLocEndsBefore, noLoc, -- * Comments @@ -54,7 +55,8 @@ USyntax, pattern Syntax, pattern CSyntax, - LocVar (..), + Located (..), + LocVar, LetSyntax (..), pattern STerm, pattern TRequirements, @@ -70,10 +72,10 @@ pattern TProj, pattern TAnnotate, pattern TSuspend, + pattern TParens, -- * Terms Var, - DelayType (..), Term' (..), Term, TTerm, @@ -103,5 +105,6 @@ import Swarm.Language.Syntax.Constants import Swarm.Language.Syntax.Loc import Swarm.Language.Syntax.Pattern +import Swarm.Language.Syntax.Pretty () import Swarm.Language.Syntax.Util import Swarm.Language.Types diff --git a/src/swarm-lang/Swarm/Language/Syntax/AST.hs b/src/swarm-lang/Swarm/Language/Syntax/AST.hs --- a/src/swarm-lang/Swarm/Language/Syntax/AST.hs +++ b/src/swarm-lang/Swarm/Language/Syntax/AST.hs @@ -5,18 +5,18 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- Types represeting the surface syntax and terms for Swarm programming language. +-- Types representing the surface syntax and terms for Swarm programming language. module Swarm.Language.Syntax.AST ( Syntax' (..), LetSyntax (..), Term' (..), - DelayType (..), ) where import Control.Lens (Plated (..)) import Data.Aeson.Types hiding (Key) import Data.Data (Data) import Data.Data.Lens (uniplate) +import Data.Hashable (Hashable) import Data.Map.Strict (Map) import Data.Text (Text) import GHC.Generics (Generic) @@ -25,6 +25,7 @@ import Swarm.Language.Syntax.Constants import Swarm.Language.Syntax.Direction import Swarm.Language.Syntax.Loc +import Swarm.Language.TDVar (TDVar) import Swarm.Language.Types ------------------------------------------------------------ @@ -38,17 +39,21 @@ , _sComments :: Comments , _sType :: ty } - deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic) + deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic, Hashable) instance Data ty => Plated (Syntax' ty) where plate = uniplate -- | A @let@ expression can be written either as @let x = e1 in e2@ or -- as @def x = e1 end; e2@. This enumeration simply records which it --- was so that we can pretty-print appropriatly. +-- was so that we can pretty-print appropriately. data LetSyntax = LSLet | LSDef - deriving (Eq, Ord, Show, Bounded, Enum, Generic, Data, ToJSON, FromJSON) + deriving (Eq, Ord, Show, Bounded, Enum, Generic, Data, Hashable, ToJSON, FromJSON) +------------------------------------------------------------ +-- Term: basic syntax tree +------------------------------------------------------------ + -- | Terms of the Swarm language. data Term' ty = -- | The unit value. @@ -67,6 +72,8 @@ TAntiText Text | -- | A Boolean literal. TBool Bool + | -- | An antiquoted Haskell variable name of type Syntax. + TAntiSyn Text | -- | A robot reference. These never show up in surface syntax, but are -- here so we can factor pretty-printing for Values through -- pretty-printing for Terms. @@ -75,9 +82,9 @@ -- but are here to facilitate pretty-printing. TRef Int | -- | Require a specific device to be installed. - TRequireDevice Text + TRequire Text | -- | Require a certain number of an entity. - TRequire Int Text + TStock Int Text | -- | Primitive command to log requirements of a term. The Text -- field is to store the unaltered original text of the term, for use -- in displaying the log message (since once we get to execution time the @@ -97,14 +104,15 @@ -- annotation on the variable. The @Bool@ indicates whether -- it is known to be recursive. -- - -- The @Maybe Requirements@ field is only for annotating the - -- requirements of a definition after typechecking; there is no - -- way to annotate requirements in the surface syntax. - SLet LetSyntax Bool LocVar (Maybe Polytype) (Maybe Requirements) (Syntax' ty) (Syntax' ty) + -- The @Maybe Polytype@ and @Maybe Requirements@ fields are only + -- for annotating the requirements of a definition after + -- typechecking; there is no way to annotate requirements in the + -- surface syntax. + SLet LetSyntax Bool LocVar (Maybe RawPolytype) (Maybe Polytype) (Maybe Requirements) (Syntax' ty) (Syntax' ty) | -- | A type synonym definition. Note that this acts like a @let@ -- (just like @def@), /i.e./ the @Syntax' ty@ field is the local -- context over which the type definition is in scope. - STydef LocVar Polytype (Maybe TydefInfo) (Syntax' ty) + STydef (Located TDVar) Polytype (Maybe TydefInfo) (Syntax' ty) | -- | A monadic bind for commands, of the form @c1 ; c2@ or @x <- c1; c2@. -- -- The @Maybe ty@ field is a place to stash the inferred type of @@ -133,10 +141,17 @@ | -- | Record projection @e.x@ SProj (Syntax' ty) Var | -- | Annotate a term with a type - SAnnotate (Syntax' ty) Polytype + SAnnotate (Syntax' ty) RawPolytype | -- | Run the given command, then suspend and wait for a new REPL -- input. SSuspend (Syntax' ty) + | -- | An explicit representation of parentheses in the input. We + -- need this to be able to print formatted code with parentheses + -- and comments preserved, but we get rid of them during + -- elaboration. + SParens (Syntax' ty) + | -- | A type literal. + TType Type deriving ( Eq , Show @@ -144,6 +159,7 @@ , Foldable , Data , Generic + , Hashable , -- | The Traversable instance for Term (and for Syntax') is used during -- typechecking: during intermediate type inference, many of the type -- annotations placed on AST nodes will have unification variables in @@ -157,24 +173,3 @@ instance Data ty => Plated (Term' ty) where plate = uniplate - ------------------------------------------------------------- --- Basic terms ------------------------------------------------------------- - --- | Different runtime behaviors for delayed expressions. -data DelayType - = -- | A simple delay, implemented via a (non-memoized) @VDelay@ - -- holding the delayed expression. - SimpleDelay - | -- | A memoized delay, implemented by allocating a mutable cell - -- with the delayed expression and returning a reference to it. - -- When the @Maybe Var@ is @Just@, a recursive binding of the - -- variable with a reference to the delayed expression will be - -- provided while evaluating the delayed expression itself. Note - -- that there is no surface syntax for binding a variable within - -- a recursive delayed expression; the only way we can get - -- @Just@ here is when we automatically generate a delayed - -- expression while interpreting a recursive @let@ or @def@. - MemoizedDelay (Maybe Var) - deriving (Eq, Show, Data, Generic, FromJSON, ToJSON) diff --git a/src/swarm-lang/Swarm/Language/Syntax/Comments.hs b/src/swarm-lang/Swarm/Language/Syntax/Comments.hs --- a/src/swarm-lang/Swarm/Language/Syntax/Comments.hs +++ b/src/swarm-lang/Swarm/Language/Syntax/Comments.hs @@ -25,19 +25,22 @@ import Data.Aeson qualified as A import Data.Aeson.Types hiding (Key) import Data.Data (Data) +import Data.Hashable (Hashable) import Data.Sequence (Seq) -import Data.Text hiding (filter, length, map) +import Data.Text (Text) import GHC.Generics (Generic) +import Prettyprinter (pretty) import Swarm.Language.Syntax.Loc +import Swarm.Pretty (PrettyPrec (..)) -- | Line vs block comments. data CommentType = LineComment | BlockComment - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Data, ToJSON, FromJSON) + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Data, Hashable, ToJSON, FromJSON) -- | Was a comment all by itself on a line, or did it occur after some -- other tokens on a line? data CommentSituation = StandaloneComment | SuffixComment - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Data, ToJSON, FromJSON) + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Data, Hashable, ToJSON, FromJSON) -- | Test whether a comment is a standalone comment or not. isStandalone :: Comment -> Bool @@ -53,15 +56,19 @@ , commentSituation :: CommentSituation , commentText :: Text } - deriving (Eq, Show, Generic, Data, ToJSON, FromJSON) + deriving (Eq, Show, Generic, Data, ToJSON, FromJSON, Hashable) +instance PrettyPrec Comment where + prettyPrec _ (Comment _ LineComment _ txt) = "//" <> pretty txt + prettyPrec _ (Comment _ BlockComment _ txt) = "/*" <> pretty txt <> "*/" + -- | Comments which can be attached to a particular AST node. Some -- comments come textually before the node and some come after. data Comments = Comments { _beforeComments :: Seq Comment , _afterComments :: Seq Comment } - deriving (Eq, Show, Generic, Data) + deriving (Eq, Show, Generic, Data, Hashable) makeLenses ''Comments diff --git a/src/swarm-lang/Swarm/Language/Syntax/Constants.hs b/src/swarm-lang/Swarm/Language/Syntax/Constants.hs --- a/src/swarm-lang/Swarm/Language/Syntax/Constants.hs +++ b/src/swarm-lang/Swarm/Language/Syntax/Constants.hs @@ -29,14 +29,17 @@ import Data.Aeson.Types hiding (Key) import Data.Data (Data) +import Data.Hashable (Hashable) import Data.Int (Int32) import Data.List.Extra (enumerate) import Data.Set (Set) import Data.Set qualified as Set -import Data.Text hiding (filter, length, map) +import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) +import Prettyprinter (pretty) import Swarm.Language.Syntax.CommandMetadata +import Swarm.Pretty (PrettyPrec (..), pparens) import Swarm.Util (showT) ------------------------------------------------------------ @@ -143,15 +146,18 @@ Scout | -- | Get the current x, y coordinates Whereami - | -- | Get the x, y coordinates of a named waypoint, by index - Waypoint - | -- | Get the x, y coordinates of southwest corner of a constructed structure, by index - Structure + | -- | Get the current subworld and x, y coordinates + LocateMe + | -- | Get the list of x, y coordinates of the waypoints for a given name + Waypoints + | -- | Get the list of x, y coordinates of the southwest corner of all + -- constructed structures of a given name + Structures | -- | Get the width and height of a structure template Floorplan | -- | Answer whether a given entity has the given tag HasTag - | -- | Cycle through the entity names that are labeled with a given tag + | -- | Get the list of entity names that are labeled with a given tag TagMembers | -- | Locate the closest instance of a given entity within the rectangle -- specified by opposite corners, relative to the current location. @@ -212,14 +218,12 @@ Inr | -- | Case analysis on a sum type. Case - | -- | First projection. - Fst - | -- | Second projection. - Snd + | -- | Pair eliminator. + Match | -- | Force a delayed evaluation. Force - | -- | Return for the cmd monad. - Return + | -- | Pure for the cmd monad. + Pure | -- | Try/catch block Try | -- | Undefined @@ -266,6 +270,12 @@ -- | Turn an arbitrary value into a string Format + | -- | Try to turn a string into a value + Read + | -- | Print a string onto a printable surface + Print + | -- | Erase a printable surface + Erase | -- | Concatenate string values Concat | -- | Count number of characters. @@ -301,6 +311,8 @@ -- | Teleport a robot to the given position. Teleport + | -- | Relocate a robot to the given cosmic position. + Warp | -- | Run a command as if you were another robot. As | -- | Find an actor by name. @@ -309,8 +321,11 @@ RobotNumbered | -- | Check if an entity is known. Knows - deriving (Eq, Ord, Enum, Bounded, Data, Show, Generic, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + deriving (Eq, Ord, Enum, Bounded, Data, Show, Generic, Hashable, FromJSON, ToJSON, FromJSONKey, ToJSONKey) +instance PrettyPrec Const where + prettyPrec p c = pparens (p > fixity (constInfo c)) $ pretty . syntax . constInfo $ c + allConst :: [Const] allConst = enumerate @@ -615,7 +630,7 @@ Use -> command 2 long . doc (Set.singleton $ Mutation EntityChange) "Use one entity upon another." $ [ "Which entities you can `use` with others depends on the available recipes." - , "The object being used must be a 'required' entity in a recipe." + , "The object being used must be a 'stocked' entity in a recipe." ] Build -> command 1 long . doc (Set.singleton $ Mutation $ RobotChange ExistenceChange) "Construct a new robot." $ @@ -642,7 +657,7 @@ <> "that is done automatically once you have a listening device equipped." , "Note that you can see the messages either in your logger device or the message panel." ] - Log -> command 1 short $ shortDoc (Set.singleton $ Mutation LogEmission) "Log the string in the robot's logger." + Log -> command 1 Intangible $ shortDoc (Set.singleton $ Mutation LogEmission) "Log the string in the robot's logger." View -> command 1 short . doc (Set.singleton $ Query $ Sensing RobotSensing) "View the given actor." $ [ "This will recenter the map on the target robot and allow its inventory and logs to be inspected." @@ -672,36 +687,33 @@ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Get the current x and y coordinates." - Waypoint -> - command 2 Intangible . doc (Set.singleton $ Query APriori) "Get the x, y coordinates of a named waypoint, by index" $ - [ "Return only the waypoints in the same subworld as the calling robot." - , "Since waypoint names can have plural multiplicity, returns a tuple of (count, (x, y))." - , "The supplied index will be wrapped automatically, modulo the waypoint count." - , "A robot can use the count to know whether they have iterated over the full waypoint circuit." - ] - Structure -> - command 2 Intangible . doc (Set.singleton $ Query $ Sensing EntitySensing) "Get the x, y coordinates of the southwest corner of a constructed structure, by name and index" $ - [ "The outermost type of the return value indicates whether any structure of such name exists." - , "Since structures can have multiple occurrences, returns a tuple of (count, (x, y))." - , "The supplied index will be wrapped automatically, modulo the structure count." - , "A robot can use the count to know whether they have iterated over the full structure list." + LocateMe -> + command 0 Intangible $ + shortDoc + (Set.singleton $ Query $ Sensing RobotSensing) + "Get the current subworld and x, y coordinates." + Waypoints -> + function 1 . doc (Set.singleton $ Query APriori) "Get the list of x, y coordinates of a named waypoint" $ + [ "Returns only the waypoints in the same subworld as the calling robot." + , "Since waypoint names can have plural multiplicity, returns a list of (x, y) coordinates)." ] + Structures -> + command 1 Intangible . doc (Set.singleton $ Query $ Sensing EntitySensing) "Get the x, y coordinates of the southwest corner of all constructed structures of a given name" $ + ["Since structures can have multiple occurrences, returns a list of (x, y) coordinates."] Floorplan -> command 1 Intangible . doc (Set.singleton $ Query APriori) "Get the dimensions of a structure template" $ [ "Returns a tuple of (width, height) for the structure of the requested name." , "Yields an error if the supplied string is not the name of a structure." ] HasTag -> - command 2 Intangible . doc (Set.singleton $ Query APriori) "Check whether the given entity has the given tag" $ + function 2 . doc (Set.singleton $ Query APriori) "Check whether the given entity has the given tag" $ [ "Returns true if the first argument is an entity that is labeled by the tag in the second argument." , "Yields an error if the first argument is not a valid entity." ] TagMembers -> - command 2 Intangible . doc (Set.singleton $ Query APriori) "Get the entities labeled by a tag." $ - [ "Returns a tuple of (member count, entity)." - , "The supplied index will be wrapped automatically, modulo the member count." - , "A robot can use the count to know whether they have iterated over the full list." - , "Item order is determined by definition sequence in the scenario file." + function 1 . doc (Set.singleton $ Query APriori) "Get the entities labeled by a tag." $ + [ "Returns a list of all entities with the given tag." + , "The order of the list is determined by the definition sequence in the scenario file." ] Detect -> command 2 Intangible . doc (Set.singleton $ Query $ Sensing EntitySensing) "Detect an entity within a rectangle." $ @@ -769,7 +781,7 @@ command 1 Intangible . doc (Set.singleton $ Query PRNG) "Get a uniformly random integer." $ ["The random integer will be chosen from the range 0 to n-1, exclusive of the argument."] Run -> command 1 long $ shortDoc (Set.singleton $ Mutation $ RobotChange BehaviorChange) "Run a program loaded from a file." - Return -> command 1 Intangible $ shortDoc Set.empty "Make the value a result in `cmd`." + Pure -> command 1 Intangible $ shortDoc Set.empty "Create a pure `Cmd a`{=type} computation that yields the given value." Try -> command 2 Intangible $ shortDoc Set.empty "Execute a command, catching errors." Undefined -> function 0 $ shortDoc Set.empty "A value of any type, that is evaluated as error." Fail -> function 1 $ shortDoc Set.empty "A value of any type, that is evaluated as error with message." @@ -779,8 +791,7 @@ Inl -> function 1 $ shortDoc Set.empty "Put the value into the left component of a sum type." Inr -> function 1 $ shortDoc Set.empty "Put the value into the right component of a sum type." Case -> function 3 $ shortDoc Set.empty "Evaluate one of the given functions on a value of sum type." - Fst -> function 1 $ shortDoc Set.empty "Get the first value of a pair." - Snd -> function 1 $ shortDoc Set.empty "Get the second value of a pair." + Match -> function 2 $ shortDoc Set.empty "Do something with both components of a pair." Force -> function 1 $ shortDoc Set.empty "Force the evaluation of a delayed value." Not -> function 1 $ shortDoc Set.empty "Negate the boolean value." Neg -> unaryOp "-" 7 P $ shortDoc Set.empty "Negate the given integer value." @@ -798,6 +809,26 @@ Leq -> binaryOp "<=" 4 N $ shortDoc Set.empty "Check that the left value is lesser or equal to the right one." Geq -> binaryOp ">=" 4 N $ shortDoc Set.empty "Check that the left value is greater or equal to the right one." Format -> function 1 $ shortDoc Set.empty "Turn an arbitrary value into a string." + Read -> function 2 $ shortDoc Set.empty "Try to read a string into a value of the expected type." + Print -> + command 2 short + . doc + (Set.singleton $ Mutation $ RobotChange InventoryChange) + "Print text onto an entity." + $ [ "`print p txt` Consumes one printable `p` entity from your inventory, and produces an entity" + , "whose name is concatenated with a colon and the given text." + , "In conjunction with `format`, this can be used to print values onto entities such as `paper`{=entity}" + , "and give them to other robots, which can reconstitute the values with `read`." + ] + Erase -> + command 1 short + . doc + (Set.singleton $ Mutation $ RobotChange InventoryChange) + "Erase an entity." + $ [ "Consumes the named printable entity from your inventory, which must have something" + , "printed on it, and produces an erased entity. This can be used to undo" + , "the effects of a `print` command." + ] Concat -> binaryOp "++" 6 R $ shortDoc Set.empty "Concatenate the given strings." Chars -> function 1 $ shortDoc Set.empty "Counts the number of characters in the text." Split -> @@ -818,7 +849,7 @@ AppF -> binaryOp "$" 0 R . doc Set.empty "Apply the function on the left to the value on the right." $ [ "This operator is useful to avoid nesting parentheses." - , "For exaple:" + , "For example:" , "`f $ g $ h x = f (g (h x))`" ] Swap -> @@ -846,6 +877,7 @@ , "The second argument is a function to handle keyboard inputs." ] Teleport -> command 2 short $ shortDoc (Set.singleton $ Mutation $ RobotChange PositionChange) "Teleport a robot to the given location." + Warp -> command 2 short $ shortDoc (Set.singleton $ Mutation $ RobotChange PositionChange) "Relocate a robot to the given cosmic location." As -> command 2 Intangible $ shortDoc (Set.singleton $ Mutation $ RobotChange BehaviorChange) "Hypothetically run a command as if you were another robot." RobotNamed -> command 1 Intangible $ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Find an actor by name." RobotNumbered -> command 1 Intangible $ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Find an actor by number." @@ -887,7 +919,7 @@ } lowShow :: Show a => a -> Text - lowShow = toLower . showT + lowShow = T.toLower . showT -- | Maximum perception distance for -- 'Chirp' and 'Sniff' commands diff --git a/src/swarm-lang/Swarm/Language/Syntax/Loc.hs b/src/swarm-lang/Swarm/Language/Syntax/Loc.hs --- a/src/swarm-lang/Swarm/Language/Syntax/Loc.hs +++ b/src/swarm-lang/Swarm/Language/Syntax/Loc.hs @@ -8,14 +8,17 @@ -- Types for working with locations of something in source code. module Swarm.Language.Syntax.Loc ( SrcLoc (..), - LocVar (..), - srcLocBefore, + Located (..), + LocVar, + srcLocStartsBefore, + srcLocEndsBefore, ) where import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) import Data.Data (Data) +import Data.Hashable (Hashable) import GHC.Generics (Generic) -import Swarm.Language.Context (Var) +import Swarm.Language.Var (Var) import Swarm.Util.JSON (optionsUntagged) ------------------------------------------------------------ @@ -28,13 +31,15 @@ = NoLoc | -- | Half-open interval from start (inclusive) to end (exclusive) SrcLoc Int Int - deriving (Eq, Ord, Show, Data, Generic) + deriving (Eq, Ord, Show, Data, Generic, Hashable) instance ToJSON SrcLoc where toJSON = genericToJSON optionsUntagged + omitField = (== NoLoc) instance FromJSON SrcLoc where parseJSON = genericParseJSON optionsUntagged + omittedField = Just NoLoc -- | @x <> y@ is the smallest 'SrcLoc' that subsumes both @x@ and @y@. instance Semigroup SrcLoc where @@ -47,15 +52,24 @@ instance Monoid SrcLoc where mempty = NoLoc --- | Check whether one @SrcLoc@ starts at or before another one, +-- | Check whether one @SrcLoc@ starts before another one, -- /i.e./ compare their starting indices to see if the first is @<=@ -- the second. -srcLocBefore :: SrcLoc -> SrcLoc -> Bool -srcLocBefore (SrcLoc a _) (SrcLoc b _) = a <= b -srcLocBefore _ _ = False +srcLocStartsBefore :: SrcLoc -> SrcLoc -> Bool +srcLocStartsBefore (SrcLoc a _) (SrcLoc b _) = a <= b +srcLocStartsBefore _ _ = False +-- | Check whether the first @SrcLoc@ ends before the second, /i.e./ +-- compare their ending indices to see if the first is @<=@ the +-- second. +srcLocEndsBefore :: SrcLoc -> SrcLoc -> Bool +srcLocEndsBefore (SrcLoc _ a) (SrcLoc _ b) = a <= b +srcLocEndsBefore _ _ = False + -- | A variable with associated source location, used for variable -- binding sites. (Variable occurrences are a bare TVar which gets -- wrapped in a Syntax node, so we don't need LocVar for those.) -data LocVar = LV {lvSrcLoc :: SrcLoc, lvVar :: Var} - deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON) +data Located v = LV {lvSrcLoc :: SrcLoc, lvVar :: v} + deriving (Eq, Ord, Functor, Show, Data, Generic, Hashable, FromJSON, ToJSON) + +type LocVar = Located Var diff --git a/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs b/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs --- a/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs +++ b/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs @@ -30,6 +30,7 @@ pattern TProj, pattern TAnnotate, pattern TSuspend, + pattern TParens, Term, TTerm, UTerm, @@ -38,11 +39,12 @@ import Control.Lens (makeLenses, pattern Empty) import Data.Map.Strict (Map) -import Data.Text hiding (filter, length, map) +import Data.Text (Text) import Swarm.Language.Requirements.Type (Requirements) import Swarm.Language.Syntax.AST import Swarm.Language.Syntax.Comments import Swarm.Language.Syntax.Loc +import Swarm.Language.TDVar import Swarm.Language.Types -- | Syntax without type annotations. @@ -58,7 +60,9 @@ -- | Raw parsed syntax, without comments or type annotations. pattern Syntax :: SrcLoc -> Term -> Syntax -pattern Syntax l t = Syntax' l t Empty () +pattern Syntax l t <- Syntax' l t _ () + where + Syntax l t = Syntax' l t Empty () {-# COMPLETE Syntax #-} @@ -104,13 +108,13 @@ pattern (:$:) t1 s2 = SApp (STerm t1) s2 -- | Match a TLet without annotations. -pattern TLet :: LetSyntax -> Bool -> Var -> Maybe Polytype -> Maybe Requirements -> Term -> Term -> Term -pattern TLet ls r v mty mreq t1 t2 <- SLet ls r (lvVar -> v) mty mreq (STerm t1) (STerm t2) +pattern TLet :: LetSyntax -> Bool -> Var -> Maybe RawPolytype -> Maybe Polytype -> Maybe Requirements -> Term -> Term -> Term +pattern TLet ls r v mty mpty mreq t1 t2 <- SLet ls r (lvVar -> v) mty mpty mreq (STerm t1) (STerm t2) where - TLet ls r v mty mreq t1 t2 = SLet ls r (LV NoLoc v) mty mreq (STerm t1) (STerm t2) + TLet ls r v mty mpty mreq t1 t2 = SLet ls r (LV NoLoc v) mty mpty mreq (STerm t1) (STerm t2) -- | Match a STydef without annotations. -pattern TTydef :: Var -> Polytype -> Maybe TydefInfo -> Term -> Term +pattern TTydef :: TDVar -> Polytype -> Maybe TydefInfo -> Term -> Term pattern TTydef v ty mtd t1 <- STydef (lvVar -> v) ty mtd (STerm t1) where TTydef v ty mtd t1 = STydef (LV NoLoc v) ty mtd (STerm t1) @@ -135,13 +139,17 @@ pattern TProj t x = SProj (STerm t) x -- | Match a TAnnotate without annotations. -pattern TAnnotate :: Term -> Polytype -> Term +pattern TAnnotate :: Term -> RawPolytype -> Term pattern TAnnotate t pt = SAnnotate (STerm t) pt -- | Match a TSuspend without annotations. pattern TSuspend :: Term -> Term pattern TSuspend t = SSuspend (STerm t) +-- | Match a TParens without annotations. +pattern TParens :: Term -> Term +pattern TParens t = SParens (STerm t) + -- COMPLETE pragma tells GHC using this set of patterns is complete for Term -{-# COMPLETE TUnit, TConst, TDir, TInt, TAntiInt, TText, TAntiText, TBool, TRequireDevice, TRequire, TRequirements, TVar, TPair, TLam, TApp, TLet, TTydef, TBind, TDelay, TRcd, TProj, TAnnotate, TSuspend #-} +{-# COMPLETE TUnit, TConst, TDir, TInt, TAntiInt, TText, TAntiText, TBool, TRequire, TStock, TRequirements, TVar, TPair, TLam, TApp, TLet, TTydef, TBind, TDelay, TRcd, TProj, TAnnotate, TSuspend, TParens #-} diff --git a/src/swarm-lang/Swarm/Language/Syntax/Pretty.hs b/src/swarm-lang/Swarm/Language/Syntax/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax/Pretty.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- We could avoid orphan instances by placing these PrettyPrec +-- instances in Swarm.Language.Syntax.AST, along with the declarations +-- of the types we are making PrettyPrec instances for, but the code +-- here depends nontrivially on stuff in other Swarm.Language.Syntax.* +-- modules, so that would require putting a whole bunch of stuff all +-- in the same module. It seemed like a much better option to have +-- code split out into separate modules and disable orphan instance +-- warnings in this one. + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Pretty-printing for terms in the Swarm programming language. +module Swarm.Language.Syntax.Pretty ( + +) where + +import Control.Lens ((&), (<>~)) +import Control.Lens.Empty (pattern Empty) +import Data.Bool (bool) +import Data.Foldable qualified as F +import Data.Map qualified as M +import Data.Sequence qualified as Seq +import Data.String (fromString) +import Prettyprinter +import Swarm.Language.Syntax.AST +import Swarm.Language.Syntax.Comments +import Swarm.Language.Syntax.Constants +import Swarm.Language.Syntax.Loc +import Swarm.Language.Syntax.Pattern (sComments, pattern STerm) +import Swarm.Language.Syntax.Util (erase, unTuple) +import Swarm.Language.TDVar (TDVar) +import Swarm.Language.Types +import Swarm.Pretty (PrettyPrec (..), encloseWithIndent, pparens, ppr, prettyEquality) +import Text.Show.Unicode (ushow) + +-- | Pretty-print a syntax node with comments. +instance PrettyPrec (Syntax' ty) where + prettyPrec p (Syntax' _ t (Comments before after) _) = case before of + Empty -> t' + _ -> + -- Print out any comments before the node + mconcat + [ vsep (map ppr (F.toList before)) + , hardline + , t' + ] + where + -- Print the node itself, possibly with suffix comments on the same line + t' = case Seq.viewr after of + Seq.EmptyR -> prettyPrec p t + _ Seq.:> lst -> case commentType lst of + -- Output a newline after a line comment, but not after a block comment + BlockComment -> tWithComments + LineComment -> tWithComments <> hardline + where + -- The pretty-printed node with suffix comments + tWithComments = prettyPrec p t <+> hsep (map ppr (F.toList after)) + +instance PrettyPrec (Term' ty) where + prettyPrec p = \case + TUnit -> "()" + TConst c -> prettyPrec p c + TDir d -> ppr d + TInt n -> pretty n + TAntiInt v -> "$int:" <> pretty v + TText s -> fromString (ushow s) + TAntiText v -> "$str:" <> pretty v + TAntiSyn v -> "$syn:" <> pretty v + TBool b -> bool "false" "true" b + TRobot r -> " pretty r <> ">" + TRef r -> "@" <> pretty r + TRequire d -> pparens (p > 10) $ "require" <+> ppr (TText d) + TStock n e -> pparens (p > 10) $ "stock" <+> pretty n <+> ppr (TText e) + SRequirements _ e -> pparens (p > 10) $ "requirements" <+> ppr e + TVar s -> ppr s + SDelay (Syntax' _ (TConst Noop) _ _) -> "{}" + SDelay t -> group . encloseWithIndent 2 lbrace rbrace $ ppr t + t@SPair {} -> prettyTuple t + t@SLam {} -> + pparens (p > 9) $ + prettyLambdas t + -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3. + -- Note a comment right after the operator will end up attached to + -- the application of the operator to the first argument. + SApp t@(Syntax' _ (SApp op@(Syntax' _ (TConst c) _ _) l) opcom _) r -> + let ci = constInfo c + pC = fixity ci + in case constMeta ci of + ConstMBinOp assoc -> + pparens (p > pC) $ + hsep + [ prettyPrec (pC + fromEnum (assoc == R)) l + , -- pretty-print the operator with comments reattached + ppr (op {_sComments = opcom}) + , prettyPrec (pC + fromEnum (assoc == L)) r + ] + _ -> prettyPrecApp p t r + SApp t1 t2 -> case t1 of + Syntax' _ (TConst c) _ _ -> + let ci = constInfo c + pC = fixity ci + in case constMeta ci of + ConstMUnOp P -> pparens (p > pC) $ ppr t1 <> prettyPrec (succ pC) t2 + ConstMUnOp S -> pparens (p > pC) $ prettyPrec (succ pC) t2 <> ppr t1 + _ -> prettyPrecApp p t1 t2 + _ -> prettyPrecApp p t1 t2 + SLet LSLet _ (LV _ x) mty _ _ t1 t2 -> + sep + [ prettyDefinition "let" x mty t1 <+> "in" + , ppr t2 + ] + SLet LSDef _ (LV _ x) mty _ _ t1 t2 -> + mconcat $ + sep [prettyDefinition "def" x mty t1, "end"] + : case t2 of + Syntax' _ (TConst Noop) _ _ -> [] + _ -> [hardline, hardline, ppr t2] + STydef (LV _ x) pty _ t1 -> + mconcat $ + prettyTydef x pty + : case t1 of + Syntax' _ (TConst Noop) _ _ -> [] + _ -> [hardline, hardline, ppr t1] + SBind Nothing _ _ _ t1 t2 -> + pparens (p > 0) $ + prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2 + SBind (Just (LV _ x)) _ _ _ t1 t2 -> + pparens (p > 0) $ + ppr x <+> "<-" <+> prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2 + SRcd m -> brackets $ hsep (punctuate "," (map prettyEquality (M.assocs m))) + SProj t x -> prettyPrec 11 t <> "." <> ppr x + SAnnotate t pt -> + pparens (p > 0) $ + prettyPrec 1 t <+> ":" <+> ppr pt + SSuspend t -> + pparens (p > 10) $ + "suspend" <+> prettyPrec 11 t + SParens t -> pparens True (ppr t) + TType ty -> "@" <> prettyPrec 11 ty + +prettyDefinition :: Doc ann -> Var -> Maybe (Poly q Type) -> Syntax' ty -> Doc ann +prettyDefinition defName x mty t1 = + nest 2 . sep $ + [ flatAlt + (defHead <> group defType <+> eqAndLambdaLine) + (defHead <> group defType' <+> defEqLambdas) + , ppr defBody + ] + where + (defBody, defLambdaList) = unchainLambdas t1 + defHead = defName <+> ppr x + defType = maybe "" (\ty -> ":" <+> flatAlt (line <> indent 2 (ppr ty)) (ppr ty)) mty + defType' = maybe "" (\ty -> ":" <+> ppr ty) mty + defEqLambdas = hsep ("=" : map prettyLambda defLambdaList) + eqAndLambdaLine = if null defLambdaList then "=" else line <> defEqLambdas + +prettyTydef :: TDVar -> Polytype -> Doc ann +prettyTydef x (unPoly -> ([], ty)) = "tydef" <+> ppr x <+> "=" <+> ppr ty <+> "end" +prettyTydef x (unPoly -> (xs, ty)) = "tydef" <+> ppr x <+> hsep (map ppr xs) <+> "=" <+> ppr ty <+> "end" + +prettyPrecApp :: Int -> Syntax' ty -> Syntax' ty -> Doc a +prettyPrecApp p t1 t2 = + pparens (p > 10) $ + prettyPrec 10 t1 <+> prettyPrec 11 t2 + +prettyTuple :: Term' ty -> Doc a +prettyTuple = tupled . map ppr . unTuple . STerm . erase + +prettyLambdas :: Term' ty -> Doc a +prettyLambdas t = hsep (prettyLambda <$> lms) <> softline <> ppr rest + where + (rest, lms) = unchainLambdas (STerm (erase t)) + +unchainLambdas :: Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)]) +unchainLambdas = \case + -- Peel off consecutive lambdas, being sure to accumulate any + -- attached comments along the way so they attach to the body + Syntax' _ (SLam (LV _ x) mty body) coms _ -> ((x, mty) :) <$> unchainLambdas (body & sComments <>~ coms) + body -> (body, []) + +prettyLambda :: (PrettyPrec a1, PrettyPrec a2) => (a1, Maybe a2) -> Doc ann +prettyLambda (x, mty) = "\\" <> ppr x <> maybe "" ((":" <>) . ppr) mty <> "." diff --git a/src/swarm-lang/Swarm/Language/Syntax/Util.hs b/src/swarm-lang/Swarm/Language/Syntax/Util.hs --- a/src/swarm-lang/Swarm/Language/Syntax/Util.hs +++ b/src/swarm-lang/Swarm/Language/Syntax/Util.hs @@ -32,11 +32,11 @@ import Data.List.NonEmpty qualified as NonEmpty import Data.Set qualified as S import Data.Tree -import Swarm.Language.Context (Var) import Swarm.Language.Syntax.AST import Swarm.Language.Syntax.Constants import Swarm.Language.Syntax.Loc import Swarm.Language.Syntax.Pattern +import Swarm.Language.Var (Var) -- Setup for doctests @@ -49,15 +49,13 @@ -- | Make an infix operation (e.g. @2 + 3@) a curried function -- application (e.g. @((+) 2) 3@). -mkOp :: Const -> Syntax -> Syntax -> Syntax -mkOp c s1@(Syntax l1 _) s2@(Syntax l2 _) = Syntax newLoc newTerm +mkOp :: Const -> (SrcLoc, t) -> Syntax -> Syntax -> Syntax +mkOp c (opLoc, _) s1@(Syntax l1 _) s2@(Syntax l2 _) = Syntax newLoc newTerm where - -- The new syntax span both terms - newLoc = l1 <> l2 - -- We don't assign a source location for the operator since it is - -- usually provided as-is and it is not likely to be useful. - sop = noLoc (TConst c) - newTerm = SApp (Syntax l1 $ SApp sop s1) s2 + -- The new syntax spans all terms + newLoc = l1 <> opLoc <> l2 + sop = Syntax opLoc (TConst c) + newTerm = SApp (Syntax (l1 <> opLoc) $ SApp sop s1) s2 -- | Make an infix operation, discarding any location information mkOp' :: Const -> Term -> Term -> Term @@ -73,13 +71,20 @@ Syntax' _ (SApp s1 s2) _ _ -> (s2, Just s1) s -> (s, Nothing) --- | Create a nested tuple out of a list of syntax nodes. -mkTuple :: [Syntax] -> Syntax -mkTuple [] = Syntax NoLoc TUnit -- should never happen -mkTuple [x] = x -mkTuple (x : xs) = let r = mkTuple xs in loc x r $ SPair x r - where - loc a b = Syntax $ (a ^. sLoc) <> (b ^. sLoc) +-- | Create an appropriate `Term` out of a list of syntax nodes which +-- were enclosed with parentheses (and separated by commas). +mkTuple :: [Syntax] -> Term +-- () = TUnit +mkTuple [] = TUnit +-- (x) = x, but record the fact that it was explicitly parenthesized, +-- for better source location tracking +mkTuple [x] = SParens x +-- (x,y) = SPair +mkTuple [x, y] = SPair x y +-- (x,y,...) = recursively nested pairs. Note that we do not assign +-- source spans to the nested tuples since they don't really come from +-- a specific place in the source. +mkTuple (x : r) = SPair x (Syntax NoLoc (mkTuple r)) -- | Decompose a nested tuple into a list of components. unTuple :: Syntax' ty -> [Syntax' ty] @@ -123,20 +128,21 @@ TAntiInt {} -> pure s TText {} -> pure s TAntiText {} -> pure s + TAntiSyn {} -> pure s TBool {} -> pure s TRobot {} -> pure s TRef {} -> pure s - TRequireDevice {} -> pure s TRequire {} -> pure s + TStock {} -> pure s SRequirements x s1 -> rewrap $ SRequirements x <$> go bound s1 TVar x | x `S.member` bound -> pure s | otherwise -> f s SLam x xty s1 -> rewrap $ SLam x xty <$> go (S.insert (lvVar x) bound) s1 SApp s1 s2 -> rewrap $ SApp <$> go bound s1 <*> go bound s2 - SLet ls r x xty xreq s1 s2 -> + SLet ls r x xty xpty xreq s1 s2 -> let bound' = S.insert (lvVar x) bound - in rewrap $ SLet ls r x xty xreq <$> go bound' s1 <*> go bound' s2 + in rewrap $ SLet ls r x xty xpty xreq <$> go bound' s1 <*> go bound' s2 STydef x xdef tdInfo t1 -> rewrap $ STydef x xdef tdInfo <$> go bound t1 SPair s1 s2 -> rewrap $ SPair <$> go bound s1 <*> go bound s2 SBind mx mty mpty mreq s1 s2 -> rewrap $ SBind mx mty mpty mreq <$> go bound s1 <*> go (maybe id (S.insert . lvVar) mx bound) s2 @@ -145,6 +151,8 @@ SProj s1 x -> rewrap $ SProj <$> go bound s1 <*> pure x SAnnotate s1 pty -> rewrap $ SAnnotate <$> go bound s1 <*> pure pty SSuspend s1 -> rewrap $ SSuspend <$> go bound s1 + SParens s1 -> rewrap $ SParens <$> go bound s1 + TType {} -> pure s where rewrap s' = Syntax' l <$> s' <*> pure ty <*> pure cmts diff --git a/src/swarm-lang/Swarm/Language/TDVar.hs b/src/swarm-lang/Swarm/Language/TDVar.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/TDVar.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Type definition variables. +module Swarm.Language.TDVar where + +import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) +import Data.Data (Data) +import Data.Hashable +import Data.String (IsString (..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Prettyprinter (Doc, pretty) +import Swarm.Pretty (PrettyPrec (..)) +import Swarm.Util (showT) + +-- | The name of a user-defined type is represented by a textual name +-- as well as a version number which we can use to differentiate +-- between names which are otherwise the same, when one shadows the +-- other. +-- +-- See Note [Shadowing for value-level and type-level variables] +data TDVar = TDVar {tdVarName :: Text, tdVarVersion :: Int} + deriving (Eq, Ord, Show, Data, Generic, Hashable, ToJSON, FromJSON, ToJSONKey, FromJSONKey) + +-- ~~~~ Note [Shadowing for value-level and type-level variables] +-- +-- The problem we are solving here is: what happens when y is defined +-- in terms of x, but then later x is redefined/shadowed? We want to +-- make sure that y still refers to the *old*, shadowed version of x, +-- not the new one. This problem with user-defined type names caused +-- a type soundness bug, https://github.com/swarm-game/swarm/issues/2437 . +-- +-- So how do the version numbers help solve this... and why wasn't it +-- already a problem with value-level names (i.e. things defined via +-- `def`)? +-- +-- The language is strict at the value level. Any use of a variable +-- will be immediately evaluated. The resulting value will either not +-- mention variables any more, OR will be some kind of closure that +-- contains an environment mapping in-scope variables to their values. +-- So if y is defined in terms of x, it will be evaluated and either +-- not refer to x any more (e.g. `def y = x + 2 end`) or contain a +-- closure with the current value of x. So if x is later shadowed it +-- makes no difference to the value of y. +-- +-- On the other hand, user-defined types are evaluated lazily. This +-- is a feature: otherwise it would be very annoying to use them for +-- purposes of abbreviating long types (see the discussion at +-- https://github.com/swarm-game/swarm/pull/2438). +-- +-- One way this could be solved is by making each type a closure that +-- stores a TDCtx along with it. However, that would be pretty +-- annoying and require large and tedious changes to the codebase. +-- The other solution is to use version numbers: when a user type is +-- defined, it is given a version number which is one greater than the +-- latest version of the same name already in the TDCtx. Other +-- definitions referring to older versions will continue to refer to +-- them, and the definitions of the older versions will be +-- retained. When a user type name is used, it is parsed initially as +-- version 0, but in a later name resolution phase (see +-- 'Swarm.Language.Kindcheck.resolveTydefs') the version is updated to +-- the latest in-scope version. + +-- | Create a type definition variable with the given name and a +-- default version of 0. +mkTDVar :: Text -> TDVar +mkTDVar = mkTDVar' 0 + +-- | Create a type definition variable with a given version number and +-- name. +mkTDVar' :: Int -> Text -> TDVar +mkTDVar' v x = TDVar x v + +-- | Pretty-print a type definition variable, given an extra argument +-- representing the latest version of any variable with this name. +-- If this variable is the latest version, just print its name. If +-- it is not the latest version, print @name%version@. +prettyTDVar :: Int -> TDVar -> Doc ann +prettyTDVar latest (TDVar x n) + | latest > n = pretty (x <> "%" <> showT n) + | otherwise = pretty x + +-- TODO(#2452): overhaul pretty-printing to take extra +-- environment/parameters, such as TDCtx to know when to print a user +-- type name with its version number, to disambiguate when it has been +-- shadowed. + +-- | The 'PrettyPrec' instance for 'TDVar' never prints the version +-- number. If you care about the version number possibly being +-- printed, you must use 'prettyTDVar' instead. +instance PrettyPrec TDVar where + prettyPrec _ (TDVar x _) = pretty x + +instance IsString TDVar where + fromString = mkTDVar . fromString diff --git a/src/swarm-lang/Swarm/Language/Text/Markdown.hs b/src/swarm-lang/Swarm/Language/Text/Markdown.hs --- a/src/swarm-lang/Swarm/Language/Text/Markdown.hs +++ b/src/swarm-lang/Swarm/Language/Text/Markdown.hs @@ -54,8 +54,9 @@ import GHC.Exts qualified (IsList (..), IsString (..)) import Swarm.Language.Parser (readTerm) import Swarm.Language.Pipeline (processParsedTerm) -import Swarm.Language.Pretty (PrettyPrec (..), prettyText, prettyTextLine, prettyTypeErrText) import Swarm.Language.Syntax (Syntax) +import Swarm.Language.Typecheck (prettyTypeErrText) +import Swarm.Pretty (PrettyPrec (..), prettyText, prettyTextLine) -- | The top-level markdown document. newtype Document c = Document {paragraphs :: [Paragraph c]} @@ -135,8 +136,7 @@ instance GHC.Exts.IsString (Paragraph Syntax) where fromString s = case paragraphs $ GHC.Exts.fromString s of [] -> mempty - [p] -> p - ps -> error $ "Error: expected one paragraph, but found " <> show (length ps) + (p : _) -> p -- | Surround some text in double quotes if it is not empty. quoteMaybe :: Text -> Text @@ -162,7 +162,7 @@ blockQuote (Document ns) = Document $ map Mark.emph ns codeBlock f = Mark.plain . pureP . LeafCodeBlock (T.unpack f) heading _lvl = Mark.plain . Mark.strong - rawBlock (Mark.Format f) t = error . T.unpack $ "Unsupported raw " <> f <> " block:\n" <> t + rawBlock _ _ = mempty referenceLinkDefinition = mempty list _type _spacing = mconcat @@ -199,9 +199,12 @@ (ts :: [Text]) <- mapM parseJSON $ toList a fromTextM $ T.intercalate "\n\n" ts --- | Parse Markdown document, but throw on invalid code. +-- | Parse Markdown document, but re-inject a generated error into the +-- document itself. fromText :: Text -> Document Syntax -fromText = either error id . fromTextE +fromText = either injectErr id . fromTextE + where + injectErr err = Document [Paragraph [LeafRaw "" (T.pack err)]] -- | Read Markdown document and parse&validate the code. -- diff --git a/src/swarm-lang/Swarm/Language/Typecheck.hs b/src/swarm-lang/Swarm/Language/Typecheck.hs --- a/src/swarm-lang/Swarm/Language/Typecheck.hs +++ b/src/swarm-lang/Swarm/Language/Typecheck.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -14,6 +15,7 @@ ContextualTypeErr (..), TypeErr (..), InvalidAtomicReason (..), + prettyTypeErrText, -- * Type provenance Source (..), @@ -37,6 +39,7 @@ -- * Type inference inferTop, + checkTop, infer, inferConst, check, @@ -52,12 +55,12 @@ import Control.Effect.Error (Error) import Control.Effect.Reader import Control.Effect.Throw -import Control.Lens ((^.)) +import Control.Lens (view, (^.)) import Control.Lens.Indexed (itraverse) -import Control.Monad (forM_, void, when, (<=<), (>=>)) -import Control.Monad.Free (Free (..)) +import Control.Monad (forM, forM_, void, when, (<=<), (>=>)) +import Control.Monad.Free qualified as Free import Data.Data (Data, gmapM) -import Data.Foldable (fold, traverse_) +import Data.Foldable (fold) import Data.Functor.Identity import Data.Generics (mkM) import Data.Map (Map, (!)) @@ -65,18 +68,23 @@ import Data.Maybe import Data.Set (Set, (\\)) import Data.Set qualified as S +import Data.Text (Text) import Data.Text qualified as T -import Swarm.Effect.Unify (Unification, UnificationError, (=:=)) +import Prettyprinter +import Swarm.Effect.Unify (Unification, UnificationError) import Swarm.Effect.Unify qualified as U import Swarm.Effect.Unify.Fast qualified as U import Swarm.Language.Context hiding (lookup) import Swarm.Language.Context qualified as Ctx -import Swarm.Language.Kindcheck (KindError, checkKind, checkPolytypeKind) +import Swarm.Language.Kindcheck (KindError (..), processPolytype, processType) import Swarm.Language.Parser.QQ (tyQ) +import Swarm.Language.Parser.Util (getLocRange) import Swarm.Language.Requirements.Analysis (requirements) import Swarm.Language.Requirements.Type (ReqCtx) import Swarm.Language.Syntax +import Swarm.Language.TDVar (TDVar, tdVarName) import Swarm.Language.Types +import Swarm.Pretty import Prelude hiding (lookup) ------------------------------------------------------------ @@ -87,16 +95,27 @@ data TCFrame where -- | Checking a definition. TCLet :: Var -> TCFrame - -- | Inferring the LHS of a bind. - TCBindL :: TCFrame - -- | Inferring the RHS of a bind. - TCBindR :: TCFrame + -- | Inferring the LHS of an application. Stored Syntax is the term + -- on the RHS. + TCAppL :: Syntax -> TCFrame + -- | Checking the RHS of an application. Stored Syntax is the term + -- on the LHS. + TCAppR :: Syntax -> TCFrame deriving (Show) +instance PrettyPrec TCFrame where + prettyPrec _ = \case + TCLet x -> "While checking the definition of" <+> ppr x + TCAppL s -> "While checking a function applied to an argument: _" <+> prettyPrec 11 s + TCAppR s -> "While checking the argument to a function:" <+> prettyPrec 10 s <+> "_" + -- | A typechecking stack frame together with the relevant @SrcLoc@. data LocatedTCFrame = LocatedTCFrame SrcLoc TCFrame deriving (Show) +instance PrettyPrec LocatedTCFrame where + prettyPrec p (LocatedTCFrame _ f) = prettyPrec p f + -- | A typechecking stack keeps track of what we are currently in the -- middle of doing during typechecking. type TCStack = [LocatedTCFrame] @@ -186,9 +205,10 @@ TCtx -> ReqCtx -> TDCtx -> - ReaderC UCtx (ReaderC TCStack (ErrorC ContextualTypeErr (U.UnificationC (ReaderC ReqCtx (ReaderC TDCtx m))))) USyntax -> + TVCtx -> + ReaderC UCtx (ReaderC TCStack (ErrorC ContextualTypeErr (U.UnificationC (ReaderC ReqCtx (ReaderC TDCtx (ReaderC TVCtx m)))))) USyntax -> m (Either ContextualTypeErr TSyntax) -runTC' ctx reqCtx tdctx = +runTC' ctx reqCtx tdctx tvCtx = (>>= finalizeUSyntax) >>> runReader (toU ctx) >>> runReader [] @@ -196,6 +216,7 @@ >>> U.runUnification >>> runReader reqCtx >>> runReader tdctx + >>> runReader tvCtx >>> fmap reportUnificationError -- | Run a top-level inference computation, returning either a @@ -204,9 +225,10 @@ TCtx -> ReqCtx -> TDCtx -> - ReaderC UCtx (ReaderC TCStack (ErrorC ContextualTypeErr (U.UnificationC (ReaderC ReqCtx (ReaderC TDCtx Identity))))) USyntax -> + TVCtx -> + ReaderC UCtx (ReaderC TCStack (ErrorC ContextualTypeErr (U.UnificationC (ReaderC ReqCtx (ReaderC TDCtx (ReaderC TVCtx Identity)))))) USyntax -> Either ContextualTypeErr TSyntax -runTC tctx reqCtx tdctx = runTC' tctx reqCtx tdctx >>> runIdentity +runTC tctx reqCtx tdctx tvCtx = runTC' tctx reqCtx tdctx tvCtx >>> runIdentity checkPredicative :: Has (Throw ContextualTypeErr) sig m => Maybe a -> m a checkPredicative = maybe (throwError (mkRawTypeErr Impredicative)) pure @@ -222,6 +244,7 @@ ( Has (Throw ContextualTypeErr) sig m , Has (Reader TCStack) sig m , Has (Reader UCtx) sig m + , Has (Reader TVCtx) sig m , Has Unification sig m ) => SrcLoc -> @@ -236,15 +259,14 @@ addLocToTypeErr :: ( Has (Throw ContextualTypeErr) sig m , Has (Catch ContextualTypeErr) sig m - , Has (Reader TCStack) sig m ) => SrcLoc -> m a -> m a addLocToTypeErr l m = m `catchError` \case - CTE NoLoc _ te -> throwTypeErr l te - te -> throwError te + CTE NoLoc stk te -> throwError $ CTE l stk te + cte -> throwError cte ------------------------------------------------------------ -- Dealing with variables: free variables, fresh variables, @@ -259,8 +281,8 @@ freeUVars = U.freeUVars -- | We can also get the free variables of a polytype. -instance (FreeUVars t) => FreeUVars (Poly t) where - freeUVars (Forall _ t) = freeUVars t +instance (FreeUVars t) => FreeUVars (Poly q t) where + freeUVars = freeUVars . ptBody -- | We can get the free variables in any polytype in a context. instance FreeUVars UCtx where @@ -268,7 +290,7 @@ -- | Generate a fresh unification variable. fresh :: Has Unification sig m => m UType -fresh = Pure <$> U.freshIntVar +fresh = Free.Pure <$> U.freshIntVar -- | Perform a substitution over a 'UType', substituting for both type -- and unification variables. Note that since 'UType's do not have @@ -277,31 +299,35 @@ substU :: Map (Either Var IntVar) UType -> UType -> UType substU m = ucata - (\v -> fromMaybe (Pure v) (M.lookup (Right v) m)) + (\v -> fromMaybe (Free.Pure v) (M.lookup (Right v) m)) ( \case - TyVarF v -> fromMaybe (UTyVar v) (M.lookup (Left v) m) - f -> Free f + TyVarF o v -> fromMaybe (UTyVar' o v) (M.lookup (Left v) m) + f -> Free.Free f ) --- | Make sure no skolem variables escape. +-- | Make sure none of the given skolem variables have escaped. noSkolems :: ( Has Unification sig m , Has (Reader TCStack) sig m , Has (Throw ContextualTypeErr) sig m ) => SrcLoc -> - Poly UType -> + [Var] -> + UPolytype -> m () -noSkolems l (Forall xs upty) = do +noSkolems l skolems (unPoly -> (xs, upty)) = do upty' <- applyBindings upty let tyvs = ucata (const S.empty) - (\case TyVarF v -> S.singleton v; f -> fold f) + (\case TyVarF _ v -> S.singleton v; f -> fold f) upty' - ftyvs = tyvs `S.difference` S.fromList xs - forM_ (S.lookupMin ftyvs) $ throwTypeErr l . EscapedSkolem + freeTyvs = tyvs `S.difference` S.fromList xs + escapees = freeTyvs `S.intersection` S.fromList skolems + -- In case of multiple escapees, just generate an error for one + forM_ (S.lookupMin escapees) $ throwTypeErr l . EscapedSkolem + -- ~~~~ Note [lookupMin to get an arbitrary element] -- -- `S.lookupMin :: Set a -> Maybe a` returns the smallest @@ -324,7 +350,7 @@ TypeJoin -> m UType unify ms j = do - res <- expected =:= actual + res <- expected U.=:= actual case res of Left _ -> do j' <- traverse U.applyBindings j @@ -343,7 +369,7 @@ applyBindings = U.applyBindings instance HasBindings UPolytype where - applyBindings (Forall xs u) = Forall xs <$> applyBindings u + applyBindings = traverse applyBindings instance HasBindings UCtx where applyBindings = mapM applyBindings @@ -360,23 +386,31 @@ -- | To 'instantiate' a 'UPolytype', we generate a fresh unification -- variable for each variable bound by the `Forall`, and then -- substitute them throughout the type. -instantiate :: Has Unification sig m => UPolytype -> m UType -instantiate (Forall xs uty) = do +instantiate :: (Has Unification sig m, Has (Reader TVCtx) sig m) => UPolytype -> m UType +instantiate (unPoly -> (xs, uty)) = do xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) xs')) uty + boundSubst <- ask @TVCtx + let s = M.mapKeys Left (M.fromList (zip xs xs') `M.union` unCtx boundSubst) + return $ substU s uty -- | 'skolemize' is like 'instantiate', except we substitute fresh -- /type/ variables instead of unification variables. Such -- variables cannot unify with anything other than themselves. This -- is used when checking something with a polytype explicitly -- specified by the user. -skolemize :: Has Unification sig m => UPolytype -> m UType -skolemize (Forall xs uty) = do - xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty - where - toSkolem (Pure v) = UTyVar (mkVarName "s" v) - toSkolem x = error $ "Impossible! Non-UVar in skolemize.toSkolem: " ++ show x +-- +-- Returns a context mapping from instantiated type variables to generated +-- Skolem variables, along with the substituted type. +skolemize :: (Has Unification sig m, Has (Reader TVCtx) sig m) => UPolytype -> m (Ctx Var UType, UType) +skolemize (unPoly -> (xs, uty)) = do + skolemNames <- forM xs $ \x -> do + s <- mkVarName "s" <$> U.freshIntVar + pure (x, s) + boundSubst <- ask @TVCtx + let xs' = map (uncurry UTyVar') skolemNames + newSubst = M.fromList $ zip xs xs' + s = M.mapKeys Left (newSubst `M.union` unCtx boundSubst) + pure (Ctx.fromMap newSubst, substU s uty) -- | 'generalize' is the opposite of 'instantiate': add a 'Forall' -- which closes over all free type and unification variables. @@ -395,53 +429,17 @@ prettyNames = map T.pack (map (: []) alphabet ++ [x : show n | n <- [0 :: Int ..], x <- alphabet]) -- Associate each free variable with a new pretty name renaming = zip fvs prettyNames - return $ - Forall + return . absQuantify $ + mkPoly (map snd renaming) (substU (M.fromList . map (Right *** UTyVar) $ renaming) uty') ------------------------------------------------------------ -- Type errors - --- | A type error along with various contextual information to help us --- generate better error messages. -data ContextualTypeErr = CTE {cteSrcLoc :: SrcLoc, cteStack :: TCStack, cteTypeErr :: TypeErr} - deriving (Show) - --- | Create a raw 'ContextualTypeErr' with no context information. -mkRawTypeErr :: TypeErr -> ContextualTypeErr -mkRawTypeErr = CTE NoLoc [] - --- | Create a 'ContextualTypeErr' value from a 'TypeErr' and context. -mkTypeErr :: SrcLoc -> TCStack -> TypeErr -> ContextualTypeErr -mkTypeErr = CTE - --- | Throw a 'ContextualTypeErr'. -throwTypeErr :: - ( Has (Throw ContextualTypeErr) sig m - , Has (Reader TCStack) sig m - ) => - SrcLoc -> - TypeErr -> - m a -throwTypeErr l te = do - stk <- ask @TCStack - throwError $ mkTypeErr l stk te +------------------------------------------------------------ --- | Adapt some other error type to a 'ContextualTypeErr'. -adaptToTypeErr :: - ( Has (Throw ContextualTypeErr) sig m - , Has (Reader TCStack) sig m - ) => - SrcLoc -> - (e -> TypeErr) -> - ThrowC e m a -> - m a -adaptToTypeErr l adapt m = do - res <- runThrow m - case res of - Left e -> throwTypeErr l (adapt e) - Right a -> return a +-------------------------------------------------- +-- Basic type errors -- | Errors that can occur during type checking. The idea is that -- each error carries information that can be used to help explain @@ -451,16 +449,21 @@ data TypeErr = -- | An undefined variable was encountered. UnboundVar Var + | -- | An undefined type was encountered. + UnboundType TDVar | -- | A kind error was encountered. KindErr KindError | -- | A Skolem variable escaped its local context. EscapedSkolem Var - | -- | Occurs check failure, i.e. infinite type. + | -- | Failure during unification. UnificationErr UnificationError | -- | Type mismatch caught by 'unify'. The given term was -- expected to have a certain type, but has a different type -- instead. Mismatch (Maybe Syntax) TypeJoin + | -- | Record type mismatch. The given term was expected to have a + -- record type, but has a different type instead. + MismatchRcd (Maybe Syntax) UType | -- | Lambda argument type mismatch. LambdaArgMismatch TypeJoin | -- | Record field mismatch, i.e. based on the expected type we @@ -482,8 +485,124 @@ | -- | Some unification variables ended up in a type, probably due to -- impredicativity. See https://github.com/swarm-game/swarm/issues/351 . Impredicative + | -- | Read must be given a literal type as an argument. See + -- https://github.com/swarm-game/swarm/pull/2461#discussion_r2124125021 + ReadNonLiteralTypeArg Term deriving (Show) +instance PrettyPrec TypeErr where + prettyPrec _ = \case + UnificationErr ue -> ppr ue + KindErr ke -> ppr ke + Mismatch Nothing (getJoin -> (ty1, ty2)) -> + "Type mismatch: expected" <+> ppr ty1 <> ", but got" <+> ppr ty2 + Mismatch (Just t) (getJoin -> (ty1, ty2)) -> + nest 2 . vcat $ + [ "Type mismatch:" + , "From context, expected" <+> pprCode t <+> "to" <+> typeDescription Expected ty1 <> "," + , "but it" <+> typeDescription Actual ty2 + ] + MismatchRcd Nothing ty -> + "Type mismatch: expected a record type, but got" <+> ppr ty + MismatchRcd (Just t) ty -> + nest 2 . vcat $ + [ "Type mismatch:" + , "From context, expected" <+> pprCode t <+> "to have a record type," + , "but it" <+> typeDescription Actual ty + ] + LambdaArgMismatch (getJoin -> (ty1, ty2)) -> + "Lambda argument has type annotation" <+> pprCode ty2 <> ", but expected argument type" <+> pprCode ty1 + FieldsMismatch (getJoin -> (expFs, actFs)) -> + fieldMismatchMsg expFs actFs + EscapedSkolem x -> + "Skolem variable" <+> ppr x <+> "would escape its scope" + UnboundVar x -> + "Unbound variable" <+> ppr x + UnboundType x -> + "Undefined type" <+> ppr x + DefNotTopLevel t -> + "Definitions may only be at the top level:" <+> pprCode t + CantInfer t -> + vsep + [ "Couldn't infer the type of term:" <+> pprCode t + , reportBug + ] + CantInferProj t -> + "In the record projection" <+> pprCode t <> ", can't infer whether the LHS has a record type. Try adding a type annotation." + UnknownProj x t -> + "Record does not have a field with name" <+> ppr x <> ":" <+> pprCode t + InvalidAtomic reason t -> + "Invalid atomic block:" <+> ppr reason <> ":" <+> pprCode t + Impredicative -> + "Unconstrained unification type variables encountered, likely due to an impredicative type. This is a known bug; for more information see https://github.com/swarm-game/swarm/issues/351 ." + ReadNonLiteralTypeArg t -> + "The `read` command must be given a literal type as its first argument (Swarm does not have dependent types); found" <+> pprCode t <+> "instead." + where + pprCode :: PrettyPrec a => a -> Doc ann + pprCode = bquote . ppr + +-- | Given a type and its source, construct an appropriate description +-- of it to go in a type mismatch error message. +typeDescription :: Source -> UType -> Doc a +typeDescription src ty + | not (hasAnyUVars ty) = + withSource src "have" "actually has" <+> "type" <+> bquote (ppr ty) + | Just f <- isTopLevelConstructor ty = + withSource src "be" "is actually" <+> tyNounPhrase f + | otherwise = + withSource src "have" "actually has" <+> "a type like" <+> bquote (ppr (fmap (const Wildcard) ty)) + +-- | Return an English noun phrase describing things with the given +-- top-level type constructor. +tyNounPhrase :: TypeF () -> Doc a +tyNounPhrase = \case + TyConF c _ -> tyConNounPhrase c + TyVarF {} -> "a type variable" + TyRcdF {} -> "a record" + TyRecF {} -> "a recursive type" + TyRecVarF {} -> "a recursive type variable" + +tyConNounPhrase :: TyCon -> Doc a +tyConNounPhrase = \case + TCBase b -> baseTyNounPhrase b + TCCmd -> "a command" + TCDelay -> "a delayed expression" + TCSum -> "a sum" + TCProd -> "a pair" + TCFun -> "a function" + TCUser t -> ppr t + +-- | Return an English noun phrase describing things with the given +-- base type. +baseTyNounPhrase :: BaseTy -> Doc a +baseTyNounPhrase = \case + BVoid -> "void" + BUnit -> "the unit value" + BInt -> "an integer" + BText -> "text" + BDir -> "a direction" + BBool -> "a boolean" + BActor -> "an actor" + BKey -> "a key" + BType -> "a type" + +-- | Generate an appropriate message when the sets of fields in two +-- record types do not match, explaining which fields are extra and +-- which are missing. +fieldMismatchMsg :: Set Var -> Set Var -> Doc a +fieldMismatchMsg expFs actFs = + nest 2 . vcat $ + ["Field mismatch; record literal has:"] + ++ ["- Extra field(s)" <+> prettyFieldSet extraFs | not (S.null extraFs)] + ++ ["- Missing field(s)" <+> prettyFieldSet missingFs | not (S.null missingFs)] + where + extraFs = actFs `S.difference` expFs + missingFs = expFs `S.difference` actFs + prettyFieldSet = hsep . punctuate "," . map (bquote . ppr) . S.toList + +-------------------------------------------------- +-- Errors for 'atomic' + -- | Various reasons the body of an @atomic@ might be invalid. data InvalidAtomicReason = -- | The argument has too many tangible commands. @@ -500,6 +619,90 @@ AtomicSuspend deriving (Show) +instance PrettyPrec InvalidAtomicReason where + prettyPrec _ = \case + TooManyTicks n -> "block could take too many ticks (" <> pretty n <> ")" + AtomicDupingThing -> "def, let, and lambda are not allowed" + NonSimpleVarType _ ty -> + "reference to variable with non-simple type" <+> ppr (prettyTextLine ty) + NestedAtomic -> "nested atomic block" + LongConst -> "commands that can take multiple ticks to execute are not allowed" + AtomicSuspend -> + "encountered a suspend command inside an atomic block" <> hardline <> reportBug + +-------------------------------------------------- +-- Type errors with context + +-- | A type error along with various contextual information to help us +-- generate better error messages. +data ContextualTypeErr = CTE {cteSrcLoc :: SrcLoc, cteStack :: TCStack, cteTypeErr :: TypeErr} + deriving (Show) + +-- | Create a raw 'ContextualTypeErr' with no context information. +mkRawTypeErr :: TypeErr -> ContextualTypeErr +mkRawTypeErr = CTE NoLoc [] + +-- | Create a 'ContextualTypeErr' value from a 'TypeErr' and context. +mkTypeErr :: SrcLoc -> TCStack -> TypeErr -> ContextualTypeErr +mkTypeErr = CTE + +-- | Throw a 'ContextualTypeErr'. +throwTypeErr :: + ( Has (Throw ContextualTypeErr) sig m + , Has (Reader TCStack) sig m + ) => + SrcLoc -> + TypeErr -> + m a +throwTypeErr l te = do + stk <- ask @TCStack + throwError $ mkTypeErr l stk te + +-- | Adapt some other error type to a 'ContextualTypeErr'. +adaptToTypeErr :: + ( Has (Throw ContextualTypeErr) sig m + , Has (Reader TCStack) sig m + ) => + SrcLoc -> + (e -> TypeErr) -> + ThrowC e m a -> + m a +adaptToTypeErr l adapt m = do + res <- runThrow m + case res of + Left e -> throwTypeErr l (adapt e) + Right a -> return a + +-------------------------------------------------- +-- Pretty-printing for contextual type errors + +-- | Format a 'ContextualTypeError' for the user and render it as +-- @Text@. +prettyTypeErrText :: Text -> ContextualTypeErr -> Text +prettyTypeErrText code = docToText . prettyTypeErr code + +-- | Format a 'ContextualTypeError' for the user. +prettyTypeErr :: Text -> ContextualTypeErr -> Doc ann +prettyTypeErr code (CTE l tcStack te) = + vcat + [ teLoc <> ppr te + , ppr (BulletList "" (filterTCStack tcStack)) + ] + where + teLoc = case l of + SrcLoc s e -> (showLoc . fst $ getLocRange code (s, e)) <> ": " + NoLoc -> emptyDoc + showLoc (r, c) = pretty r <> ":" <> pretty c + +-- | Filter the TCStack so we stop printing context outside of a def/let +filterTCStack :: TCStack -> TCStack +filterTCStack tcStack = case tcStack of + [] -> [] + -- A def/let is enough context to locate something; don't keep + -- printing wider context after that + t@(LocatedTCFrame _ (TCLet _)) : _ -> [t] + t : xs -> t : filterTCStack xs + ------------------------------------------------------------ -- Type decomposition @@ -518,7 +721,7 @@ Sourced UType -> m UType decomposeTyConApp1 c t (src, UTyConApp (TCUser u) as) = do - ty2 <- expandTydef u as + ty2 <- adaptToTypeErr NoLoc (UnboundType . getUnexpanded) $ expandTydef u as decomposeTyConApp1 c t (src, ty2) decomposeTyConApp1 c _ (_, UTyConApp c' [a]) | c == c' = return a @@ -540,6 +743,42 @@ decomposeCmdTy = decomposeTyConApp1 TCCmd decomposeDelayTy = decomposeTyConApp1 TCDelay +-- | Decompose a type which is expected to be a record type. There +-- are three possible outcomes: +-- +-- * If the type is definitely a record type, return its mapping +-- from field names to types. +-- +-- * If the type is definitely not a record type, throw a type error. +-- +-- * Otherwise, return @Nothing@. +-- +-- This is the best we can do, and different than the way the other +-- @decompose...Ty@ functions work, because we can't solve for record +-- types via unification. +decomposeRcdTy :: + ( Has (Reader TDCtx) sig m + , Has (Reader TCStack) sig m + , Has (Throw ContextualTypeErr) sig m + ) => + Maybe Syntax -> + UType -> + m (Maybe (Map Var UType)) +decomposeRcdTy ms = \case + ty@(UTyConApp tc as) -> case tc of + -- User-defined type: expand it + TCUser u -> do + ty2 <- adaptToTypeErr NoLoc (UnboundType . getUnexpanded) $ expandTydef u as + decomposeRcdTy ms ty2 + -- Any other type constructor application is definitely not a record type + _ -> throwTypeErr (maybe NoLoc (view sLoc) ms) $ MismatchRcd ms ty + -- Recursive type: expand it + UTyRec x t -> decomposeRcdTy ms (unfoldRec x t) + -- Record type + UTyRcd m -> pure (Just m) + -- With anything else (type variables, etc.) we're not sure + _ -> pure Nothing + -- | Decompose a type that is supposed to be the application of a -- given type constructor to two type arguments. Also take the term -- which is supposed to have that type, for use in error messages. @@ -554,7 +793,7 @@ Sourced UType -> m (UType, UType) decomposeTyConApp2 c t (src, UTyConApp (TCUser u) as) = do - ty2 <- expandTydef u as + ty2 <- adaptToTypeErr NoLoc (UnboundType . getUnexpanded) $ expandTydef u as decomposeTyConApp2 c t (src, ty2) decomposeTyConApp2 c _ (_, UTyConApp c' [ty1, ty2]) | c == c' = return (ty1, ty2) @@ -584,8 +823,12 @@ -- types, type synonyms, and a term, either return a type error or a -- fully type-annotated version of the term. inferTop :: TCtx -> ReqCtx -> TDCtx -> Syntax -> Either ContextualTypeErr TSyntax -inferTop ctx reqCtx tdCtx = runTC ctx reqCtx tdCtx . infer +inferTop ctx reqCtx tdCtx = runTC ctx reqCtx tdCtx Ctx.empty . infer +-- | Top level type checking function. +checkTop :: TCtx -> ReqCtx -> TDCtx -> Syntax -> Type -> Either ContextualTypeErr TSyntax +checkTop ctx reqCtx tdCtx t ty = runTC ctx reqCtx tdCtx Ctx.empty $ check t (toU ty) + -- | Infer the type of a term, returning a type-annotated term. -- -- The only cases explicitly handled in 'infer' are those where @@ -602,12 +845,13 @@ -- downside is that we have to be really careful not to miss any types -- along the way; there is no difference, at the Haskell type level, -- between ill- and well-kinded Swarm types, so we just have to make --- sure that we call checkKind on every type embedded in the term +-- sure that we call processType on every type embedded in the term -- being checked. infer :: ( Has (Reader UCtx) sig m , Has (Reader ReqCtx) sig m , Has (Reader TDCtx) sig m + , Has (Reader TVCtx) sig m , Has (Reader TCStack) sig m , Has Unification sig m , Has (Error ContextualTypeErr) sig m @@ -627,8 +871,8 @@ TAntiText x -> return $ Syntax' l (TAntiText x) cs UTyText TBool b -> return $ Syntax' l (TBool b) cs UTyBool TRobot r -> return $ Syntax' l (TRobot r) cs UTyActor - TRequireDevice d -> return $ Syntax' l (TRequireDevice d) cs (UTyCmd UTyUnit) - TRequire n d -> return $ Syntax' l (TRequire n d) cs (UTyCmd UTyUnit) + TRequire d -> return $ Syntax' l (TRequire d) cs (UTyCmd UTyUnit) + TStock n d -> return $ Syntax' l (TStock n d) cs (UTyCmd UTyUnit) SRequirements x t1 -> do t1' <- infer t1 return $ Syntax' l (SRequirements x t1') cs (UTyCmd UTyUnit) @@ -645,16 +889,27 @@ -- under an extended context and return the appropriate function -- type. SLam x (Just argTy) body -> do - adaptToTypeErr l KindErr $ checkKind argTy - let uargTy = toU argTy - body' <- withBinding (lvVar x) (Forall [] uargTy) $ infer body - return $ Syntax' l (SLam x (Just argTy) body') cs (UTyFun uargTy (body' ^. sType)) + argTy' <- adaptToTypeErr l KindErr $ processType argTy + let uargTy = toU argTy' + body' <- withBinding @Var @UPolytype (lvVar x) (mkTrivPoly uargTy) $ infer body + return $ Syntax' l (SLam x (Just argTy') body') cs (UTyFun uargTy (body' ^. sType)) -- Need special case here for applying 'atomic' or 'instant' so we -- don't handle it with the case for generic type application. -- This must come BEFORE the SApp case. TConst c :$: _ | c `elem` [Atomic, Instant] -> fresh >>= check s + -- Special case for applying 'read' to a type argument, since we need to make + -- sure the type propagates to the inferred output type of 'read'. + TConst Read :$: STerm arg -> do + argTy <- case arg of + TType ty -> pure ty + _ -> throwTypeErr l $ ReadNonLiteralTypeArg arg + r' <- infer $ Syntax l (TConst Read) + argTy' <- adaptToTypeErr l (UnboundType . getUnexpanded) $ expandTydefs argTy + arg' <- check (STerm (TType argTy')) UTyType + pure $ Syntax' l (SApp r' arg') cs (UTyFun UTyText (toU argTy')) + -- It works better to handle applications in *inference* mode. -- Knowing the expected result type of an application does not -- really help much. In the typical case, the function being @@ -668,11 +923,13 @@ -- each time. SApp f x -> do -- Infer the type of the left-hand side and make sure it has a function type. - f' <- infer f - (argTy, resTy) <- decomposeFunTy f (Actual, f' ^. sType) + (f', argTy, resTy) <- withFrame l (TCAppL x) $ do + f' <- infer f + (argTy, resTy) <- decomposeFunTy f (Actual, f' ^. sType) + pure (f', argTy, resTy) -- Then check that the argument has the right type. - x' <- check x argTy + x' <- withFrame l (TCAppR f) $ check x argTy -- Call applyBindings explicitly, so that anything we learned -- about unification variables while checking the type of the @@ -698,13 +955,12 @@ -- the surface syntax, so the second through fourth fields are -- necessarily Nothing. SBind mx _ _ _ c1 c2 -> do - c1' <- withFrame l TCBindL $ infer c1 + c1' <- infer c1 a <- decomposeCmdTy c1 (Actual, c1' ^. sType) genA <- generalize a c2' <- - maybe id ((`withBinding` genA) . lvVar) mx - . withFrame l TCBindR - $ infer c2 + maybe id ((`withBinding` genA) . lvVar) mx $ + infer c2 -- We don't actually need the result type since we're just -- going to return the entire type, but it's important to @@ -733,36 +989,41 @@ -- first anyway. SProj t1 x -> do t1' <- infer t1 - case t1' ^. sType of - UTyRcd m -> case M.lookup x m of + mm <- decomposeRcdTy (Just t1) (t1' ^. sType) + case mm of + Just m -> case M.lookup x m of Just xTy -> return $ Syntax' l (SProj t1' x) cs xTy Nothing -> throwTypeErr l $ UnknownProj x (SProj t1 x) - _ -> throwTypeErr l $ CantInferProj (SProj t1 x) + Nothing -> throwTypeErr l $ CantInferProj (SProj t1 x) -- See Note [Checking and inference for record literals] SRcd m -> do m' <- itraverse (\x -> infer . fromMaybe (STerm (TVar x))) m return $ Syntax' l (SRcd (Just <$> m')) cs (UTyRcd (fmap (^. sType) m')) + -- Once we're typechecking, we don't need to keep around explicit + -- parens any more + SParens t1 -> infer t1 -- To infer a type-annotated term, switch into checking mode. -- However, we must be careful to deal properly with polymorphic -- type annotations. SAnnotate c pty -> do - _ <- adaptToTypeErr l KindErr $ checkPolytypeKind pty - let upty = toU pty + qpty <- quantify pty + TydefInfo qpty' _ <- adaptToTypeErr l KindErr $ processPolytype qpty + let upty = toU qpty' -- Typecheck against skolemized polytype. - uty <- skolemize upty + (skolemSubst, uty) <- skolemize upty _ <- check c uty -- Make sure no skolem variables have escaped. - ask @UCtx >>= mapM_ (noSkolems l) + ask @UCtx >>= mapM_ (noSkolems l (Ctx.vars skolemSubst)) -- If check against skolemized polytype is successful, -- instantiate polytype with unification variables. -- Free variables should be able to unify with anything in -- following typechecking steps. iuty <- instantiate upty c' <- check c iuty - return $ Syntax' l (SAnnotate c' pty) cs iuty - + return $ Syntax' l (SAnnotate c' (forgetQ qpty')) cs iuty + TType ty -> pure $ Syntax' l (TType ty) cs UTyType -- Fallback: to infer the type of anything else, make up a fresh unification -- variable for its type and check against it. _ -> do @@ -771,7 +1032,7 @@ -- | Infer the type of a constant. inferConst :: Const -> Polytype -inferConst c = case c of +inferConst c = run . runReader @TVCtx Ctx.empty . quantify $ case c of Wait -> [tyQ| Int -> Cmd Unit |] Noop -> [tyQ| Cmd Unit |] Selfdestruct -> [tyQ| Cmd Unit |] @@ -810,11 +1071,12 @@ Time -> [tyQ| Cmd Int |] Scout -> [tyQ| Dir -> Cmd Bool |] Whereami -> [tyQ| Cmd (Int * Int) |] - Waypoint -> [tyQ| Text -> Int -> Cmd (Int * (Int * Int)) |] - Structure -> [tyQ| Text -> Int -> Cmd (Unit + (Int * (Int * Int))) |] + LocateMe -> [tyQ| Cmd (Text * (Int * Int)) |] + Waypoints -> [tyQ| Text -> (rec l. Unit + (Int * Int) * l) |] + Structures -> [tyQ| Text -> Cmd (rec l. Unit + (Int * Int) * l) |] Floorplan -> [tyQ| Text -> Cmd (Int * Int) |] - HasTag -> [tyQ| Text -> Text -> Cmd Bool |] - TagMembers -> [tyQ| Text -> Int -> Cmd (Int * Text) |] + HasTag -> [tyQ| Text -> Text -> Bool |] + TagMembers -> [tyQ| Text -> (rec l. Unit + Text * l) |] Detect -> [tyQ| Text -> ((Int * Int) * (Int * Int)) -> Cmd (Unit + (Int * Int)) |] Resonate -> [tyQ| Text -> ((Int * Int) * (Int * Int)) -> Cmd Int |] Density -> [tyQ| ((Int * Int) * (Int * Int)) -> Cmd Int |] @@ -840,11 +1102,10 @@ If -> [tyQ| Bool -> {a} -> {a} -> a |] Inl -> [tyQ| a -> a + b |] Inr -> [tyQ| b -> a + b |] - Case -> [tyQ|a + b -> (a -> c) -> (b -> c) -> c |] - Fst -> [tyQ| a * b -> a |] - Snd -> [tyQ| a * b -> b |] + Case -> [tyQ| a + b -> (a -> c) -> (b -> c) -> c |] + Match -> [tyQ| a * b -> (a -> b -> c) -> c |] Force -> [tyQ| {a} -> a |] - Return -> [tyQ| a -> Cmd a |] + Pure -> [tyQ| a -> Cmd a |] Try -> [tyQ| {Cmd a} -> {Cmd a} -> Cmd a |] Undefined -> [tyQ| a |] Fail -> [tyQ| Text -> a |] @@ -864,6 +1125,9 @@ Div -> arithBinT Exp -> arithBinT Format -> [tyQ| a -> Text |] + Read -> [tyQ| Type -> Text -> a |] + Print -> [tyQ| Text -> Text -> Cmd Text |] + Erase -> [tyQ| Text -> Cmd Text |] Concat -> [tyQ| Text -> Text -> Text |] Chars -> [tyQ| Text -> Int |] Split -> [tyQ| Int -> Text -> (Text * Text) |] @@ -876,6 +1140,7 @@ Key -> [tyQ| Text -> Key |] InstallKeyHandler -> [tyQ| Text -> (Key -> Cmd Unit) -> Cmd Unit |] Teleport -> [tyQ| Actor -> (Int * Int) -> Cmd Unit |] + Warp -> [tyQ| Actor -> (Text * (Int * Int)) -> Cmd Unit |] As -> [tyQ| Actor -> {Cmd a} -> Cmd a |] RobotNamed -> [tyQ| Text -> Cmd Actor |] RobotNumbered -> [tyQ| Int -> Cmd Actor |] @@ -893,6 +1158,7 @@ ( Has (Reader UCtx) sig m , Has (Reader ReqCtx) sig m , Has (Reader TDCtx) sig m + , Has (Reader TVCtx) sig m , Has (Reader TCStack) sig m , Has Unification sig m , Has (Error ContextualTypeErr) sig m @@ -901,6 +1167,9 @@ UType -> m (Syntax' UType) check s@(CSyntax l t cs) expected = addLocToTypeErr l $ case t of + -- Once we're typechecking, we don't need to keep around explicit + -- parens any more + SParens t1 -> check t1 expected -- If t : ty, then {t} : {ty}. SDelay s1 -> do ty1 <- decomposeDelayTy s (Expected, expected) @@ -918,21 +1187,20 @@ -- To check a lambda, make sure the expected type is a function type. SLam x mxTy body -> do (argTy, resTy) <- decomposeFunTy s (Expected, expected) - traverse_ (adaptToTypeErr l KindErr . checkKind) mxTy - case toU mxTy of - Just xTy -> do - res <- argTy =:= xTy - case res of - -- Generate a special error when the explicit type annotation - -- on a lambda doesn't match the expected type, - -- e.g. (\x:Int. x + 2) : Text -> Int, since the usual - -- "expected/but got" language would probably be confusing. - Left _ -> throwTypeErr l $ LambdaArgMismatch (joined argTy xTy) - Right _ -> return () - Nothing -> return () - body' <- withBinding (lvVar x) (Forall [] argTy) $ check body resTy - return $ Syntax' l (SLam x mxTy body') cs (UTyFun argTy resTy) + mxTy' <- traverse (adaptToTypeErr l KindErr . processType) mxTy + forM_ (toU mxTy') $ \xTy -> do + res <- argTy U.=:= xTy + case res of + -- Generate a special error when the explicit type annotation + -- on a lambda doesn't match the expected type, + -- e.g. (\x:Int. x + 2) : Text -> Int, since the usual + -- "expected/but got" language would probably be confusing. + Left _ -> throwTypeErr l $ LambdaArgMismatch (joined argTy xTy) + Right _ -> return () + body' <- withBinding @Var @UPolytype (lvVar x) (mkTrivPoly argTy) $ check body resTy + return $ Syntax' l (SLam x mxTy' body') cs (UTyFun argTy resTy) + -- Special case for checking the argument to 'atomic' (or -- 'instant'). 'atomic t' has the same type as 't', which must have -- a type of the form 'Cmd a' for some 'a'. @@ -954,27 +1222,29 @@ return $ Syntax' l (SApp atomic' at') cs (UTyCmd argTy) -- Checking the type of a let- or def-expression. - SLet ls r x mxTy _ t1 t2 -> withFrame l (TCLet (lvVar x)) $ do - traverse_ (adaptToTypeErr l KindErr . checkPolytypeKind) mxTy - (upty, t1') <- case mxTy of + SLet ls r x mxTy _ _ t1 t2 -> withFrame l (TCLet (lvVar x)) $ do + mqxTy <- traverse quantify mxTy + (skolems, upty, t1') <- case mqxTy of -- No type annotation was provided for the let binding, so infer its type. Nothing -> do -- The let could be recursive, so we must generate a fresh -- unification variable for the type of x and infer the type -- of t1 with x in the context. xTy <- fresh - t1' <- withBinding (lvVar x) (Forall [] xTy) $ infer t1 + t1' <- withBinding @Var @UPolytype (lvVar x) (mkTrivPoly xTy) $ infer t1 let uty = t1' ^. sType - _ <- xTy =:= uty - upty <- generalize uty - return (upty, t1') - -- An explicit polytype annotation has been provided. Skolemize it and check - -- definition and body under an extended context. + uty' <- unify (Just t1) (joined xTy uty) + upty <- generalize uty' + return ([], upty, t1') + -- An explicit polytype annotation has been provided. Perform + -- implicit quantification, kind checking, and skolemization, + -- then check definition and body under an extended context. Just pty -> do - let upty = toU pty - uty <- skolemize upty - t1' <- withBinding (lvVar x) upty $ check t1 uty - return (upty, t1') + TydefInfo pty' _ <- adaptToTypeErr l KindErr . processPolytype $ pty + let upty = toU pty' + (ss, uty) <- skolemize upty + t1' <- withBinding (lvVar x) upty . withBindings ss $ check t1 uty + return (Ctx.vars ss, upty, t1') -- Check the requirements of t1. tdCtx <- ask @TDCtx @@ -984,8 +1254,8 @@ -- If we are checking a 'def', ensure t2 has a command type. This ensures that -- something like 'def ... end; x + 3' is not allowed, since this - -- would result in the whole thing being wrapped in return, like - -- 'return (def ... end; x + 3)', which means the def would be local and + -- would result in the whole thing being wrapped in pure, like + -- 'pure (def ... end; x + 3)', which means the def would be local and -- not persist to the next REPL input, which could be surprising. -- -- On the other hand, 'let x = y in x + 3' is perfectly fine. @@ -998,8 +1268,8 @@ withBinding (lvVar x) reqs $ check t2 expected - -- Make sure no skolem variables have escaped. - ask @UCtx >>= mapM_ (noSkolems l) + -- Make sure none of the generated skolem variables have escaped. + ask @UCtx >>= mapM_ (noSkolems l skolems) -- Annotate a 'def' with requirements, but not 'let'. The reason -- is so that let introduces truly "local" bindings which never @@ -1008,7 +1278,7 @@ -- terms if the environment holds not only a value but also a type -- + requirements for them. For example: -- - -- > def x : Int = 3 end; return (x + 2) + -- > def x : Int = 3 end; pure (x + 2) -- 5 -- > x -- 3 @@ -1016,7 +1286,7 @@ -- 5 -- > y -- 1:1: Unbound variable y - -- > let y = 3 in def x = 5 end; return (x + y) + -- > let y = 3 in def x = 5 end; pure (x + y) -- 8 -- > y -- 1:1: Unbound variable y @@ -1027,17 +1297,17 @@ LSLet -> Nothing -- Return the annotated let. - return $ Syntax' l (SLet ls r x mxTy mreqs t1' t2') cs expected + return $ Syntax' l (SLet ls r x mxTy mqxTy mreqs t1' t2') cs expected -- Kind-check a type definition and then check the body under an -- extended context. STydef x pty _ t1 -> do - tydef <- adaptToTypeErr l KindErr $ checkPolytypeKind pty - t1' <- withBinding (lvVar x) tydef (check t1 expected) + tydef@(TydefInfo pty' _) <- adaptToTypeErr l KindErr $ processPolytype pty + t1' <- withBindingTD (tdVarName (lvVar x)) tydef (check t1 expected) -- Eliminate the type alias in the reported type, since it is not -- in scope in the ambient context to which we report back the type. expected' <- elimTydef (lvVar x) tydef <$> applyBindings expected - return $ Syntax' l (STydef x pty (Just tydef) t1') cs expected' + return $ Syntax' l (STydef x pty' (Just tydef) t1') cs expected' -- To check a record, ensure the expected type is a record type, -- ensure all the right fields are present, and push the expected @@ -1147,12 +1417,14 @@ TAntiInt {} -> return 0 TText {} -> return 0 TAntiText {} -> return 0 + TAntiSyn {} -> return 0 TBool {} -> return 0 TRobot {} -> return 0 - TRequireDevice {} -> return 0 TRequire {} -> return 0 + TStock {} -> return 0 SRequirements {} -> return 0 STydef {} -> return 0 + TType {} -> return 0 -- Constants. TConst c -- Nested 'atomic' is not allowed. @@ -1168,10 +1440,11 @@ -- executed. TConst If :$: tst :$: thn :$: els -> (+) <$> analyzeAtomic locals tst <*> (max <$> analyzeAtomic locals thn <*> analyzeAtomic locals els) - -- Pairs, application, and delay are simple: just recurse and sum the results. + -- Pairs, application, delay, and parens are simple: just recurse and sum the results. SPair s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2 SApp s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2 SDelay s1 -> analyzeAtomic locals s1 + SParens s1 -> analyzeAtomic locals s1 -- Bind is similarly simple except that we have to keep track of a local variable -- bound in the RHS. SBind mx _ _ _ s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic (maybe id (S.insert . lvVar) mx locals) s2 @@ -1233,7 +1506,7 @@ -- | A simple polytype is a simple type with no quantifiers. isSimpleUPolytype :: UPolytype -> Bool -isSimpleUPolytype (Forall [] ty) = isSimpleUType ty +isSimpleUPolytype (unPoly -> ([], ty)) = isSimpleUType ty isSimpleUPolytype _ = False -- | A simple type is a sum or product of base types. @@ -1247,5 +1520,5 @@ UTyCmd {} -> False UTyDelay {} -> False -- Make the pattern-match coverage checker happy - Pure {} -> False - Free {} -> False + Free.Pure {} -> False + Free.Free {} -> False diff --git a/src/swarm-lang/Swarm/Language/Types.hs b/src/swarm-lang/Swarm/Language/Types.hs --- a/src/swarm-lang/Swarm/Language/Types.hs +++ b/src/swarm-lang/Swarm/Language/Types.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -41,6 +44,7 @@ pattern TyBool, pattern TyActor, pattern TyKey, + pattern TyType, pattern (:+:), pattern (:*:), pattern (:->:), @@ -56,6 +60,7 @@ pattern UTyConApp, pattern UTyBase, pattern UTyVar, + pattern UTyVar', pattern UTyVoid, pattern UTyUnit, pattern UTyInt, @@ -64,6 +69,7 @@ pattern UTyBool, pattern UTyActor, pattern UTyKey, + pattern UTyType, pattern UTySum, pattern UTyProd, pattern UTyFun, @@ -77,25 +83,48 @@ ucata, mkVarName, fuvs, + hasAnyUVars, + isTopLevelConstructor, + UnchainableFun (..), -- * Polytypes - Poly (..), + ImplicitQuantification (..), + Poly, + mkPoly, + mkQPoly, + mkTrivPoly, + unPoly, + ptVars, + ptBody, Polytype, + RawPolytype, pattern PolyUnit, UPolytype, + quantify, + absQuantify, + forgetQ, -- * Contexts TCtx, UCtx, + TVCtx, -- * User type definitions TydefInfo (..), tydefType, tydefArity, substTydef, + ExpandTydefErr (..), expandTydef, + expandTydefs, elimTydef, TDCtx, + emptyTDCtx, + lookupTD, + lookupTDR, + addBindingTD, + withBindingTD, + resolveUserTy, -- * WHNF whnfType, @@ -106,31 +135,46 @@ import Control.Algebra (Has, run) import Control.Carrier.Reader (runReader) -import Control.Effect.Reader (Reader, ask) -import Control.Lens (makeLenses, view) +import Control.Carrier.Throw.Either (runThrow) +import Control.Effect.Reader (Reader, ask, local) +import Control.Effect.Throw (Throw, throwError) +import Control.Lens (Plated (..), makeLenses, rewriteM, view) import Control.Monad.Free import Data.Aeson (FromJSON (..), FromJSON1 (..), ToJSON (..), ToJSON1 (..), genericLiftParseJSON, genericLiftToJSON, genericParseJSON, genericToJSON) import Data.Data (Data) +import Data.Data.Lens (uniplate) import Data.Eq.Deriving (deriveEq1) import Data.Fix import Data.Foldable (fold) +import Data.Functor.Classes (Eq1) +import Data.Hashable (Hashable (..)) +import Data.Hashable.Lifted (Hashable1) import Data.Kind qualified +import Data.List.NonEmpty ((<|)) +import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as M -import Data.Maybe (fromMaybe) +import Data.MonoidMap (MonoidMap) +import Data.MonoidMap qualified as MM +import Data.MonoidMap.JSON () import Data.Ord.Deriving (deriveOrd1) +import Data.Semigroup (Sum (..)) import Data.Set (Set) import Data.Set qualified as S import Data.String (IsString (..)) import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic, Generic1) -import Swarm.Language.Context (Ctx, Var) +import Prettyprinter (align, braces, brackets, concatWith, flatAlt, hsep, pretty, punctuate, softline, (<+>)) +import Swarm.Language.Context (Ctx) import Swarm.Language.Context qualified as Ctx -import Swarm.Util (parens, showT) +import Swarm.Language.TDVar (TDVar, mkTDVar, mkTDVar', tdVarName) +import Swarm.Language.Var (Var) +import Swarm.Pretty (PrettyPrec (..), pparens, pparens', ppr, prettyBinding) +import Swarm.Util (showT, unsnocNE) import Swarm.Util.JSON (optionsMinimize, optionsUnwrapUnary) import Text.Show.Deriving (deriveShow1) -import Witch +import Witch (into) ------------------------------------------------------------ -- Base types @@ -157,11 +201,16 @@ BActor | -- | Keys, i.e. things that can be pressed on the keyboard BKey - deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic, FromJSON, ToJSON) + | -- | The type of types + BType + deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic, Hashable, FromJSON, ToJSON) baseTyName :: BaseTy -> Text baseTyName = into @Text . drop 1 . show +instance PrettyPrec BaseTy where + prettyPrec _ = pretty . drop 1 . show + ------------------------------------------------------------ -- Type constructors ------------------------------------------------------------ @@ -181,8 +230,8 @@ | -- | Function types. TCFun | -- | User-defined type constructor. - TCUser Var - deriving (Eq, Ord, Show, Data, Generic) + TCUser TDVar + deriving (Eq, Ord, Show, Data, Generic, Hashable) instance ToJSON TyCon where toJSON = genericToJSON optionsMinimize @@ -190,10 +239,20 @@ instance FromJSON TyCon where parseJSON = genericParseJSON optionsMinimize +instance PrettyPrec TyCon where + prettyPrec _ = \case + TCBase b -> ppr b + TCCmd -> "Cmd" + TCDelay -> "Delay" + TCSum -> "Sum" + TCProd -> "Prod" + TCFun -> "Fun" + TCUser t -> ppr t + -- | The arity of a type, /i.e./ the number of type parameters it -- expects. newtype Arity = Arity {getArity :: Int} - deriving (Eq, Ord, Show, Generic, Data) + deriving (Eq, Ord, Show, Generic, Data, Hashable) instance ToJSON Arity where toJSON = genericToJSON optionsUnwrapUnary @@ -201,6 +260,9 @@ instance FromJSON Arity where parseJSON = genericParseJSON optionsUnwrapUnary +instance PrettyPrec Arity where + prettyPrec _ (Arity a) = pretty a + ------------------------------------------------------------ -- Types ------------------------------------------------------------ @@ -209,7 +271,7 @@ data Nat where NZ :: Nat NS :: Nat -> Nat - deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON) + deriving (Eq, Ord, Show, Data, Generic, Hashable, FromJSON, ToJSON) natToInt :: Nat -> Int natToInt NZ = 0 @@ -227,8 +289,12 @@ -- directly store a list of all arguments (as opposed to -- iterating binary application). TyConF TyCon [t] - | -- | A type variable. - TyVarF Var + | -- | A type variable. The first Var represents the original name, + -- and should be ignored except for use in e.g. error messages. + -- The second Var is the real name of the variable; it may be the + -- same as the first, or it may be different e.g. if it is a + -- freshly generated skolem variable. + TyVarF Var Var | -- | Record type. TyRcdF (Map Var t) | -- | A recursive type variable bound by an enclosing Rec, @@ -238,12 +304,14 @@ -- when pretty-printing; the actual bound variables are represented -- via de Bruijn indices. TyRecF Var t - deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1, Data) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1, Data, Hashable) deriveEq1 ''TypeF deriveOrd1 ''TypeF deriveShow1 ''TypeF +instance Hashable1 TypeF -- needs the Eq1 instance + instance ToJSON1 TypeF where liftToJSON = genericLiftToJSON optionsMinimize @@ -256,13 +324,15 @@ -- with 'Type' as if it were defined in a directly recursive way. type Type = Fix TypeF --- | Get all the type variables contained in a 'Type'. -tyVars :: Type -> Set Var -tyVars = foldFix (\case TyVarF x -> S.singleton x; f -> fold f) +instance Plated Type where + plate = uniplate newtype IntVar = IntVar Int - deriving (Show, Data, Eq, Ord) + deriving (Show, Data, Eq, Ord, Generic, Hashable) +instance PrettyPrec IntVar where + prettyPrec _ = ppr . mkVarName "u" + -- | 'UType's are like 'Type's, but also contain unification -- variables. 'UType' is defined via 'Free', which is also a kind -- of fixed point (in fact, @Free TypeF@ is the /free monad/ over @@ -272,6 +342,9 @@ -- working with 'UType' as if it were defined directly. type UType = Free TypeF IntVar +-- orphan instance +instance (Eq1 f, Hashable x, Hashable (f (Free f x))) => Hashable (Free f x) + -- | A generic /fold/ for things defined via 'Free' (including, in -- particular, 'UType'). ucata :: Functor t => (v -> a) -> (t a -> a) -> Free t v -> a @@ -282,54 +355,246 @@ -- as a unification variable) into a unique variable name, by -- appending a number to the given name. mkVarName :: Text -> IntVar -> Var -mkVarName nm (IntVar v) = T.append nm (from @String (show v)) +mkVarName nm (IntVar v) = T.append nm (showT v) -- | Get all the free unification variables in a 'UType'. fuvs :: UType -> Set IntVar fuvs = ucata S.singleton fold +-- | Check whether a type contains any unification variables at all. +hasAnyUVars :: UType -> Bool +hasAnyUVars = ucata (const True) or + +-- | Check whether a type consists of a top-level type constructor +-- immediately applied to unification variables. +isTopLevelConstructor :: UType -> Maybe (TypeF ()) +isTopLevelConstructor = \case + Free (TyRcdF m) | all isPure m -> Just (TyRcdF M.empty) + UTyConApp c ts | all isPure ts -> Just (TyConF c []) + _ -> Nothing + +isPure :: Free f a -> Bool +isPure (Pure {}) = True +isPure _ = False + -- | For convenience, so we can write /e.g./ @"a"@ instead of @TyVar "a"@. instance IsString Type where - fromString x = TyVar (from @String x) + fromString = TyVar . into @Text instance IsString UType where - fromString x = UTyVar (from @String x) + fromString = UTyVar . into @Text +-------------------------------------------------- +-- Recursive type utilities + +-- | @unfoldRec x t@ unfolds the recursive type @rec x. t@ one step, +-- to @t [(rec x. t) / x]@. +unfoldRec :: SubstRec t => Var -> t -> t +unfoldRec x ty = substRec (TyRecF x ty) ty NZ + +-- | Class of type-like things where we can substitute for a bound de +-- Bruijn variable. +class SubstRec t where + -- | @substRec s t n@ substitutes @s@ for the bound de Bruijn variable + -- @n@ everywhere in @t@. + substRec :: TypeF t -> t -> Nat -> t + +instance SubstRec (Free TypeF v) where + substRec s = ucata (\i _ -> Pure i) $ \f i -> case f of + TyRecVarF j + | i == j -> Free s + | otherwise -> Free (TyRecVarF j) + TyRecF x g -> Free (TyRecF x (g (NS i))) + _ -> Free (fmap ($ i) f) + +instance SubstRec Type where + substRec s = foldFix $ \f i -> case f of + TyRecVarF j + | i == j -> Fix s + | otherwise -> Fix (TyRecVarF j) + TyRecF x g -> Fix (TyRecF x (g (NS i))) + _ -> Fix (fmap ($ i) f) + +-------------------------------------------------- +-- Pretty-printing machinery for types + +-- | Split a function type chain, so that we can pretty print +-- the type parameters aligned on each line when they don't fit. +class UnchainableFun t where + unchainFun :: t -> NE.NonEmpty t + +instance UnchainableFun Type where + unchainFun (a :->: ty) = a <| unchainFun ty + unchainFun ty = pure ty + +instance UnchainableFun (Free TypeF ty) where + unchainFun (Free (TyConF TCFun [ty1, ty2])) = ty1 <| unchainFun ty2 + unchainFun ty = pure ty + +instance (UnchainableFun t, PrettyPrec t, SubstRec t) => PrettyPrec (TypeF t) where + prettyPrec p = \case + TyVarF v _ -> ppr v + TyRcdF m -> brackets $ hsep (punctuate "," (map prettyBinding (M.assocs m))) + -- Special cases for type constructors with special syntax. + -- Always use parentheses around sum and product types, see #1625 + TyConF TCSum [ty1, ty2] -> + pparens (p > 0) $ + prettyPrec 2 ty1 <+> "+" <+> prettyPrec 2 ty2 + TyConF TCProd [ty1, ty2] -> + pparens (p > 0) $ + prettyPrec 2 ty1 <+> "*" <+> prettyPrec 2 ty2 + TyConF TCDelay [ty] -> braces $ ppr ty + TyConF TCFun [ty1, ty2] -> + let (iniF, lastF) = unsnocNE $ ty1 <| unchainFun ty2 + funs = (prettyPrec 2 <$> iniF) <> [prettyPrec 1 lastF] + inLine l r = l <+> "->" <+> r + multiLine l r = l <+> "->" <> softline <> r + in pparens' (p > 1) . align $ + flatAlt (concatWith multiLine funs) (concatWith inLine funs) + TyRecF x ty -> + pparens (p > 0) $ + "rec" <+> ppr x <> "." <+> prettyPrec 0 (substRec (TyVarF x x) ty NZ) + -- This case shouldn't be possible, since TyRecVar should only occur inside a TyRec, + -- and pretty-printing the TyRec (above) will substitute a variable name for + -- any bound TyRecVars before recursing. + TyRecVarF i -> pretty (show (natToInt i)) + -- Fallthrough cases for type constructor application. Handles base + -- types, Cmd, user-defined types, or ill-kinded things like 'Int + -- Bool'. + TyConF c [] -> ppr c + TyConF c tys -> pparens (p > 9) $ ppr c <+> hsep (map (prettyPrec 10) tys) + ------------------------------------------------------------ -- Generic folding over type representations ------------------------------------------------------------ +-- | Type class for various type representations (e.g. 'Type', +-- 'UType') and generic operations we can perform on them. This +-- helps us avoid code duplication in some cases, by writing a +-- single generic function which works for any 'Typical' instance. class Typical t where - foldT :: (TypeF t -> t) -> t -> t + -- | Fold a type into a summary value of some type @a@, given an + -- "empty" value of type @a@ (for use at e.g. Pure nodes in a + -- UType) + foldT :: a -> (TypeF a -> a) -> t -> a + + -- | Refold a type into another type. This is a special case of + -- 'foldT' when we want to produce another type, since then we can + -- do something more sensible with 'Pure' nodes in a 'UType' + -- (i.e. preserve them instead of replacing them with a default + -- value). + refoldT :: (TypeF t -> t) -> t -> t + + -- | Unroll one level of structure. + unrollT :: t -> Maybe (TypeF t) + + -- | Roll up one level of structure. rollT :: TypeF t -> t + + -- | It should be possible to convert 'Type' to any type-ish thing. fromType :: Type -> t instance Typical Type where - foldT = foldFix + foldT _ = foldFix + refoldT = foldFix + unrollT (Fix t) = Just t rollT = Fix fromType = id instance Typical UType where - foldT = ucata Pure + foldT e = ucata (const e) + refoldT = ucata Pure + unrollT (Free t) = Just t + unrollT _ = Nothing rollT = Free fromType = toU +-- | Get all the type variables (/not/ unification variables) +-- contained in a 'Type' or 'UType'. +tyVars :: Typical t => t -> Set Var +tyVars = foldT S.empty (\case TyVarF _ x -> S.singleton x; f -> fold f) + ------------------------------------------------------------ -- Polytypes ------------------------------------------------------------ --- | A @Poly t@ is a universally quantified @t@. The variables in the --- list are bound inside the @t@. For example, the type @forall --- a. a -> a@ would be represented as @Forall ["a"] (TyFun "a" "a")@. -data Poly t = Forall {ptVars :: [Var], ptBody :: t} - deriving (Show, Eq, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON) +data ImplicitQuantification = Unquantified | Quantified + deriving (Eq, Ord, Read, Show) --- | A polytype without unification variables. -type Polytype = Poly Type +-- | A @Poly q t@ is a universally quantified @t@. The variables in +-- the list are bound inside the @t@. For example, the type @forall +-- a. a -> a@ would be represented as @Forall ["a"] (TyFun "a" +-- "a")@. +-- +-- The type index @q@ is a phantom type index indicating whether the +-- type has been implicitly quantified. Immediately after a +-- polytype is parsed it is 'Unquantified' and unsafe to use. For +-- example, the type @a -> a@ would parse literally as @Forall [] +-- (TyFun "a" "a") :: Poly Unquantified Type@, where the type +-- variable @a@ is not in the list of bound variables. Later, after +-- running through 'quantify', it would become a @Poly Quantified +-- Type@, either @Forall ["a"] (TyFun "a" "a")@ if the type variable +-- is implicitly quantified, or unchanged if the type variable @a@ +-- was already in scope. +-- +-- The @Poly@ constructor intentionally unexported, so that the +-- only way to create a @Poly Quantified@ is through the 'quantify' +-- function. +data Poly (q :: ImplicitQuantification) t = Forall {_ptVars :: [Var], ptBody :: t} + deriving (Show, Eq, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON, Hashable) +-- | Create a raw, unquantified @Poly@ value. +mkPoly :: [Var] -> t -> Poly 'Unquantified t +mkPoly = Forall + +-- | Create a polytype while performing implicit quantification. +mkQPoly :: Typical t => t -> Poly 'Quantified t +mkQPoly = absQuantify . Forall [] + +-- | Create a trivial "polytype" with no bound variables. This is +-- somewhat unsafe --- only use this if you are sure that the polytype +-- you want has no type variables. +mkTrivPoly :: t -> Poly q t +mkTrivPoly = Forall [] + +-- | Project out the variables and body of a 'Poly' value. It's only +-- possible to project from a 'Poly Quantified' since the list of +-- variables might be meaningless for a type that has not had +-- implicit quantification applied. +unPoly :: Poly 'Quantified t -> ([Var], t) +unPoly (Forall xs t) = (xs, t) + +-- | Project out the variables of a 'Poly Quantified' value. +ptVars :: Poly 'Quantified t -> [Var] +ptVars (Forall xs _) = xs + +-- | Forget that a polytype has been properly quantified. +forgetQ :: Poly 'Quantified t -> Poly 'Unquantified t +forgetQ (Forall xs t) = Forall xs t + +-- | A regular polytype (without unification variables). A @Polytype@ +-- (as opposed to a @RawPolytype@) is guaranteed to have implicit +-- quantification properly applied, so that all type variables bound +-- by the forall are explicitly listed. +type Polytype = Poly 'Quantified Type + +-- | A raw polytype (without unification variables), which corresponds +-- exactly to the way a polytype was written in source code. In +-- particular there may be type variables which are used in the type +-- but not listed explicitly, which are to be implicitly quantified. +type RawPolytype = Poly 'Unquantified Type + +instance PrettyPrec (Poly q Type) where + prettyPrec _ (Forall [] t) = ppr t + prettyPrec _ (Forall xs t) = hsep ("∀" : map ppr xs) <> "." <+> ppr t + -- | A polytype with unification variables. -type UPolytype = Poly UType +type UPolytype = Poly 'Quantified UType +instance PrettyPrec (Poly q UType) where + prettyPrec _ (Forall [] t) = ppr t + prettyPrec _ (Forall xs t) = hsep ("∀" : map ppr xs) <> "." <+> ppr t + ------------------------------------------------------------ -- WithU ------------------------------------------------------------ @@ -387,7 +652,9 @@ pattern TyBase b = TyConApp (TCBase b) [] pattern TyVar :: Var -> Type -pattern TyVar v = Fix (TyVarF v) +pattern TyVar x <- Fix (TyVarF _ x) + where + TyVar x = Fix (TyVarF x x) pattern TyVoid :: Type pattern TyVoid = TyBase BVoid @@ -413,6 +680,9 @@ pattern TyKey :: Type pattern TyKey = TyBase BKey +pattern TyType :: Type +pattern TyType = TyBase BType + infixr 5 :+: pattern (:+:) :: Type -> Type -> Type @@ -437,7 +707,7 @@ pattern TyDelay :: Type -> Type pattern TyDelay ty = TyConApp TCDelay [ty] -pattern TyUser :: Var -> [Type] -> Type +pattern TyUser :: TDVar -> [Type] -> Type pattern TyUser v tys = TyConApp (TCUser v) tys pattern TyRec :: Var -> Type -> Type @@ -453,8 +723,13 @@ pattern UTyBase b = UTyConApp (TCBase b) [] pattern UTyVar :: Var -> UType -pattern UTyVar v = Free (TyVarF v) +pattern UTyVar x <- Free (TyVarF _ x) + where + UTyVar x = Free (TyVarF x x) +pattern UTyVar' :: Var -> Var -> UType +pattern UTyVar' x y = Free (TyVarF x y) + pattern UTyVoid :: UType pattern UTyVoid = UTyBase BVoid @@ -479,6 +754,9 @@ pattern UTyKey :: UType pattern UTyKey = UTyBase BKey +pattern UTyType :: UType +pattern UTyType = UTyBase BType + pattern UTySum :: UType -> UType -> UType pattern UTySum ty1 ty2 = UTyConApp TCSum [ty1, ty2] @@ -497,7 +775,7 @@ pattern UTyDelay :: UType -> UType pattern UTyDelay ty = UTyConApp TCDelay [ty] -pattern UTyUser :: Var -> [UType] -> UType +pattern UTyUser :: TDVar -> [UType] -> UType pattern UTyUser v tys = UTyConApp (TCUser v) tys pattern UTyRec :: Var -> UType -> UType @@ -512,14 +790,42 @@ -- | A @TCtx@ is a mapping from variables to polytypes. We generally -- get one of these at the end of the type inference process. -type TCtx = Ctx Polytype +type TCtx = Ctx Var Polytype -- | A @UCtx@ is a mapping from variables to polytypes with -- unification variables. We generally have one of these while we -- are in the midst of the type inference process. -type UCtx = Ctx UPolytype +type UCtx = Ctx Var UPolytype +-- | A @TVCtx@ tracks which type variables are in scope, and what +-- skolem variables were assigned to them. +type TVCtx = Ctx Var UType + ------------------------------------------------------------ +-- Implicit quantification of polytypes +------------------------------------------------------------ + +-- | Implicitly quantify any otherwise unbound type variables. +quantify :: + (Has (Reader TVCtx) sig m, Typical ty) => + Poly 'Unquantified ty -> + m (Poly 'Quantified ty) +quantify (Forall xs ty) = do + inScope <- ask @TVCtx + -- Look at all variables which occur in the type but are not + -- explicitly bound by the forall, and and are not bound in the + -- context. Such variables must be implicitly quantified. + let implicit = + (tyVars ty `S.difference` S.fromList xs) + `S.difference` M.keysSet (Ctx.unCtx inScope) + pure $ Forall (xs ++ S.toList implicit) ty + +-- | Absolute implicit quantification, i.e. assume there are no type +-- variables in scope. +absQuantify :: Typical t => Poly 'Unquantified t -> Poly 'Quantified t +absQuantify = run . runReader @TVCtx Ctx.empty . quantify + +------------------------------------------------------------ -- Type definitions ------------------------------------------------------------ @@ -527,46 +833,115 @@ { _tydefType :: Polytype , _tydefArity :: Arity } - deriving (Eq, Show, Generic, Data, FromJSON, ToJSON) + deriving (Eq, Show, Generic, Data, FromJSON, ToJSON, Hashable) makeLenses ''TydefInfo -- | A @TDCtx@ is a mapping from user-defined type constructor names --- to their definitions and arities/kinds. -type TDCtx = Ctx TydefInfo +-- to their definitions and arities/kinds. It also stores the +-- latest version of each name (for any names with more than one +-- version), so we can tell when a type definition has been +-- shadowed. +data TDCtx = TDCtx + { getTDCtx :: Ctx TDVar TydefInfo + , getTDVersions :: MonoidMap Text (Sum Int) + } + deriving (Eq, Generic, Show, ToJSON) +-- Need to write manual Hashable instance since MonoidMap +-- does not have instances of its own. + +instance Hashable TDCtx where + hashWithSalt s (TDCtx ctx versions) = + s + `hashWithSalt` ctx + `hashWithSalt` (getSum <$> MM.toMap versions) + +-- | The empty type definition context. +emptyTDCtx :: TDCtx +emptyTDCtx = TDCtx Ctx.empty MM.empty + +-- | Look up a variable in the type definition context. +lookupTD :: TDVar -> TDCtx -> Maybe TydefInfo +lookupTD x = Ctx.lookup x . getTDCtx + +-- | Look up a variable in an ambient type definition context. +lookupTDR :: Has (Reader TDCtx) sig m => TDVar -> m (Maybe TydefInfo) +lookupTDR x = lookupTD x <$> ask + +-- | Add a binding of a variable name to a type definition, giving it +-- an appropriate version number if it shadows other variables with +-- the same name. +addBindingTD :: Text -> TydefInfo -> TDCtx -> TDCtx +addBindingTD x info (TDCtx tdCtx tdVersions) = + case Ctx.lookup (mkTDVar x) tdCtx of + Nothing -> TDCtx (Ctx.addBinding (mkTDVar x) info tdCtx) tdVersions + Just _ -> + let newVersion = 1 + MM.get x tdVersions + in TDCtx (Ctx.addBinding (mkTDVar' (getSum newVersion) x) info tdCtx) (MM.set x newVersion tdVersions) + +-- | Locally extend the ambient type definition context with an +-- additional binding, via 'addBindingTD'. +withBindingTD :: Has (Reader TDCtx) sig m => Text -> TydefInfo -> m a -> m a +withBindingTD x info = local (addBindingTD x info) + +-- | Given a parsed variable representing a user-defined type, figure +-- out which version is currently in scope and set the version +-- number of the variable appropriately. +resolveUserTy :: Has (Reader TDCtx) sig m => TDVar -> m TDVar +resolveUserTy v = do + tdCtx <- ask + let x = tdVarName v + let ver = getSum (MM.get x (getTDVersions tdCtx)) + pure $ mkTDVar' ver x + +newtype ExpandTydefErr = UnexpandedUserType {getUnexpanded :: TDVar} + deriving (Eq, Show) + -- | Expand an application "T ty1 ty2 ... tyn" by looking up the -- definition of T and substituting ty1 .. tyn for its arguments. -- -- Note that this has already been kind-checked so we know the --- number of arguments must match up; we don't worry about what --- happens if the lists have different lengths since in theory that --- can never happen. -expandTydef :: (Has (Reader TDCtx) sig m, Typical t) => Var -> [t] -> m t +-- number of arguments must match up, and user types must be +-- defined; we don't worry about what happens if the lists have +-- different lengths since in theory that can never happen. +-- However, if T does not exist, we throw an error containing its +-- name. +expandTydef :: + ( Has (Reader TDCtx) sig m + , Has (Throw ExpandTydefErr) sig m + , Typical t + ) => + TDVar -> + [t] -> + m t expandTydef userTyCon tys = do - mtydefInfo <- Ctx.lookupR userTyCon - tdCtx <- ask @TDCtx - -- In theory, if everything has kind checked, we should never encounter an undefined - -- type constructor here. - let errMsg = - into @String $ - T.unwords - [ "Encountered undefined type constructor" - , userTyCon - , "in expandTyDef" - , parens ("tdCtx = " <> showT tdCtx) - ] - tydefInfo = fromMaybe (error errMsg) mtydefInfo - return $ substTydef tydefInfo tys + mtydefInfo <- lookupTDR userTyCon + case mtydefInfo of + Nothing -> throwError (UnexpandedUserType userTyCon) + Just tydefInfo -> pure $ substTydef tydefInfo tys +-- | Expand *all* applications of user-defined type constructors +-- everywhere in a type. +expandTydefs :: + (Has (Reader TDCtx) sig m, Has (Throw ExpandTydefErr) sig m, Typical t, Plated t) => + t -> + m t +expandTydefs = rewriteM expand + where + -- expand :: t -> m (Maybe t) + expand t = case unrollT t of + Just (TyConF (TCUser u) tys) -> Just <$> expandTydef u tys + _ -> pure Nothing + -- | Given the definition of a type alias, substitute the given -- arguments into its body and return the resulting type. substTydef :: forall t. Typical t => TydefInfo -> [t] -> t -substTydef (TydefInfo (Forall as ty) _) tys = foldT @t substF (fromType ty) +substTydef (TydefInfo (Forall as ty) _) tys = refoldT @t substF (fromType ty) where argMap = M.fromList $ zip as tys - substF tyF@(TyVarF x) = case M.lookup x argMap of + substF tyF@(TyVarF _ x) = case M.lookup x argMap of Nothing -> rollT tyF Just ty' -> ty' substF tyF = rollT tyF @@ -575,8 +950,8 @@ -- inside a type. Typically this is done when reporting the type of -- a term containing a local tydef: since the tydef is local we -- can't use it in the reported type. -elimTydef :: forall t. Typical t => Var -> TydefInfo -> t -> t -elimTydef x tdInfo = foldT substF +elimTydef :: forall t. Typical t => TDVar -> TydefInfo -> t -> t +elimTydef x tdInfo = refoldT substF where substF = \case TyConF (TCUser u) tys | u == x -> substTydef tdInfo tys @@ -599,52 +974,25 @@ TCSum -> Just 2 TCProd -> Just 2 TCFun -> Just 2 - TCUser t -> getArity . view tydefArity <$> Ctx.lookup t tydefs - ------------------------------------------------------------- --- Recursive type utilities ------------------------------------------------------------- - --- | @unfoldRec x t@ unfolds the recursive type @rec x. t@ one step, --- to @t [(rec x. t) / x]@. -unfoldRec :: SubstRec t => Var -> t -> t -unfoldRec x ty = substRec (TyRecF x ty) ty NZ - --- | Class of type-like things where we can substitute for a bound de --- Bruijn variable. -class SubstRec t where - -- | @substRec s t n@ substitutes @s@ for the bound de Bruijn variable - -- @n@ everywhere in @t@. - substRec :: TypeF t -> t -> Nat -> t - -instance SubstRec (Free TypeF v) where - substRec s = ucata (\i _ -> Pure i) $ \f i -> case f of - TyRecVarF j - | i == j -> Free s - | otherwise -> Free (TyRecVarF j) - TyRecF x g -> Free (TyRecF x (g (NS i))) - _ -> Free (fmap ($ i) f) - -instance SubstRec Type where - substRec s = foldFix $ \f i -> case f of - TyRecVarF j - | i == j -> Fix s - | otherwise -> Fix (TyRecVarF j) - TyRecF x g -> Fix (TyRecF x (g (NS i))) - _ -> Fix (fmap ($ i) f) + TCUser t -> getArity . view tydefArity <$> lookupTD t tydefs ------------------------------------------------------------ -- Reducing types to WHNF ------------------------------------------------------------ --- | Reduce a type to weak head normal form, i.e. keep unfold type +-- | Reduce a type to weak head normal form, i.e. keep unfolding type -- aliases and recursive types just until the top-level constructor --- of the type is neither @rec@ nor an application of a type alias. +-- of the type is neither @rec@ nor an application of a defined type +-- alias. whnfType :: TDCtx -> Type -> Type whnfType tdCtx = run . runReader tdCtx . go where go :: Has (Reader TDCtx) sig m => Type -> m Type go = \case - TyUser u tys -> expandTydef u tys >>= go + TyUser u tys -> do + res <- runThrow @ExpandTydefErr (expandTydef u tys) + case res of + Left _ -> pure $ TyUser u tys + Right expTy -> go expTy TyRec x ty -> go (unfoldRec x ty) ty -> pure ty diff --git a/src/swarm-lang/Swarm/Language/Value.hs b/src/swarm-lang/Swarm/Language/Value.hs --- a/src/swarm-lang/Swarm/Language/Value.hs +++ b/src/swarm-lang/Swarm/Language/Value.hs @@ -29,7 +29,9 @@ import Control.Lens hiding (Const) import Data.Bool (bool) -import Data.List (foldl') +import Data.Foldable (Foldable (..)) +import Data.Function (on) +import Data.Hashable (Hashable, hash) import Data.Map (Map) import Data.Map qualified as M import Data.Set qualified as S @@ -39,12 +41,13 @@ import Swarm.Language.Context (Ctx) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Key (KeyCombo, prettyKeyCombo) -import Swarm.Language.Pretty (prettyText) import Swarm.Language.Requirements.Type (ReqCtx, Requirements) import Swarm.Language.Syntax import Swarm.Language.Syntax.Direction import Swarm.Language.Typed -import Swarm.Language.Types (Polytype, TCtx, TDCtx, TydefInfo) +import Swarm.Language.Types (Polytype, TCtx, TDCtx, TydefInfo, Type, addBindingTD, emptyTDCtx) +import Swarm.Pretty (prettyText) +import Prelude hiding (Foldable (..)) -- | A /value/ is a term that cannot (or does not) take any more -- evaluation steps on its own. @@ -118,11 +121,17 @@ -- .) VBlackhole :: Value - deriving (Eq, Show, Generic) + -- | A special value used to represent runtime type information + -- passed to ad-hoc polymorphic functions. + VType :: Type -> Value + deriving (Eq, Generic, Hashable) +-- For the lack of Show and Eq instances, see Note [Env Show and Eq +-- instances] + -- | A value context is a mapping from variable names to their runtime -- values. -type VCtx = Ctx Value +type VCtx = Ctx Var Value -------------------------------------------------- -- Environments @@ -141,12 +150,28 @@ , _envTydefs :: TDCtx -- ^ Type synonym definitions. } - deriving (Eq, Show, Generic) + deriving (Hashable, Generic) +-- A derived `Eq` instance for `Env` can cause exponential blowup (see +-- Note [Env Show and Eq instances]), but we need an `Eq` instance in +-- order to have a `Hashable` instance. So we just implement equality +-- testing by comparing hashes. +instance Eq Env where + (==) = (==) `on` hash + +-- ~~~~ Note [Env Show and Eq instances] +-- Env contains values, which can be e.g. closures, which +-- contain more Envs. Normally, in memory, there is a lot of sharing, +-- but when naively printing it out all the sharing is lost and it can +-- generate tons of output. This is why we intentionally do NOT have +-- a Show instance for Env (hence neither for Value). Similarly, we +-- do not have a derived Eq instance since it would be incredibly +-- inefficient and there is no good reason to use it. See #2197. + makeLenses ''Env emptyEnv :: Env -emptyEnv = Env Ctx.empty Ctx.empty Ctx.empty Ctx.empty +emptyEnv = Env Ctx.empty Ctx.empty Ctx.empty emptyTDCtx lookupValue :: Var -> Env -> Maybe Value lookupValue x e = Ctx.lookup x (e ^. envVals) @@ -161,18 +186,10 @@ addValueBinding :: Var -> Value -> Env -> Env addValueBinding x v = envVals %~ Ctx.addBinding x v -addTydef :: Var -> TydefInfo -> Env -> Env -addTydef x pty = envTydefs %~ Ctx.addBinding x pty - -instance Semigroup Env where - Env t1 r1 v1 td1 <> Env t2 r2 v2 td2 = Env (t1 <> t2) (r1 <> r2) (v1 <> v2) (td1 <> td2) - -instance Monoid Env where - mempty = Env mempty mempty mempty mempty - -instance AsEmpty Env +addTydef :: Text -> TydefInfo -> Env -> Env +addTydef x pty = envTydefs %~ addBindingTD x pty -type instance Index Env = Ctx.Var +type instance Index Env = Var type instance IxValue Env = Typed Value instance Ixed Env @@ -225,7 +242,7 @@ M.foldrWithKey ( \y v -> case v of VIndir {} -> id - _ -> TLet LSLet False y Nothing Nothing (valueToTerm v) + _ -> TLet LSLet False y Nothing Nothing Nothing (valueToTerm v) ) (TLam x Nothing t) (M.restrictKeys (Ctx.unCtx (e ^. envVals)) (S.delete x (setOf freeVarsV (Syntax' NoLoc t Empty ())))) @@ -240,3 +257,4 @@ VSuspend t _ -> TSuspend t VExc -> TConst Undefined VBlackhole -> TConst Undefined + VType ty -> TType ty diff --git a/src/swarm-lang/Swarm/Language/Var.hs b/src/swarm-lang/Swarm/Language/Var.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Var.hs @@ -0,0 +1,12 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Value-level variables. +module Swarm.Language.Var where + +import Data.Text (Text) + +-- | For now, we just use 'Text' to represent variables. In theory, +-- at some point in the future we might want to represent them in some +-- fancier way. +type Var = Text diff --git a/src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs b/src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs --- a/src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs +++ b/src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs @@ -126,6 +126,7 @@ | GetDisoriented | SwapSame | GaveToSelf + | EquippedAllDevices deriving (Eq, Ord, Show, Bounded, Enum, Generic) instance FromJSON GameplayAchievement diff --git a/src/swarm-scenario/Swarm/Game/Device.hs b/src/swarm-scenario/Swarm/Game/Device.hs --- a/src/swarm-scenario/Swarm/Game/Device.hs +++ b/src/swarm-scenario/Swarm/Game/Device.hs @@ -71,7 +71,7 @@ -- Otherwise, parse as a Map from capabilities to ingredients. instance (FromJSON e) => FromJSON (SingleEntityCapabilities e) where parseJSON x = - simpleList <|> (Capabilities <$> costMap) + (Capabilities <$> costMap) <|> simpleList where simpleList = zeroCostCapabilities <$> parseJSON x costMap = withArray "Capabilities" (fmap (M.fromList . map toMapEntry) . mapM parseJSON . V.toList) x diff --git a/src/swarm-scenario/Swarm/Game/Display.hs b/src/swarm-scenario/Swarm/Game/Display.hs --- a/src/swarm-scenario/Swarm/Game/Display.hs +++ b/src/swarm-scenario/Swarm/Game/Display.hs @@ -22,6 +22,7 @@ defaultChar, orientationMap, curOrientation, + boundaryOverride, displayAttr, displayPriority, invisible, @@ -31,15 +32,20 @@ displayChar, hidden, + -- ** Neighbor-based boundary rendering + getBoundaryDisplay, + -- ** Construction defaultTerrainDisplay, defaultEntityDisplay, defaultRobotDisplay, ) where +import Control.Applicative ((<|>)) import Control.Lens hiding (Const, from, (.=)) import Control.Monad (when) import Data.Hashable (Hashable) +import Data.List.Extra (enumerate) import Data.Map (Map) import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust) @@ -49,7 +55,7 @@ import GHC.Generics (Generic) import Graphics.Text.Width import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..)) -import Swarm.Util (maxOn, quote) +import Swarm.Util (applyWhen, maxOn, quote) import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE) @@ -89,6 +95,7 @@ { _defaultChar :: Char , _orientationMap :: Map AbsoluteDir Char , _curOrientation :: Maybe Direction + , _boundaryOverride :: Maybe Char , _displayAttr :: Attribute , _displayPriority :: Priority , _invisible :: Bool @@ -117,6 +124,9 @@ -- know which character to use from the orientation map. curOrientation :: Lens' Display (Maybe Direction) +-- | The display character to substitute when neighbor boundaries are present +boundaryOverride :: Lens' Display (Maybe Char) + -- | The attribute to use for display. displayAttr :: Lens' Display Attribute @@ -146,6 +156,7 @@ liftE $ do let _defaultChar = c + _boundaryOverride = Nothing _orientationMap <- v .:? "orientationMap" .!= dOM _curOrientation <- v .:? "curOrientation" .!= (defD ^. curOrientation) _displayAttr <- (v .:? "attr") .!= (defD ^. displayAttr) @@ -172,16 +183,18 @@ object $ [ "char" .= (d ^. defaultChar) , "attr" .= (d ^. displayAttr) - , "priority" .= (d ^. displayPriority) ] + ++ ["priority" .= (d ^. displayPriority) | (d ^. displayPriority) /= (defaultEntityDisplay ' ' ^. displayPriority)] ++ ["orientationMap" .= (d ^. orientationMap) | not (M.null (d ^. orientationMap))] ++ ["invisible" .= (d ^. invisible) | d ^. invisible] -- | Look up the character that should be used for a display. displayChar :: Display -> Char -displayChar disp = fromMaybe (disp ^. defaultChar) $ do - DAbsolute d <- disp ^. curOrientation - M.lookup d (disp ^. orientationMap) +displayChar disp = + fromMaybe (disp ^. defaultChar) $ + disp ^. boundaryOverride <|> do + DAbsolute d <- disp ^. curOrientation + M.lookup d (disp ^. orientationMap) -- | Modify a display to use a @?@ character for entities that are -- hidden/unknown. @@ -204,6 +217,7 @@ { _defaultChar = c , _orientationMap = M.empty , _curOrientation = Nothing + , _boundaryOverride = Nothing , _displayAttr = AEntity , _displayPriority = 1 , _invisible = False @@ -227,6 +241,7 @@ , (DSouth, 'v') , (DNorth, '^') ] + , _boundaryOverride = Nothing , _curOrientation = Nothing , _displayAttr = ARobot , _displayPriority = 10 @@ -236,3 +251,61 @@ instance Monoid Display where mempty = defaultEntityDisplay ' ' & invisible .~ True + +-- * Boundary rendering + +-- | This type is isomorphic to 'Bool' but +-- is more compact for readability of the +-- 'glyphForNeighbors' cases. +data Presence + = -- | present + X + | -- | absent + O + +emptyNeighbors :: Neighbors Presence +emptyNeighbors = Neighbors O O O O + +data Neighbors a = Neighbors + { e :: a + , w :: a + , n :: a + , s :: a + } + +computeNeighborPresence :: (AbsoluteDir -> Bool) -> Neighbors Presence +computeNeighborPresence checkPresence = + foldr assignPresence emptyNeighbors enumerate + where + assignPresence d = applyWhen (checkPresence d) $ setNeighbor d X + +setNeighbor :: AbsoluteDir -> a -> Neighbors a -> Neighbors a +setNeighbor DNorth x y = y {n = x} +setNeighbor DSouth x y = y {s = x} +setNeighbor DEast x y = y {e = x} +setNeighbor DWest x y = y {w = x} + +-- | For a center cell that itself is a boundary, +-- determine a glyph override for rendering, given certain +-- neighbor combinations. +glyphForNeighbors :: Neighbors Presence -> Maybe Char +glyphForNeighbors = \case + Neighbors {e = O, w = O, n = O, s = O} -> Nothing + Neighbors {e = X, w = O, n = O, s = O} -> Just '╶' + Neighbors {e = O, w = X, n = O, s = O} -> Just '╴' + Neighbors {e = X, w = X, n = O, s = O} -> Just '─' + Neighbors {e = O, w = O, n = X, s = O} -> Just '╵' + Neighbors {e = O, w = O, n = O, s = X} -> Just '╷' + Neighbors {e = O, w = O, n = X, s = X} -> Just '│' + Neighbors {e = X, w = O, n = X, s = O} -> Just '└' + Neighbors {e = X, w = O, n = O, s = X} -> Just '┌' + Neighbors {e = O, w = X, n = X, s = O} -> Just '┘' + Neighbors {e = O, w = X, n = O, s = X} -> Just '┐' + Neighbors {e = X, w = X, n = X, s = O} -> Just '┴' + Neighbors {e = X, w = X, n = O, s = X} -> Just '┬' + Neighbors {e = X, w = O, n = X, s = X} -> Just '├' + Neighbors {e = O, w = X, n = X, s = X} -> Just '┤' + Neighbors {e = X, w = X, n = X, s = X} -> Just '┼' + +getBoundaryDisplay :: (AbsoluteDir -> Bool) -> Maybe Char +getBoundaryDisplay = glyphForNeighbors . computeNeighborPresence diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs --- a/src/swarm-scenario/Swarm/Game/Entity.hs +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -75,6 +75,7 @@ contains, contains0plus, elems, + nonzeroEntities, isSubsetOf, isEmpty, inventoryCapabilities, @@ -102,41 +103,44 @@ import Data.Bifunctor (first) import Data.Char (toLower) import Data.Either.Extra (maybeToEither) +import Data.Foldable (Foldable (elem, foldl', null)) import Data.Function (on) import Data.Hashable import Data.IntMap (IntMap) import Data.IntMap qualified as IM import Data.IntSet (IntSet) import Data.IntSet qualified as IS -import Data.List (foldl') import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M import Data.Maybe (isJust, listToMaybe) +import Data.MonoidMap (MonoidMap) +import Data.MonoidMap qualified as MM +import Data.MonoidMap.JSON () import Data.Set (Set) -import Data.Set qualified as Set (fromList, member) +import Data.Set qualified as Set (fromList, member, null) import Data.Text (Text) import Data.Text qualified as T import Data.Yaml import GHC.Generics (Generic) +import Swarm.Failure import Swarm.Game.Device import Swarm.Game.Display import Swarm.Game.Entity.Cosmetic (WorldAttr (..)) import Swarm.Game.Entity.Cosmetic.Assignment (worldAttributes) -import Swarm.Game.Failure import Swarm.Game.Ingredients import Swarm.Game.Location -import Swarm.Game.ResourceLoading (getDataFileNameSafe) import Swarm.Game.Terrain (TerrainType) import Swarm.Language.Capability import Swarm.Language.Syntax (Syntax) import Swarm.Language.Text.Markdown (Document, docToText) +import Swarm.ResourceLoading (getDataFileNameSafe) import Swarm.Util (binTuples, failT, findDup, plural, quote, (?)) import Swarm.Util.Effect (withThrow) import Swarm.Util.Yaml import Text.Read (readMaybe) import Witch -import Prelude hiding (lookup) +import Prelude hiding (Foldable (..), lookup) ------------------------------------------------------------ -- Properties @@ -157,6 +161,8 @@ Pushable | -- | Obstructs the view of robots that attempt to "scout" Opaque + | -- | Is automatically rendered as a contiguous border + Boundary | -- | Regrows from a seed after it is harvested. Growable | -- | Can burn when ignited (either via 'Swarm.Language.Syntax.Ignite' or by @@ -166,8 +172,15 @@ Infinite | -- | Robots drown if they walk on this without a boat. Liquid + | -- | If robots try to 'Swarm.Language.Syntax.Place' this, + -- it disappears + Evanescent | -- | Robots automatically know what this is without having to scan it. Known + | -- | Text can be printed on this entity with the + -- 'Swarm.Language.Syntax.Print' command (and erased with + -- 'Swarm.Language.Syntax.Erase') + Printable deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable) instance ToJSON EntityProperty where @@ -241,19 +254,30 @@ -- See . , duration :: (Integer, Integer) -- ^ min and max tick counts for combustion to persist + , delay :: Integer + -- ^ Delay until this entity may start igniting its neighbors. , product :: Maybe EntityName -- ^ what entity, if any, is left over after combustion } - deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON) + deriving (Eq, Ord, Show, Read, Generic, Hashable, ToJSON) +instance FromJSON Combustibility where + parseJSON = withObject "Combustibility" $ \v -> do + ignition <- v .: "ignition" + duration <- v .: "duration" + delay <- v .:? "delay" .!= 0 + product <- v .: "product" + pure Combustibility {..} + -- | The default combustion specification for a combustible entity -- with no combustion specification: -- -- * ignition rate 0.5 -- * duration (100, 200) +-- * delay of 0 -- * product @ash@ defaultCombustibility :: Combustibility -defaultCombustibility = Combustibility 0.5 (100, 200) (Just "ash") +defaultCombustibility = Combustibility 0.5 (100, 200) 0 (Just "ash") ------------------------------------------------------------ -- Entity @@ -422,21 +446,31 @@ } deriving (Eq, Show, Generic, ToJSON) --- | --- Note that duplicates in a single 'EntityMap' are precluded by the --- 'buildEntityMap' function. --- But it is possible for the latter 'EntityMap' to override --- members of the former with the same name. --- This replacement happens automatically with 'Map', but needs --- to be explicitly handled for the list concatenation --- of 'entityDefinitionOrder' (overridden entries are removed --- from the former 'EntityMap'). +-- | Right-biased union of 'EntityMap's. +-- +-- Note that duplicates in a single 'EntityMap' are precluded by the +-- 'buildEntityMap' function. But it is possible for the right-hand +-- 'EntityMap' to override members of the left-hand with the same name. +-- For example, this is how custom entities defined in a scenario +-- can override standard entities. This replacement happens +-- automatically with 'Map' (as long as we keep in mind that Map +-- union is *left*-biased), but needs to be explicitly handled for the +-- list concatenation of 'entityDefinitionOrder' (overridden entries +-- are removed from the former 'EntityMap'), and for 'entitiesByCap', +-- which are organized by capability rather than by entity. instance Semigroup EntityMap where EntityMap n1 c1 d1 <> EntityMap n2 c2 d2 = EntityMap - (n1 <> n2) - (c1 <> c2) - (filter ((`M.notMember` n2) . view entityName) d1 <> d2) + (n2 <> n1) + (removeOverriddenDevices c1 <> c2) + (filter notOverridden d1 <> d2) + where + notOverridden :: Entity -> Bool + notOverridden = (`M.notMember` n2) . view entityName + removeOverriddenDevices (Capabilities m) = + Capabilities + . M.mapMaybe (NE.nonEmpty . NE.filter (notOverridden . device)) + $ m instance Monoid EntityMap where mempty = EntityMap M.empty mempty [] @@ -463,7 +497,8 @@ AWorld n -> unless (Set.member (WorldAttr $ T.unpack n) validAttrs) . throwError - . CustomMessage + . SystemFailure + . CustomFailure $ T.unwords [ "Nonexistent attribute" , quote n @@ -479,11 +514,10 @@ -- from a file; see 'loadEntities'. buildEntityMap :: Has (Throw LoadingFailure) sig m => [Entity] -> m EntityMap buildEntityMap es = do - case findDup (map fst namedEntities) of - Nothing -> return () - Just duped -> throwError $ Duplicate Entities duped + forM_ (findDup $ map fst namedEntities) $ + throwError . Duplicate Entities case combineEntityCapsM entsByName es of - Left x -> throwError $ CustomMessage x + Left x -> throwError . SystemFailure . CustomFailure $ x Right ebc -> return $ EntityMap @@ -561,8 +595,8 @@ [ "display" .= (e ^. entityDisplay) , "name" .= (e ^. entityName) , "description" .= (e ^. entityDescription) - , "tags" .= (e ^. entityTags) ] + ++ ["tags" .= (e ^. entityTags) | not (Set.null (e ^. entityTags))] ++ ["plural" .= (e ^. entityPlural) | isJust (e ^. entityPlural)] ++ ["orientation" .= (e ^. entityOrientation) | isJust (e ^. entityOrientation)] ++ ["growth" .= (e ^. entityGrowth) | isJust (e ^. entityGrowth)] @@ -689,7 +723,7 @@ counts :: IntMap (Count, Entity) , -- Mirrors the main map; just caching the ability to look up by -- name. - byName :: Map Text IntSet + byName :: MonoidMap Text IntSet , -- Cached hash of the inventory, using a homomorphic hashing scheme -- (see https://github.com/swarm-game/swarm/issues/229). -- @@ -722,7 +756,7 @@ -- positive, or just use 'countByName' in the first place. lookupByName :: Text -> Inventory -> [Entity] lookupByName name (Inventory cs byN _) = - maybe [] (map (snd . (cs IM.!)) . IS.elems) (M.lookup (T.toLower name) byN) + fmap snd . IM.elems . IM.restrictKeys cs $ MM.get (T.toLower name) byN -- | Look up an entity by name and see how many there are in the -- inventory. If there are multiple entities with the same name, it @@ -733,7 +767,7 @@ -- | The empty inventory. empty :: Inventory -empty = Inventory IM.empty M.empty 0 +empty = Inventory IM.empty MM.empty 0 -- | Create an inventory containing one entity. singleton :: Entity -> Inventory @@ -759,7 +793,7 @@ insertCount k e (Inventory cs byN h) = Inventory (IM.insertWith (\(m, _) (n, _) -> (m + n, e)) (e ^. entityHash) (k, e) cs) - (M.insertWith IS.union (T.toLower $ e ^. entityName) (IS.singleton (e ^. entityHash)) byN) + (MM.adjust (IS.insert (e ^. entityHash)) (T.toLower $ e ^. entityName) byN) (h + (k + extra) * (e ^. entityHash)) -- homomorphic hashing where -- Include the hash of an entity once just for "knowing about" it; @@ -849,7 +883,7 @@ union (Inventory cs1 byN1 h1) (Inventory cs2 byN2 h2) = Inventory (IM.unionWith (\(c1, e) (c2, _) -> (c1 + c2, e)) cs1 cs2) - (M.unionWith IS.union byN1 byN2) + (MM.union byN1 byN2) (h1 + h2 - common) where -- Need to subtract off the sum of the hashes in common, because diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs --- a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs +++ b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs @@ -4,8 +4,10 @@ -- Preserve color fidelity for non-TUI rendering module Swarm.Game.Entity.Cosmetic where -import Data.Colour.SRGB (RGB) +import Codec.Picture (PixelRGBA8 (..)) +import Data.Colour.SRGB (RGB (..)) import Data.Word (Word8) +import Swarm.Game.Scenario.Topography.Rasterize data NamedColor = White @@ -20,6 +22,27 @@ -- | 8-bit color type RGBColor = RGB Word8 +fromHiFi :: PreservableColor -> ColorLayers RGBColor +fromHiFi = fmap $ \case + Triple x -> x + -- The triples we've manually assigned for named + -- ANSI colors do not need to be round-tripped, since + -- those triples are not inputs to the VTY attribute creation. + AnsiColor x -> namedToTriple x + +-- | Since terminals can customize these named +-- colors using themes or explicit user overrides, +-- these color assignments are somewhat arbitrary. +namedToTriple :: NamedColor -> RGBColor +namedToTriple = \case + White -> RGB 208 207 204 + BrightRed -> RGB 246 97 81 + Red -> RGB 192 28 40 + Green -> RGB 38 162 105 + Blue -> RGB 18 72 139 + BrightYellow -> RGB 233 173 12 + Yellow -> RGB 162 115 76 + -- | High-fidelity color representation for rendering -- outside of the TUI. data TrueColor @@ -54,6 +77,11 @@ deriving (Show, Functor) type PreservableColor = ColorLayers TrueColor + +instance ToPixel PreservableColor where + toPixel h = PixelRGBA8 r g b 255 + where + RGB r g b = flattenBg $ fromHiFi h getBackground :: ColorLayers a -> Maybe a getBackground = \case diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs --- a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs +++ b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs @@ -41,6 +41,9 @@ ice :: (WorldAttr, PreservableColor) ice = (WorldAttr "ice", BgOnly $ AnsiColor White) +burnt :: (WorldAttr, PreservableColor) +burnt = (WorldAttr "burnt", BgOnly $ Triple $ RGB 40 24 0) -- dark brown + -- | Colors of entities in the world. worldAttributes :: Map WorldAttr PreservableColor worldAttributes = @@ -55,6 +58,7 @@ , grass , stone , ice + , burnt ] <> map (bimap WorldAttr FgOnly) diff --git a/src/swarm-scenario/Swarm/Game/Failure.hs b/src/swarm-scenario/Swarm/Game/Failure.hs deleted file mode 100644 --- a/src/swarm-scenario/Swarm/Game/Failure.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A data type to represent system failures (as distinct from robot --- program failures). --- --- These failures are often not fatal and serve --- to create common infrastructure for logging. -module Swarm.Game.Failure ( - SystemFailure (..), - simpleErrorHandle, - AssetData (..), - Asset (..), - Entry (..), - LoadingFailure (..), - OrderFileWarning (..), -) where - -import Control.Carrier.Throw.Either (ThrowC (..), runThrow) -import Control.Monad ((<=<)) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Text (Text) -import Data.Text qualified as T -import Data.Void -import Data.Yaml (ParseException, prettyPrintParseException) -import Prettyprinter (Pretty (pretty), nest, squotes, vcat, (<+>)) -import Swarm.Language.Pretty -import Swarm.Util (showLowT) -import Text.Megaparsec (ParseErrorBundle, errorBundlePretty) -import Witch (into) - ------------------------------------------------------------- --- Failure descriptions - --- | Enumeration of various assets we can attempt to load. -data AssetData = AppAsset | NameGeneration | Entities | Terrain | Recipes | Worlds | Scenarios | Script - deriving (Eq, Show) - --- | Overarching enumeration of various assets we can attempt to load. -data Asset = Achievement | Data AssetData | History | Keybindings | Save - deriving (Eq, Show) - --- | Enumeration type to distinguish between directories and files. -data Entry = Directory | File - deriving (Eq, Show) - --- | An error that occurred while attempting to load some kind of asset. -data LoadingFailure - = DoesNotExist Entry - | EntryNot Entry - | CanNotParseYaml ParseException - | CanNotParseMegaparsec (ParseErrorBundle Text Void) - | DoesNotTypecheck Text -- See Note [Typechecking errors] - | Duplicate AssetData Text - | CustomMessage Text - deriving (Show) - --- ~~~~ Note [Pretty-printing typechecking errors] --- --- It would make sense to store a CheckErr in DoesNotTypecheck; --- however, Swarm.Game.Failure is imported in lots of places, and --- CheckErr can contain high-level things like TTerms etc., so it --- would lead to an import cycle. Instead, we choose to just --- pretty-print typechecking errors before storing them here. - --- | A warning that arose while processing an @00-ORDER.txt@ file. -data OrderFileWarning - = NoOrderFile - | MissingFiles (NonEmpty FilePath) - | DanglingFiles (NonEmpty FilePath) - deriving (Eq, Show) - --- | An enumeration of various types of failures (errors or warnings) --- that can occur. -data SystemFailure - = AssetNotLoaded Asset FilePath LoadingFailure - | ScenarioNotFound FilePath - | OrderFileWarning FilePath OrderFileWarning - | CustomFailure Text - deriving (Show) - ------------------------------------------------------------- --- Basic error handling - -simpleErrorHandle :: ThrowC SystemFailure IO a -> IO a -simpleErrorHandle = either (fail . prettyString) pure <=< runThrow - ------------------------------------------------------------- --- Pretty-printing - -instance PrettyPrec AssetData where - prettyPrec _ = \case - NameGeneration -> "name generation data" - AppAsset -> "data assets" - d -> pretty (showLowT d) - -instance PrettyPrec Asset where - prettyPrec _ = \case - Data ad -> ppr ad - a -> pretty (showLowT a) - -instance PrettyPrec Entry where - prettyPrec _ = prettyShowLow - -instance PrettyPrec LoadingFailure where - prettyPrec _ = \case - DoesNotExist e -> "The" <+> ppr e <+> "is missing!" - EntryNot e -> "The entry is not a" <+> ppr e <> "!" - CanNotParseYaml p -> - nest 2 . vcat $ - "Parse failure:" - : map pretty (T.lines (into @Text (prettyPrintParseException p))) - CanNotParseMegaparsec p -> - nest 2 . vcat $ - "Parse failure:" - : map pretty (T.lines (into @Text (errorBundlePretty p))) - DoesNotTypecheck t -> - nest 2 . vcat $ - "Parse failure:" - : map pretty (T.lines t) - Duplicate thing duped -> "Duplicate" <+> ppr thing <> ":" <+> squotes (pretty duped) - CustomMessage m -> pretty m - -instance PrettyPrec OrderFileWarning where - prettyPrec _ = \case - NoOrderFile -> "File not found; using alphabetical order" - MissingFiles missing -> - ppr . BulletList "Files not listed will be ignored:" $ - map (into @Text) (NE.toList missing) - DanglingFiles dangling -> - ppr . BulletList "Some listed files do not exist:" $ - map (into @Text) (NE.toList dangling) - -instance PrettyPrec SystemFailure where - prettyPrec _ = \case - AssetNotLoaded a fp l -> - nest 2 . vcat $ - [ "Failed to acquire" <+> ppr a <+> "from path" <+> squotes (pretty fp) <> ":" - , ppr l - ] - ScenarioNotFound s -> "Scenario not found:" <+> pretty s - OrderFileWarning orderFile w -> - nest 2 . vcat $ - [ "Warning: while processing" <+> pretty orderFile <> ":" - , ppr w - ] - CustomFailure m -> pretty m diff --git a/src/swarm-scenario/Swarm/Game/Land.hs b/src/swarm-scenario/Swarm/Game/Land.hs --- a/src/swarm-scenario/Swarm/Game/Land.hs +++ b/src/swarm-scenario/Swarm/Game/Land.hs @@ -16,8 +16,8 @@ import Control.Effect.Throw (Throw) import Control.Lens (makeLenses) import GHC.Generics (Generic) +import Swarm.Failure (SystemFailure) import Swarm.Game.Entity -import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Terrain data TerrainEntityMaps = TerrainEntityMaps diff --git a/src/swarm-scenario/Swarm/Game/Recipe.hs b/src/swarm-scenario/Swarm/Game/Recipe.hs --- a/src/swarm-scenario/Swarm/Game/Recipe.hs +++ b/src/swarm-scenario/Swarm/Game/Recipe.hs @@ -59,22 +59,23 @@ import Control.Monad ((<=<)) import Data.Bifunctor (second) import Data.Either.Validation +import Data.Foldable (Foldable (..)) import Data.IntMap (IntMap) import Data.IntMap qualified as IM -import Data.List (foldl') import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Yaml import GHC.Generics (Generic) +import Swarm.Failure import Swarm.Game.Entity as E -import Swarm.Game.Failure import Swarm.Game.Ingredients -import Swarm.Game.ResourceLoading (getDataFileNameSafe) +import Swarm.ResourceLoading (getDataFileNameSafe) import Swarm.Util.Effect (withThrow) import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Util.Yaml import Witch +import Prelude hiding (Foldable (..)) -- | A recipe represents some kind of process where inputs are -- transformed into outputs. @@ -162,7 +163,7 @@ withThrow (AssetNotLoaded (Data Recipes) fileName . CanNotParseYaml) . (liftEither <=< sendIO) $ decodeFileEither @[Recipe Text] fileName - withThrow (AssetNotLoaded (Data Recipes) fileName . CustomMessage) + withThrow (AssetNotLoaded (Data Recipes) fileName . SystemFailure . CustomFailure) . liftEither . left (T.append "Unknown entities in recipe(s): " . T.intercalate ", ") . validationToEither diff --git a/src/swarm-scenario/Swarm/Game/Recipe/Graph.hs b/src/swarm-scenario/Swarm/Game/Recipe/Graph.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Recipe/Graph.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: calculate the graph of craftable entities +-- and their dependencies via recipes. +module Swarm.Game.Recipe.Graph ( + RecipeGraph (..), + classicScenarioRecipeGraph, + scenarioRecipeGraph, + ignoredEntities, +) where + +import Control.Lens (view, (^.)) +import Data.Map.Lazy (Map) +import Data.Map.Lazy qualified as Map +import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Tuple (swap) +import Swarm.Failure (simpleErrorHandle) +import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), EntityProperty (Pickable), entityProperties, entityYields) +import Swarm.Game.Entity qualified as E +import Swarm.Game.Land +import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs) +import Swarm.Game.Robot (TRobot, tequippedDevices, trobotInventory) +import Swarm.Game.Scenario +import Swarm.Game.Scenario.Topography.Cell (PCell (..)) +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Structure.Overlay (gridContent) +import Swarm.Game.Scenario.Topography.WorldDescription +import Swarm.Game.World.Gen (extractEntities) +import Swarm.Util (both) +import Swarm.Util.Erasable (erasableToMaybe) + +-- | Ignore utility entities that are just used for tutorials and challenges. +ignoredEntities :: Set Text +ignoredEntities = Set.fromList ["wall"] + +-- | A description of a recipe graph for a given scenario. +data RecipeGraph = RecipeGraph + { worldEntities :: Set Entity + -- ^ Entities available in the world + , startingDevices :: Set Entity + -- ^ Which devices the base starts with + , startingInventory :: Set Entity + -- ^ What inventory the base starts with + , levels :: [Set Entity] + -- ^ Recursively craftable entities, organized by distance from + -- starting inventory (i.e. number of crafting steps needed) + , allEntities :: Set Entity + -- ^ All known entities + , recipes :: [Recipe Entity] + -- ^ All known recipes + } + +baseRobotTemplate :: ScenarioLandscape -> Maybe TRobot +baseRobotTemplate = listToMaybe . view scenarioRobots + +-- | Load the recipe graph corresponding to the classic scenario. +classicScenarioRecipeGraph :: IO RecipeGraph +classicScenarioRecipeGraph = simpleErrorHandle $ do + (classic, gsi) <- loadStandaloneScenario "data/scenarios/classic.yaml" + pure $ scenarioRecipeGraph classic gsi + +scenarioRecipeGraph :: Scenario -> GameStateInputs -> RecipeGraph +scenarioRecipeGraph scenario (GameStateInputs (ScenarioInputs _ (TerrainEntityMaps _ emap)) recipeList) = + RecipeGraph + { startingDevices = devs + , startingInventory = inv + , worldEntities = ents + , levels = recipeLevels scenarioEMap recipeList (Set.unions [ents, devs, inv]) + , allEntities = Set.fromList . Map.elems $ entitiesByName scenarioEMap + , recipes = recipeList ++ (scenario ^. scenarioOperation . scenarioRecipes) + } + where + scenarioEMap = (scenario ^. scenarioLandscape . scenarioTerrainAndEntities . entityMap) <> emap + landscape = scenario ^. scenarioLandscape + baseRobot = baseRobotTemplate landscape + devs = maybe Set.empty robotStartingDevices baseRobot + inv = maybe Set.empty (Map.keysSet . robotStartingInventory) baseRobot + ents = landscapeEntities landscape + +-- | Get the set of all entities which can be harvested from the world. +landscapeEntities :: ScenarioLandscape -> Set Entity +landscapeEntities = foldMap harvestable . view scenarioWorlds + where + harvestable :: WorldDescription -> Set Entity + harvestable wd = Set.fromList (static wd) <> dynamic wd + where + static :: WorldDescription -> [Entity] + static = + filter (Set.member Pickable . view entityProperties) + . mapMaybe (erasableToMaybe . cellEntity) + . catMaybes + . allMembers + . gridContent + . area + + dynamic :: WorldDescription -> Set Entity + dynamic = maybe Set.empty extractEntities . worldProg + +------------------------------------------------------------------------------- +-- RECIPE LEVELS +------------------------------------------------------------------------------- + +-- | Order entities in sets depending on how soon it is possible to obtain them. +-- +-- So: +-- * Level 0 - starting entities (for example those obtainable in the world) +-- * Level N+1 - everything possible to make (or drill or harvest) from Level N +-- +-- This is almost a BFS, but the requirement is that the set of entities +-- required for recipe is subset of the entities known in Level N. +-- +-- If we ever depend on some graph library, this could be rewritten +-- as some BFS-like algorithm with added recipe nodes, but you would +-- need to enforce the condition that recipes need ALL incoming edges. +recipeLevels :: EntityMap -> [Recipe Entity] -> Set Entity -> [Set Entity] +recipeLevels emap recipeList start = levs + where + recipeParts r = ((r ^. recipeInputs) <> (r ^. recipeCatalysts), r ^. recipeOutputs) + m :: [(Set Entity, Set Entity)] + m = map (both (Set.fromList . map snd) . recipeParts) recipeList + levs :: [Set Entity] + levs = reverse $ go [start] start + where + isKnown known (i, _o) = null $ i Set.\\ known + lookupYield e = case view entityYields e of + Nothing -> e + Just yn -> fromMaybe e (E.lookupEntityName yn emap) + yielded = Set.map lookupYield + nextLevel known = Set.unions $ yielded known : map snd (filter (isKnown known) m) + go ls known = + let n = nextLevel known Set.\\ known + in if null n + then ls + else go (n : ls) (Set.union n known) + +robotStartingDevices :: TRobot -> Set Entity +robotStartingDevices = Set.fromList . map snd . E.elems . view tequippedDevices + +robotStartingInventory :: TRobot -> Map Entity Int +robotStartingInventory = Map.fromList . map swap . E.elems . view trobotInventory diff --git a/src/swarm-scenario/Swarm/Game/ResourceLoading.hs b/src/swarm-scenario/Swarm/Game/ResourceLoading.hs deleted file mode 100644 --- a/src/swarm-scenario/Swarm/Game/ResourceLoading.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- Description: Fetching game data --- --- Various utilities related to loading game data files. -module Swarm.Game.ResourceLoading ( - -- * Generic data access - getDataDirSafe, - getDataFileNameSafe, - - -- * Concrete data access - getSwarmConfigIniFile, - getSwarmSavePath, - getSwarmHistoryPath, - getSwarmAchievementsPath, - - -- ** Loading text files - readAppData, - NameGenerator (..), - initNameGenerator, -) where - -import Control.Algebra (Has) -import Control.Effect.Lift (Lift, sendIO) -import Control.Effect.Throw (Throw, liftEither, throwError) -import Control.Exception (catch) -import Control.Exception.Base (IOException) -import Control.Monad (forM, when, (<=<)) -import Data.Array (Array, listArray) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Paths_swarm (getDataDir) -import Swarm.Game.Failure -import Swarm.Util -import System.Directory ( - XdgDirectory (..), - createDirectoryIfMissing, - doesDirectoryExist, - doesFileExist, - getXdgDirectory, - listDirectory, - ) -import System.FilePath -import Witch - --- | Read-only lists of adjectives and words for use in building random robot names -data NameGenerator = NameGenerator - { adjList :: Array Int Text - , nameList :: Array Int Text - } - --- | Get subdirectory from swarm data directory. --- --- This will first look in Cabal generated path and then --- try a @data@ directory in 'XdgData' path. --- --- The idea is that when installing with Cabal/Stack the first --- is preferred, but when the players install a binary they --- need to extract the `data` archive to the XDG directory. -getDataDirSafe :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - AssetData -> - FilePath -> - m FilePath -getDataDirSafe asset p = do - d <- (`appDir` p) <$> sendIO getDataDir - de <- sendIO $ doesDirectoryExist d - if de - then return d - else do - xd <- (`appDir` p) <$> sendIO (getSwarmXdgDataSubdir False "data") - xde <- sendIO $ doesDirectoryExist xd - if xde then return xd else throwError $ AssetNotLoaded (Data asset) xd $ DoesNotExist Directory - where - appDir r = \case - "" -> r - "." -> r - d -> r d - --- | Get file from swarm data directory. --- --- See the note in 'getDataDirSafe'. -getDataFileNameSafe :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - AssetData -> - FilePath -> - m FilePath -getDataFileNameSafe asset name = do - d <- getDataDirSafe asset "." - let fp = d name - fe <- sendIO $ doesFileExist fp - if fe - then return fp - else throwError $ AssetNotLoaded (Data asset) fp $ DoesNotExist File - -getSwarmConfigIniFile :: Bool -> IO (Bool, FilePath) -getSwarmConfigIniFile createDirs = do - swarmConfig <- getXdgDirectory XdgConfig "swarm" - when createDirs (createDirectoryIfMissing True swarmConfig) - let ini = swarmConfig "config.ini" - iniExists <- doesFileExist ini - return (iniExists, ini) - --- | Get path to swarm data, optionally creating necessary --- directories. This could fail if user has bad permissions --- on his own @$HOME@ or @$XDG_DATA_HOME@ which is unlikely. -getSwarmXdgDataSubdir :: Bool -> FilePath -> IO FilePath -getSwarmXdgDataSubdir createDirs subDir = do - swarmData <- ( subDir) <$> getXdgDirectory XdgData "swarm" - when createDirs (createDirectoryIfMissing True swarmData) - pure swarmData - -getSwarmXdgDataFile :: Bool -> FilePath -> IO FilePath -getSwarmXdgDataFile createDirs filepath = do - let (subDir, file) = splitFileName filepath - d <- getSwarmXdgDataSubdir createDirs subDir - return $ d file - --- | Get path to swarm saves, optionally creating necessary --- directories. -getSwarmSavePath :: Bool -> IO FilePath -getSwarmSavePath createDirs = getSwarmXdgDataSubdir createDirs "saves" - --- | Get path to swarm history, optionally creating necessary --- directories. -getSwarmHistoryPath :: Bool -> IO FilePath -getSwarmHistoryPath createDirs = getSwarmXdgDataFile createDirs "history" - --- | Get a path to the directory where achievement records are --- stored. If the argument is set to @True@, create the directory if --- it does not exist. -getSwarmAchievementsPath :: Bool -> IO FilePath -getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement" - --- | Read all the @.txt@ files in the @data/@ directory. -readAppData :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - m (Map Text Text) -readAppData = do - d <- getDataDirSafe AppAsset "." - dirMembers :: [FilePath] <- - (liftEither <=< sendIO) $ - (pure <$> listDirectory d) `catch` \(e :: IOException) -> - return . Left . AssetNotLoaded (Data AppAsset) d . CustomMessage . T.pack $ show e - let fs = filter ((== ".txt") . takeExtension) dirMembers - - filesList <- sendIO $ forM fs (\f -> (into @Text (dropExtension f),) <$> readFileMayT (d f)) - return $ M.fromList . mapMaybe sequenceA $ filesList - -initNameGenerator :: Has (Throw SystemFailure) sig m => Map Text Text -> m NameGenerator -initNameGenerator appDataMap = do - adjs <- getDataLines "adjectives" - names <- getDataLines "names" - return $ - NameGenerator - { adjList = makeArr adjs - , nameList = makeArr names - } - where - makeArr xs = listArray (0, length xs - 1) xs - getDataLines f = case M.lookup f appDataMap of - Nothing -> - throwError $ - AssetNotLoaded (Data NameGeneration) (into @FilePath f <.> "txt") (DoesNotExist File) - Just content -> return . drop 1 . T.lines $ content diff --git a/src/swarm-scenario/Swarm/Game/Robot.hs b/src/swarm-scenario/Swarm/Game/Robot.hs --- a/src/swarm-scenario/Swarm/Game/Robot.hs +++ b/src/swarm-scenario/Swarm/Game/Robot.hs @@ -42,7 +42,9 @@ trobotLocation, robotOrientation, robotInventory, + trobotInventory, equippedDevices, + tequippedDevices, inventoryHash, robotCapabilities, walkabilityContext, @@ -58,6 +60,7 @@ -- ** Query robotKnows, + isInteractive, -- ** Constants hearingDistance, @@ -238,6 +241,10 @@ robotInventory :: Lens' Robot Inventory robotInventory = robotEntity . entityInventory +-- | A robot template's inventory. +trobotInventory :: Lens' TRobot Inventory +trobotInventory = robotEntity . entityInventory + -- | The (unique) ID number of the robot. This is only a Getter since -- the robot ID is immutable. robotID :: Getter Robot RID @@ -266,6 +273,10 @@ , _robotCapabilities = inventoryCapabilities inst } +-- | A robot template's equipped devices. +tequippedDevices :: Getter TRobot Inventory +tequippedDevices = to _equippedDevices + -- | A hash of a robot's entity record and equipped devices, to -- facilitate quickly deciding whether we need to redraw the robot -- info panel. @@ -275,6 +286,9 @@ -- | Does a robot know of an entity's existence? robotKnows :: Robot -> Entity -> Bool robotKnows r e = contains0plus e (r ^. robotInventory) || contains0plus e (r ^. equippedDevices) + +isInteractive :: Robot -> Bool +isInteractive r = not $ r ^. robotDisplay . invisible && r ^. systemRobot -- | Get the set of capabilities this robot possesses. This is only a -- getter, not a lens, because it is automatically generated from diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -13,21 +13,12 @@ -- conditions, which can be used both for building interactive -- tutorials and for standalone puzzles and scenarios. module Swarm.Game.Scenario ( - -- * WorldDescription - PCell (..), - Cell, - PWorldDescription (..), - WorldDescription, - IndexedTRobot, - StructureCells, - -- * Scenario Scenario (..), ScenarioLandscape (..), - StaticStructureInfo (..), ScenarioMetadata (ScenarioMetadata), + RecognizableStructureContent, staticPlacements, - structureDefs, -- ** Fields scenarioMetadata, @@ -82,36 +73,39 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) +import Swarm.Failure import Swarm.Game.Entity import Swarm.Game.Entity.Cosmetic import Swarm.Game.Entity.Cosmetic.Assignment (worldAttributes) -import Swarm.Game.Failure import Swarm.Game.Land import Swarm.Game.Location (Location) import Swarm.Game.Recipe -import Swarm.Game.ResourceLoading (getDataFileNameSafe) import Swarm.Game.Robot (TRobot, trobotLocation, trobotName) import Swarm.Game.Scenario.Objective (Objective) import Swarm.Game.Scenario.Objective.Validation import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Style import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Navigation.Portal import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..)) import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly +import Swarm.Game.Scenario.Topography.Structure.Named qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Overlay -import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..)) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute +import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry (renderRedundancy) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.Terrain import Swarm.Game.Universe import Swarm.Game.World.Gen (Seed) import Swarm.Game.World.Load (loadWorlds) import Swarm.Game.World.Typecheck (WorldMap) -import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax (Syntax, TSyntax) import Swarm.Language.Text.Markdown (Document) +import Swarm.Pretty (prettyText) +import Swarm.ResourceLoading (getDataFileNameSafe) import Swarm.Util (binTuples, commaList, failT, quote) import Swarm.Util.Effect (ignoreWarnings, throwToMaybe, withThrow) import Swarm.Util.Lens (makeLensesNoSigs) @@ -120,24 +114,6 @@ import System.FilePath ((<.>), ()) import System.Random (randomRIO) -type StructureCells = Structure.NamedGrid (Maybe Cell) - -data StaticStructureInfo = StaticStructureInfo - { _structureDefs :: [SymmetryAnnotatedGrid StructureCells] - , _staticPlacements :: M.Map SubworldName [Structure.LocatedStructure] - } - deriving (Show) - -makeLensesNoSigs ''StaticStructureInfo - --- | Structure templates that may be auto-recognized when constructed --- by a robot -structureDefs :: Lens' StaticStructureInfo [SymmetryAnnotatedGrid StructureCells] - --- | A record of the static placements of structures, so that they can be --- added to the "recognized" list upon scenario initialization -staticPlacements :: Lens' StaticStructureInfo (M.Map SubworldName [Structure.LocatedStructure]) - -- * Scenario records -- | Authorship information about scenario not used at play-time @@ -207,6 +183,8 @@ -- take during a single tick. scenarioStepsPerTick :: Lens' ScenarioOperation (Maybe Int) +type RecognizableStructureContent = NonEmptyGrid (Maybe Cell) + -- | All cosmetic and structural content of the scenario. data ScenarioLandscape = ScenarioLandscape { _scenarioSeed :: Maybe Int @@ -216,10 +194,9 @@ , _scenarioKnown :: Set EntityName , _scenarioWorlds :: NonEmpty WorldDescription , _scenarioNavigation :: Navigation (M.Map SubworldName) Location - , _scenarioStructures :: StaticStructureInfo + , _scenarioStructures :: StaticStructureInfo RecognizableStructureContent Entity , _scenarioRobots :: [TRobot] } - deriving (Show) makeLensesNoSigs ''ScenarioLandscape @@ -246,7 +223,7 @@ scenarioWorlds :: Lens' ScenarioLandscape (NonEmpty WorldDescription) -- | Information required for structure recognition -scenarioStructures :: Lens' ScenarioLandscape StaticStructureInfo +scenarioStructures :: Lens' ScenarioLandscape (StaticStructureInfo RecognizableStructureContent Entity) -- | Waypoints and inter-world portals scenarioNavigation :: Lens' ScenarioLandscape (Navigation (M.Map SubworldName) Location) @@ -262,7 +239,6 @@ , _scenarioOperation :: ScenarioOperation , _scenarioLandscape :: ScenarioLandscape } - deriving (Show) makeLensesNoSigs ''Scenario @@ -292,12 +268,10 @@ validatedTerrainObjects <- runValidation $ validateTerrainAttrRefs attrsUnion tmRaw - let tm = mkTerrainMap validatedTerrainObjects - runValidation $ validateEntityAttrRefs attrsUnion emRaw em <- runValidation $ buildEntityMap emRaw - + let tm = mkTerrainMap validatedTerrainObjects let scenarioSpecificTerrainEntities = TerrainEntityMaps tm em -- Save the passed in WorldMap for later @@ -312,9 +286,8 @@ combinedTEM <- getE let TerrainEntityMaps _tm emCombined = combinedTEM - case filter (isNothing . (`lookupEntityName` emCombined)) known of - [] -> return () - unk -> failT ["Unknown entities in 'known' list:", T.intercalate ", " unk] + forM_ (NE.nonEmpty $ filter (isNothing . (`lookupEntityName` emCombined)) known) $ \unk -> + failT ["Unknown entities in 'known' list:", T.intercalate ", " $ NE.toList unk] -- parse robots and build RobotMap rs <- v ..: "robots" @@ -333,14 +306,13 @@ -- -- We should also make use of such a pre-computed map in the -- invocation of 'mergeStructures' inside WorldDescription.hs. + let structureMap = Assembly.makeStructureMap rootLevelSharedStructures mergedStructures <- either (fail . T.unpack) return $ mapM - (sequenceA . (id &&& (Assembly.mergeStructures mempty Root . Structure.structure))) + (sequenceA . (id &&& (Assembly.mergeStructures structureMap Root . Structure.structure))) rootLevelSharedStructures - let namedGrids = map (\(ns, Structure.MergedStructure (PositionedGrid _ s) _ _) -> s <$ ns) mergedStructures - allWorlds <- localE (WorldParseDependencies worldMap rootLevelSharedStructures rsMap) $ do rootWorld <- v ..: "world" subworlds <- v ..:? "subworlds" ..!= [] @@ -379,12 +351,20 @@ $ NE.toList allWorlds let mergedNavigation = Navigation mergedWaypoints mergedPortals + + stuffGrid (ns, Structure.MergedStructure (PositionedGrid _ s) _ _) = s <$ ns + namedGrids = map stuffGrid mergedStructures recognizableGrids = filter Structure.isRecognizable namedGrids - symmetryAnnotatedGrids <- mapM checkSymmetry recognizableGrids + -- We exclude empty grids from the recognition engine. + nonEmptyRecognizableGrids = mapMaybe (traverse getNonEmptyGrid) recognizableGrids + myAutomatons <- + either (fail . T.unpack . renderRedundancy) return $ + mkAutomatons (fmap cellToEntity) nonEmptyRecognizableGrids + let structureInfo = - StaticStructureInfo symmetryAnnotatedGrids + StaticStructureInfo myAutomatons . M.fromList . NE.toList $ NE.map (worldName &&& placedStructures) allWorlds @@ -460,6 +440,11 @@ where adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml +-- | Load a single scenario from disk, first loading needed entity + +-- recipe data. This function should only be called in the case of +-- "peripheral" tools that need to load a scenario (for example, +-- documentation generation, scenario world rendering, etc.), not as +-- part of the normal game code path. loadStandaloneScenario :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => FilePath -> diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs --- a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs @@ -11,7 +11,7 @@ import Data.Aeson import Data.BoolExpr (Signed (Positive)) import Data.BoolExpr qualified as BE -import Data.Graph (Graph, SCC (AcyclicSCC), graphFromEdges, stronglyConnComp) +import Data.Graph (Graph, SCC, graphFromEdges, stronglyConnComp) import Data.Map (Map) import Data.Map.Strict qualified as M import Data.Maybe (mapMaybe) @@ -24,6 +24,7 @@ import Servant.Docs qualified as SD import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Logic as L +import Swarm.Util.Graph (isAcyclicGraph) -- | This is only needed for constructing a Graph, -- which requires all nodes to have a key. @@ -53,11 +54,6 @@ deriving instance Generic (BE.Signed ObjectiveLabel) deriving instance ToJSON (BE.Signed ObjectiveLabel) -getConstFromSigned :: BE.Signed a -> a -getConstFromSigned = \case - BE.Positive x -> x - BE.Negative x -> x - getDistinctConstants :: (Ord a) => Prerequisite a -> Set (BE.Signed a) getDistinctConstants = Set.fromList . BE.constants . toBoolExpr @@ -137,14 +133,6 @@ f (k, v) = (v, k, maybe [] (map Label . g) $ v ^. objectivePrerequisite) g = Set.toList . getDistinctConstants . logic - -isAcyclicGraph :: [SCC Objective] -> Bool -isAcyclicGraph = - all isAcyclicVertex - where - isAcyclicVertex = \case - AcyclicSCC _ -> True - _ -> False makeGraphInfo :: ObjectiveCompletion -> GraphInfo makeGraphInfo oc = diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs --- a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs @@ -7,15 +7,15 @@ module Swarm.Game.Scenario.Objective.Validation where import Control.Lens (view, (^.)) -import Control.Monad (unless) +import Control.Monad (forM_, unless) import Data.Foldable (for_, toList) -import Data.Graph (stronglyConnComp) -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Set qualified as Set import Data.Text qualified as T import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph import Swarm.Util (failT, quote) +import Swarm.Util.Graph -- | Performs monadic validation before returning -- the "pure" construction of a wrapper record. @@ -29,24 +29,21 @@ [Objective] -> m [Objective] validateObjectives objectives = do - for_ objectives $ \x -> case x ^. objectivePrerequisite of - Just p -> - unless (null remaining) $ - failT - [ "Reference to undefined objective(s)" - , T.intercalate ", " (map quote $ Set.toList remaining) <> "." - , "Defined are:" - , T.intercalate ", " (map quote $ Set.toList allIds) - ] - where - refs = Set.fromList $ toList $ logic p - remaining = Set.difference refs allIds - Nothing -> return () + for_ objectives $ \x -> forM_ (x ^. objectivePrerequisite) $ \p -> + let refs = Set.fromList $ toList $ logic p + remaining = Set.difference refs allIds + in unless (null remaining) $ + failT + [ "Reference to undefined objective(s)" + , T.intercalate ", " (map quote $ Set.toList remaining) <> "." + , "Defined are:" + , T.intercalate ", " (map quote $ Set.toList allIds) + ] - unless (isAcyclicGraph connectedComponents) $ - failT ["There are dependency cycles in the prerequisites."] + either (fail . T.unpack) return $ + failOnCyclicGraph "Prerequisites" (fromMaybe "N/A" . view objectiveId) edges return objectives where - connectedComponents = stronglyConnComp $ makeGraphEdges objectives + edges = makeGraphEdges objectives allIds = Set.fromList $ mapMaybe (view objectiveId) objectives diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Style.hs b/src/swarm-scenario/Swarm/Game/Scenario/Style.hs --- a/src/swarm-scenario/Swarm/Game/Scenario/Style.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Style.hs @@ -1,17 +1,21 @@ +{-# LANGUAGE ViewPatterns #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause -- -- Types for styling custom entity attributes module Swarm.Game.Scenario.Style where +import Codec.Picture (PixelRGBA8 (..)) import Data.Aeson -import Data.Colour.Palette.BrewerSet (Kolor) -import Data.Colour.SRGB (sRGB24read, toSRGB24) +import Data.Colour.Palette.Types (Kolor) +import Data.Colour.SRGB (RGB (..), sRGB24reads, sRGB24show, toSRGB24) +import Data.Colour.SRGB.Linear (toRGB) import Data.Set (Set) -import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) import Swarm.Game.Entity.Cosmetic +import Swarm.Game.Scenario.Topography.Rasterize data StyleFlag = Standout @@ -36,11 +40,37 @@ instance ToJSON StyleFlag where toJSON = genericToJSON styleFlagJsonOptions --- | Hexadecimal color notation. --- May include a leading hash symbol (see 'Data.Colour.SRGB.sRGB24read'). -newtype HexColor = HexColor Text - deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) +-- | A color, parsed from hexadecimal notation. May include a leading +-- hash symbol (see 'Data.Colour.SRGB.sRGB24read'). +newtype HexColor = HexColor {getHexColor :: Kolor} + deriving (Eq, Show, Generic) +instance Ord HexColor where + -- There is no Ord instance for Colour a, but we need one to use + -- with OccurrenceEncoder, so we make our own. + -- + -- We use toRGB here since it does no conversions whatsoever, it + -- simply unpacks the raw color data into an RGB triple. For the + -- purposes of an Ord instance, it doesn't matter: we just want a + -- consistent way to put a total ordering on colors as fast as + -- possible. + compare (HexColor (toRGB -> RGB r1 g1 b1)) (HexColor (toRGB -> RGB r2 g2 b2)) = + compare (r1, g1, b1) (r2, g2, b2) + +instance FromJSON HexColor where + parseJSON = withText "hex color" $ \t -> + case sRGB24reads (T.unpack t) of + ((c, _) : _) -> pure $ HexColor c + _ -> fail $ "Could not parse hex color '" ++ T.unpack t ++ "'" + +instance ToJSON HexColor where + toJSON = toJSON . T.pack . sRGB24show . getHexColor + +instance ToPixel HexColor where + toPixel (HexColor kolor) = PixelRGBA8 r g b 255 + where + RGB r g b = toSRGB24 kolor + data CustomAttr = CustomAttr { name :: String , fg :: Maybe HexColor @@ -68,7 +98,4 @@ (Nothing, Just b) -> Just $ BgOnly b (Nothing, Nothing) -> Nothing - conv (HexColor x) = Triple $ toSRGB24 kolor - where - kolor :: Kolor - kolor = sRGB24read $ T.unpack x + conv (HexColor kolor) = Triple $ toSRGB24 kolor diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs @@ -8,6 +8,7 @@ Cell, AugmentedCell, CellPaintDisplay, + cellToEntity, ) where import Control.Lens hiding (from, (.=), (<.>)) @@ -23,10 +24,10 @@ import Swarm.Game.Land import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.ProtoCell +import Swarm.Game.Scenario.Topography.ProtoCell hiding (name) import Swarm.Game.Terrain import Swarm.Util (quote, showT) -import Swarm.Util.Erasable (Erasable (..)) +import Swarm.Util.Erasable (Erasable (..), erasableToMaybe) import Swarm.Util.Yaml ------------------------------------------------------------ @@ -106,6 +107,9 @@ robs <- mapMaybeM name2rob (drop 2 tupRaw) return $ Cell terr ent robs + +cellToEntity :: Maybe Cell -> Maybe Entity +cellToEntity = ((erasableToMaybe . cellEntity) =<<) ------------------------------------------------------------ -- World editor diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs @@ -28,6 +28,7 @@ import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M +import Data.Map.NonEmpty qualified as NEM import Data.Maybe (fromMaybe, listToMaybe) import Data.Text qualified as T import Data.Tuple (swap) @@ -37,7 +38,7 @@ import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Universe import Swarm.Language.Syntax.Direction -import Swarm.Util (allEqual, binTuples, both, failT, quote, showT) +import Swarm.Util (allEqual, binTuples, both, commaList, failT, quote, showT) type WaypointMap = M.Map WaypointName (NonEmpty Location) @@ -46,7 +47,7 @@ , reorientation :: Direction , destination :: Cosmic a } - deriving (Show, Eq) + deriving (Show, Eq, Generic, ToJSON) -- | Parameterized on waypoint dimensionality ('additionalDimension') and -- on the portal location specification method ('portalExitLoc'). @@ -71,6 +72,7 @@ -- coordinates (as with applying the "ul" offset). , portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc) } + deriving (Generic) deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b) deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b) @@ -179,7 +181,7 @@ correctedWaypoints = binTuples $ map - (\x -> (wpName $ wpConfig $ value x, fmap (offsetLoc $ upperLeft .-. origin) x)) + (\x -> (wpName $ wpConfig $ value x, fmap (offsetLoc $ asVector upperLeft) x)) unmergedWaypoints bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints @@ -238,12 +240,28 @@ [(Cosmic Location, AnnotatedDestination Location)] -> m () ensureSpatialConsistency xs = - unless (null nonUniform) $ + forM_ (NEM.nonEmptyMap nonUniform) $ \nonUniformMap -> failT [ "Non-uniform portal distances:" - , showT nonUniform + , renderNonUniformPairs nonUniformMap ] where + renderNonUniformPairs nem = + commaList $ NE.toList $ renderPair <$> NEM.toList nem + where + renderPair (k, v) = + T.unwords + [ renderKey k <> ":" + , commaList $ NE.toList $ showT <$> v + ] + renderKey (sw1, sw2) = + T.unwords + [ "Between subworlds" + , renderQuotedWorldName sw1 + , "and" + , renderQuotedWorldName sw2 + ] + consistentPairs :: [(Cosmic Location, Cosmic Location)] consistentPairs = map (fmap destination) $ filter (enforceConsistency . snd) xs diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs deleted file mode 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs +++ /dev/null @@ -1,115 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Precomputation for structure recognizer. --- --- = Search process overview --- --- 2D structures may be defined at the --- . --- Upon scenario load, all of the predefined structures that are marked --- as @"recognize"@ are compiled into searcher state machines. --- --- When an entity is placed on any cell in the world, the --- 'Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking.entityModified' --- function is called, which looks up a customized searcher based --- on the type of placed entity. --- --- The first searching stage looks for any member row of all participating --- structure definitions that contains the placed entity. --- The value returned by the searcher is a second-stage searcher state machine, --- which this time searches for complete structures of which the found row may --- be a member. --- --- Both the first stage and second stage searcher know to start the search --- at a certain offset horizontally or vertically from the placed entity, --- based on where within a structure that entity (or row) may occur. --- --- Upon locating a complete structure, it is added to a registry --- (see 'Swarm.Game.Scenario.Topography.Structure.Recognition.Registry.FoundRegistry'), which --- supports lookups by either name or by location (using two different --- maps maintained in parallel). The map by location is used to remove --- a structure from the registry if a member entity is changed. -module Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute ( - -- * Main external interface - mkAutomatons, - - -- * Helper functions - populateStaticFoundStructures, - getEntityGrid, - lookupStaticPlacements, -) where - -import Control.Arrow ((&&&)) -import Data.Map qualified as M -import Data.Maybe (catMaybes, mapMaybe) -import Data.Set qualified as Set -import Swarm.Game.Entity (Entity) -import Swarm.Game.Scenario (StaticStructureInfo (..), StructureCells) -import Swarm.Game.Scenario.Topography.Cell (cellEntity) -import Swarm.Game.Scenario.Topography.Grid (getRows) -import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform, getStructureName) -import Swarm.Game.Scenario.Topography.Structure -import Swarm.Game.Scenario.Topography.Structure qualified as Structure -import Swarm.Game.Scenario.Topography.Structure.Recognition.Prep -import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -import Swarm.Game.Universe (Cosmic (..)) -import Swarm.Language.Syntax.Direction (AbsoluteDir) -import Swarm.Util (histogram) -import Swarm.Util.Erasable (erasableToMaybe) - -getEntityGrid :: StructureCells -> [SymbolSequence Entity] -getEntityGrid = getRows . fmap ((erasableToMaybe . cellEntity) =<<) . structure - --- | Create Aho-Corasick matchers that will recognize all of the --- provided structure definitions -mkAutomatons :: - [SymmetryAnnotatedGrid StructureCells] -> - RecognizerAutomatons StructureCells Entity -mkAutomatons xs = - RecognizerAutomatons - infos - (mkEntityLookup rotatedGrids) - where - rotatedGrids = concatMap (extractGrids . namedGrid) xs - - process g = StructureInfo g entGrid countsMap - where - entGrid = getEntityGrid $ namedGrid g - countsMap = histogram $ concatMap catMaybes entGrid - - infos = - M.fromList $ - map (getStructureName . Structure.name . namedGrid &&& process) xs - -extractOrientedGrid :: - StructureCells -> - AbsoluteDir -> - StructureWithGrid StructureCells Entity -extractOrientedGrid x d = - StructureWithGrid wrapped d $ getEntityGrid g - where - wrapped = NamedOriginal (getStructureName $ Structure.name x) x - g = applyOrientationTransform (Orientation d False) <$> x - --- | At this point, we have already ensured that orientations --- redundant by rotational symmetry have been excluded --- (i.e. at Scenario validation time). -extractGrids :: StructureCells -> [StructureWithGrid StructureCells Entity] -extractGrids x = map (extractOrientedGrid x) $ Set.toList $ recognize x - --- | The output list of 'FoundStructure' records is not yet --- vetted; the 'ensureStructureIntact' function will subsequently --- filter this list. -lookupStaticPlacements :: StaticStructureInfo -> [FoundStructure StructureCells Entity] -lookupStaticPlacements (StaticStructureInfo structDefs thePlacements) = - concatMap f $ M.toList thePlacements - where - definitionMap = M.fromList $ map ((Structure.name &&& id) . namedGrid) structDefs - - f (subworldName, locatedList) = mapMaybe g locatedList - where - g (LocatedStructure theName d loc) = do - sGrid <- M.lookup theName definitionMap - return $ FoundStructure (extractOrientedGrid sGrid d) $ Cosmic subworldName loc diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -14,34 +14,36 @@ import Data.Functor.Identity import Data.Text qualified as T import Data.Yaml as Y -import Swarm.Game.Entity +import Swarm.Game.Entity (Entity) import Swarm.Game.Land import Swarm.Game.Location -import Swarm.Game.Scenario.RobotLookup +import Swarm.Game.Scenario.RobotLookup (RobotMap) import Swarm.Game.Scenario.Topography.Cell -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.Grid (Grid (EmptyGrid)) +import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade) import Swarm.Game.Scenario.Topography.Navigation.Portal import Swarm.Game.Scenario.Topography.Navigation.Waypoint ( Parentage (Root), WaypointName, ) -import Swarm.Game.Scenario.Topography.ProtoCell +import Swarm.Game.Scenario.Topography.ProtoCell ( + StructurePalette (StructurePalette), + ) import Swarm.Game.Scenario.Topography.Structure ( - LocatedStructure, MergedStructure (MergedStructure), NamedStructure, - PStructure (Structure), - paintMap, + parseStructure, ) import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly -import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.Structure.Overlay ( + PositionedGrid (..), + ) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Static (LocatedStructure) import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Game.Universe +import Swarm.Game.Universe (SubworldName (DefaultRootSubworld)) import Swarm.Game.World.Parse () import Swarm.Game.World.Syntax import Swarm.Game.World.Typecheck -import Swarm.Language.Pretty (prettyString) +import Swarm.Pretty (prettyString) import Swarm.Util.Yaml ------------------------------------------------------------ @@ -52,13 +54,13 @@ -- This type is parameterized to accommodate Cells that -- utilize a less stateful Entity type. data PWorldDescription e = WorldDescription - { offsetOrigin :: Bool - , scrollable :: Bool + { scrollable :: Bool , palette :: WorldPalette e - , ul :: Location , area :: PositionedGrid (Maybe (PCell e)) , navigation :: Navigation Identity WaypointName , placedStructures :: [LocatedStructure] + -- ^ statically-placed structures to pre-populate + -- the structure recognizer , worldName :: SubworldName , worldProg :: Maybe (TTerm '[] (World CellVal)) } @@ -76,25 +78,6 @@ -- | last for the benefit of partial application TerrainEntityMaps -integrateArea :: - WorldPalette e -> - [NamedStructure (Maybe (PCell e))] -> - Object -> - Parser (MergedStructure (Maybe (PCell e))) -integrateArea palette initialStructureDefs v = do - placementDefs <- v .:? "placements" .!= [] - waypointDefs <- v .:? "waypoints" .!= [] - rawMap <- v .:? "map" .!= EmptyGrid - (initialArea, mapWaypoints) <- paintMap Nothing palette rawMap - let unflattenedStructure = - Structure - (PositionedGrid origin initialArea) - initialStructureDefs - placementDefs - (waypointDefs <> mapWaypoints) - either (fail . T.unpack) return $ - Assembly.mergeStructures mempty Root unflattenedStructure - instance FromJSONE WorldParseDependencies WorldDescription where parseJSONE = withObjectE "world description" $ \v -> do WorldParseDependencies worldMap scenarioLevelStructureDefs rm tem <- getE @@ -107,33 +90,44 @@ withDeps $ v ..:? "structures" ..!= [] - let structureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs - MergedStructure area staticStructurePlacements unmergedWaypoints <- - liftE $ integrateArea palette structureDefs v + let initialStructureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs + liftE $ mkWorld tem worldMap palette initialStructureDefs v + where + mkWorld tem worldMap palette initialStructureDefs v = do + MergedStructure mergedGrid staticStructurePlacements unmergedWaypoints <- do + unflattenedStructure <- parseStructure palette initialStructureDefs v - worldName <- liftE $ v .:? "name" .!= DefaultRootSubworld - ul <- liftE $ v .:? "upperleft" .!= origin - portalDefs <- liftE $ v .:? "portals" .!= [] - navigation <- - validatePartialNavigation - worldName - ul - unmergedWaypoints - portalDefs + -- NOTE: In contrast with the 'Swarm.Game.Scenario' module, + -- we do not need to pass in a structure map here, + -- because all the structure definitions we need are at this + -- point already stored inside the "Structure" object. + either (fail . T.unpack) return $ + Assembly.mergeStructures mempty Root unflattenedStructure - mwexp <- liftE $ v .:? "dsl" - worldProg <- forM mwexp $ \wexp -> do - let checkResult = - run . runThrow @CheckErr . runReader worldMap . runReader tem $ - check CNil (TTyWorld TTyCell) wexp - either (fail . prettyString) return checkResult + worldName <- v .:? "name" .!= DefaultRootSubworld + ul <- v .:? "upperleft" .!= origin + portalDefs <- v .:? "portals" .!= [] + navigation <- + validatePartialNavigation + worldName + ul + unmergedWaypoints + portalDefs - offsetOrigin <- liftE $ v .:? "offset" .!= False - scrollable <- liftE $ v .:? "scrollable" .!= True - let placedStructures = - map (offsetLoc $ coerce ul) staticStructurePlacements - return $ WorldDescription {..} + mwexp <- v .:? "dsl" + worldProg <- forM mwexp $ \wexp -> do + let checkResult = + run . runThrow @CheckErr . runReader worldMap . runReader tem $ + check CNil (TTyWorld TTyCell) wexp + either (fail . prettyString) return checkResult + scrollable <- v .:? "scrollable" .!= True + let placedStructures = + map (offsetLoc $ coerce ul) staticStructurePlacements + + let area = modifyLoc ((ul .+^) . asVector) mergedGrid + return $ WorldDescription {..} + ------------------------------------------------------------ -- World editor ------------------------------------------------------------ @@ -145,9 +139,8 @@ instance ToJSON WorldDescriptionPaint where toJSON w = object - [ "offset" .= offsetOrigin w - , "palette" .= Y.toJSON paletteKeymap - , "upperleft" .= ul w + [ "palette" .= Y.toJSON paletteKeymap + , "upperleft" .= gridPosition (area w) , "map" .= Y.toJSON mapText ] where diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.WorldPalette where -import Control.Arrow (first) import Control.Lens hiding (from, (.=), (<.>)) import Data.Aeson.KeyMap qualified as KM import Data.Map qualified as M @@ -72,11 +69,13 @@ where invertedMappedPairs = map (swap . fmap toKey) mappedPairs + renderMapCell :: Maybe CellPaintDisplay -> Char renderMapCell maybeC = case maybeC of Nothing -> maskChar Just c -> - -- NOTE: This lookup should never fail - M.findWithDefault (error "Palette lookup failed!") k $ + -- NOTE: This lookup should never fail; if it does for some + -- reason, return Z rather than crash the game + M.findWithDefault 'Z' k $ M.fromList invertedMappedPairs where k = toKey $ cellToTerrainPair c @@ -105,9 +104,8 @@ where preassignments :: [(Char, TerrainWith EntityFacade)] preassignments = - map (first T.head . fmap (cellToTerrainPair . standardCell)) $ - M.toList $ - KM.toMapText suggestedPalette + map (fmap (cellToTerrainPair . standardCell)) $ + M.toList suggestedPalette entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) entityCells = getUniqueTerrainFacadePairs $ catMaybes $ allMembers cellGrid diff --git a/src/swarm-scenario/Swarm/Game/State/Config.hs b/src/swarm-scenario/Swarm/Game/State/Config.hs --- a/src/swarm-scenario/Swarm/Game/State/Config.hs +++ b/src/swarm-scenario/Swarm/Game/State/Config.hs @@ -7,8 +7,8 @@ import Data.Map (Map) import Data.Text (Text) -import Swarm.Game.ResourceLoading (NameGenerator) import Swarm.Game.Scenario (GameStateInputs) +import Swarm.ResourceLoading (NameGenerator) -- | Record to pass information needed to create an initial -- 'GameState' record when starting a scenario. @@ -16,5 +16,9 @@ { initAppDataMap :: Map Text Text , nameParts :: NameGenerator -- ^ Lists of words/adjectives for use in building random robot names. + , startPaused :: Bool + -- ^ Start the game paused - useful for debugging or competitive play. + , pauseOnObjectiveCompletion :: Bool + -- ^ Pause the game when any objective is completed. , initState :: GameStateInputs } diff --git a/src/swarm-scenario/Swarm/Game/State/Landscape.hs b/src/swarm-scenario/Swarm/Game/State/Landscape.hs --- a/src/swarm-scenario/Swarm/Game/State/Landscape.hs +++ b/src/swarm-scenario/Swarm/Game/State/Landscape.hs @@ -13,6 +13,7 @@ multiWorld, worldScrollable, terrainAndEntities, + recognizerAutomatons, -- ** Utilities initLandscape, @@ -39,18 +40,21 @@ import Swarm.Game.Location import Swarm.Game.Robot (TRobot, trobotLocation) import Swarm.Game.Scenario +import Swarm.Game.Scenario.RobotLookup (IndexedTRobot) import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.State.Config import Swarm.Game.Terrain (TerrainType (..), terrainIndexByName) import Swarm.Game.Universe as U import Swarm.Game.World import Swarm.Game.World.Coords import Swarm.Game.World.Eval (runWorld) -import Swarm.Game.World.Gen (Seed, findGoodOrigin) -import Swarm.Util (applyWhen) +import Swarm.Game.World.Gen (Seed) import Swarm.Util.Erasable import Swarm.Util.Lens (makeLensesNoSigs) @@ -60,6 +64,7 @@ { _worldNavigation :: Navigation (M.Map SubworldName) Location , _multiWorld :: MultiWorld Int Entity , _terrainAndEntities :: TerrainEntityMaps + , _recognizerAutomatons :: RecognizerAutomatons RecognizableStructureContent Entity , _worldScrollable :: Bool } @@ -78,6 +83,9 @@ -- | The catalogs of all terrain and entities that the game knows about. terrainAndEntities :: Lens' Landscape TerrainEntityMaps +-- | Recognition engine for predefined structures +recognizerAutomatons :: Lens' Landscape (RecognizerAutomatons RecognizableStructureContent Entity) + -- | Whether the world map is supposed to be scrollable or not. worldScrollable :: Lens' Landscape Bool @@ -89,6 +97,7 @@ { _worldNavigation = Navigation mempty mempty , _multiWorld = mempty , _terrainAndEntities = initEntityTerrain $ gsiScenarioInputs $ initState gsc + , _recognizerAutomatons = RecognizerAutomatons mempty mempty , _worldScrollable = True } @@ -98,6 +107,7 @@ { _worldNavigation = sLandscape ^. scenarioNavigation , _multiWorld = genMultiWorld worldTuples theSeed , _terrainAndEntities = sLandscape ^. scenarioTerrainAndEntities + , _recognizerAutomatons = sLandscape ^. scenarioStructures . staticAutomatons , -- TODO (#1370): Should we allow subworlds to have their own scrollability? -- Leaning toward no, but for now just adopt the root world scrollability -- as being universal. @@ -134,9 +144,6 @@ g = gridContent area - ulOffset = origin .-. gridPosition area - ulModified = ul .+^ ulOffset - worldGrid :: Grid (TerrainType, Erasable Entity) worldGrid = maybe (BlankT, ENothing) (cellTerrain &&& cellEntity) <$> g @@ -144,7 +151,7 @@ offsetCoordsByArea x a = x `addTuple` swap (asTuple a) - coords = locToCoords ulModified + coords = locToCoords $ gridPosition area arrayMaxBound = both (subtract 1) @@ -158,7 +165,7 @@ worldArray = listArray arrayBoundsTuple $ allMembers worldGrid dslWF, arrayWF :: Seed -> WorldFun TerrainType Entity - dslWF = maybe mempty ((applyWhen offsetOrigin findGoodOrigin .) . runWorld) worldProg + dslWF = maybe mempty runWorld worldProg arrayWF = const $ worldFunFromArray worldArray wf = dslWF <> arrayWF @@ -166,7 +173,7 @@ -- Get all the robots described in cells and set their locations appropriately robots :: SubworldName -> [IndexedTRobot] robots swName = - concat $ mapIndexedMembers extractRobots g + concat $ mapWithCoords extractRobots g where extractRobots (Coords coordsTuple) maybeCell = let robotWithLoc = trobotLocation ?~ Cosmic swName (coordsToLoc (coords `addTuple` coordsTuple)) diff --git a/src/swarm-scenario/Swarm/Game/Terrain.hs b/src/swarm-scenario/Swarm/Game/Terrain.hs --- a/src/swarm-scenario/Swarm/Game/Terrain.hs +++ b/src/swarm-scenario/Swarm/Game/Terrain.hs @@ -35,10 +35,10 @@ import Data.Tuple (swap) import Data.Yaml import GHC.Generics (Generic) +import Swarm.Failure import Swarm.Game.Display import Swarm.Game.Entity.Cosmetic (WorldAttr (..)) -import Swarm.Game.Failure -import Swarm.Game.ResourceLoading (getDataFileNameSafe) +import Swarm.ResourceLoading (getDataFileNameSafe) import Swarm.Util (enumeratedMap, quote) import Swarm.Util.Effect (withThrow) @@ -134,7 +134,8 @@ forM rawTerrains $ \(TerrainItem n a d) -> do unless (Set.member (WorldAttr $ T.unpack a) validAttrs) . throwError - . CustomMessage + . SystemFailure + . CustomFailure $ T.unwords [ "Nonexistent attribute" , quote a diff --git a/src/swarm-scenario/Swarm/Game/World.hs b/src/swarm-scenario/Swarm/Game/World.hs --- a/src/swarm-scenario/Swarm/Game/World.hs +++ b/src/swarm-scenario/Swarm/Game/World.hs @@ -63,15 +63,15 @@ import Data.Semigroup (Last (..)) import Data.Yaml (FromJSON, ToJSON) import GHC.Generics (Generic) -import Swarm.Game.Entity (Entity) +import Swarm.Game.Entity (Entity, entityHash) import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Modify import Swarm.Game.Terrain (TerrainMap, TerrainType (BlankT), terrainByIndex, terrainName) import Swarm.Game.Universe import Swarm.Game.World.Coords -import Swarm.Game.World.Modify import Swarm.Util ((?)) import Swarm.Util.Erasable -import Prelude hiding (lookup) +import Prelude hiding (Foldable (..), lookup) ------------------------------------------------------------ -- World function @@ -278,7 +278,7 @@ World t Entity -> (World t Entity, CellUpdate Entity) update i g w@(World f t m) = - (wNew, classifyModification entityBefore entityAfter) + (wNew, classifyModification (view entityHash) entityBefore entityAfter) where wNew = World f t $ M.insert i entityAfter m entityBefore = lookupEntity i w diff --git a/src/swarm-scenario/Swarm/Game/World/Gen.hs b/src/swarm-scenario/Swarm/Game/World/Gen.hs --- a/src/swarm-scenario/Swarm/Game/World/Gen.hs +++ b/src/swarm-scenario/Swarm/Game/World/Gen.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -7,17 +6,9 @@ -- Utilities for working with procedurally generated worlds. module Swarm.Game.World.Gen where -import Control.Lens (view) -import Data.Enumeration -import Data.Int (Int32) -import Data.List (find) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Semigroup (Last (..), getLast) +import Data.Semigroup (Last (..)) import Data.Set qualified as S -import Data.Text (Text) import Swarm.Game.Entity -import Swarm.Game.World -import Swarm.Game.World.Coords import Swarm.Game.World.Syntax (CellVal (..)) import Swarm.Game.World.Typecheck (Const (CCell), TTerm (..)) import Swarm.Util.Erasable @@ -33,48 +24,3 @@ getEntity (EJust (Last e)) = S.singleton e getEntity _ = S.empty extractEntities _ = S.empty - --- | Offset a world by a multiple of the @skip@ in such a way that it --- satisfies the given predicate. -findOffset :: Integer -> ((Coords -> (t, Erasable (Last e))) -> Bool) -> WorldFun t e -> WorldFun t e -findOffset skip isGood (WF f) = WF f' - where - offset :: Enumeration Int32 - offset = fromIntegral . (skip *) <$> int - - f' = - fromMaybe (error "the impossible happened, no offsets were found!") - . find isGood - . map shift - . enumerate - $ offset >< offset - - shift (dr, dc) (Coords (r, c)) = f (Coords (r - dr, c - dc)) - --- | Offset the world so the base starts in a 32x32 patch containing at least one --- of each of a list of required entities. -findPatchWith :: [Text] -> WorldFun t Entity -> WorldFun t Entity -findPatchWith reqs = findOffset 32 isGoodPatch - where - patchCoords = [(r, c) | r <- [-16 .. 16], c <- [-16 .. 16]] - isGoodPatch f = all (`S.member` es) reqs - where - es = S.fromList . map (view entityName) . mapMaybe (erasableToMaybe . fmap getLast . snd . f . Coords) $ patchCoords - --- | Offset the world so the base starts on empty spot next to tree and grass. -findTreeOffset :: WorldFun t Entity -> WorldFun t Entity -findTreeOffset = findOffset 1 isGoodPlace - where - isGoodPlace f = - hasEntity Nothing (0, 0) - && any (hasEntity (Just "tree")) neighbors - && all (\c -> hasEntity (Just "tree") c || hasEntity Nothing c) neighbors - where - hasEntity mayE = (== mayE) . erasableToMaybe . fmap (view entityName . getLast) . snd . f . Coords - - neighbors = [(r, c) | r <- [-1 .. 1], c <- [-1 .. 1]] - --- | Offset the world so the base starts in a good patch (near --- necessary items), next to a tree. -findGoodOrigin :: WorldFun t Entity -> WorldFun t Entity -findGoodOrigin = findTreeOffset . findPatchWith ["tree", "copper ore", "bit (0)", "bit (1)", "rock", "lambda", "water", "sand"] diff --git a/src/swarm-scenario/Swarm/Game/World/Interpret.hs b/src/swarm-scenario/Swarm/Game/World/Interpret.hs --- a/src/swarm-scenario/Swarm/Game/World/Interpret.hs +++ b/src/swarm-scenario/Swarm/Game/World/Interpret.hs @@ -11,7 +11,6 @@ interpConst, ) where -import Control.Applicative (Applicative (..)) import Data.ByteString (ByteString) import Data.Hash.Murmur (murmur3) import Data.Tagged (unTagged) @@ -24,7 +23,6 @@ import Swarm.Game.World.Typecheck (Const (..), Empty (..), Over (..)) import Witch (from) import Witch.Encoding qualified as Encoding -import Prelude hiding (Applicative (..)) -- | Interpret an abstracted term into the host language. interpBTerm :: Seed -> BTerm a -> a diff --git a/src/swarm-scenario/Swarm/Game/World/Load.hs b/src/swarm-scenario/Swarm/Game/World/Load.hs --- a/src/swarm-scenario/Swarm/Game/World/Load.hs +++ b/src/swarm-scenario/Swarm/Game/World/Load.hs @@ -8,39 +8,33 @@ import Control.Algebra (Has) import Control.Arrow (left) -import Control.Carrier.Accum.FixedStrict (Accum) import Control.Carrier.Lift (Lift, sendIO) import Control.Carrier.Reader (runReader) import Control.Effect.Throw (Throw, liftEither) import Data.Map qualified as M -import Data.Maybe (catMaybes) -import Data.Sequence (Seq) import Data.Text (Text) -import Swarm.Game.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..)) +import Swarm.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..)) import Swarm.Game.Land -import Swarm.Game.ResourceLoading (getDataDirSafe) import Swarm.Game.World.Parse (parseWExp, runParser) import Swarm.Game.World.Typecheck -import Swarm.Language.Pretty (prettyText) +import Swarm.Pretty (prettyText) +import Swarm.ResourceLoading (getDataDirSafe) import Swarm.Util (acquireAllWithExt) -import Swarm.Util.Effect (throwToWarning, withThrow) +import Swarm.Util.Effect (withThrow) import System.FilePath (dropExtension, joinPath, splitPath) import Witch (into) -- | Load and typecheck all world descriptions from `worlds/*.world`. --- Emit a warning for each one which fails to parse or typecheck. +-- Throw an exception if any fail to parse or typecheck. loadWorlds :: - (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => TerrainEntityMaps -> m WorldMap loadWorlds tem = do - res <- throwToWarning @SystemFailure $ getDataDirSafe Worlds "worlds" - case res of - Nothing -> return M.empty - Just dir -> do - worldFiles <- sendIO $ acquireAllWithExt dir "world" - ws <- mapM (throwToWarning @SystemFailure . loadWorld dir tem) worldFiles - return . M.fromList . catMaybes $ ws + dir <- getDataDirSafe Worlds "worlds" + worldFiles <- sendIO $ acquireAllWithExt dir "world" + ws <- mapM (loadWorld dir tem) worldFiles + return . M.fromList $ ws -- | Load a file containing a world DSL term, throwing an exception if -- it fails to parse or typecheck. @@ -52,10 +46,10 @@ m (Text, Some (TTerm '[])) loadWorld dir tem (fp, src) = do wexp <- - liftEither . left (AssetNotLoaded (Data Worlds) fp . CanNotParseMegaparsec) $ + liftEither . left (AssetNotLoaded (Data Worlds) fp . SystemFailure . CanNotParseMegaparsec) $ runParser parseWExp (into @Text src) t <- - withThrow (AssetNotLoaded (Data Worlds) fp . DoesNotTypecheck . prettyText @CheckErr) $ + withThrow (AssetNotLoaded (Data Worlds) fp . SystemFailure . DoesNotTypecheck . prettyText @CheckErr) $ runReader tem . runReader @WorldMap M.empty $ infer CNil wexp return (into @Text (dropExtension (stripDir dir fp)), t) diff --git a/src/swarm-scenario/Swarm/Game/World/Modify.hs b/src/swarm-scenario/Swarm/Game/World/Modify.hs deleted file mode 100644 --- a/src/swarm-scenario/Swarm/Game/World/Modify.hs +++ /dev/null @@ -1,41 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Captures the various possibilities of cell --- modification as a sum type for use by the structure recognizer --- (see 'Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking.entityModified'). -module Swarm.Game.World.Modify where - -import Control.Lens (view) -import Data.Function (on) -import Swarm.Game.Entity (Entity, entityHash) - --- | Compare to 'WorldUpdate' in "Swarm.Game.World" -data CellUpdate e - = NoChange (Maybe e) - | Modified (CellModification e) - -getModification :: CellUpdate e -> Maybe (CellModification e) -getModification (NoChange _) = Nothing -getModification (Modified x) = Just x - -data CellModification e - = -- | Fields represent what existed in the cell "before" and "after", in that order. - -- The values are guaranteed to be different. - Swap e e - | Remove e - | Add e - -classifyModification :: - -- | before - Maybe Entity -> - -- | after - Maybe Entity -> - CellUpdate Entity -classifyModification Nothing Nothing = NoChange Nothing -classifyModification Nothing (Just x) = Modified $ Add x -classifyModification (Just x) Nothing = Modified $ Remove x -classifyModification (Just x) (Just y) = - if ((/=) `on` view entityHash) x y - then Modified $ Swap x y - else NoChange $ Just x diff --git a/src/swarm-scenario/Swarm/Game/World/Parse.hs b/src/swarm-scenario/Swarm/Game/World/Parse.hs --- a/src/swarm-scenario/Swarm/Game/World/Parse.hs +++ b/src/swarm-scenario/Swarm/Game/World/Parse.hs @@ -270,5 +270,5 @@ instance FromJSON WExp where parseJSON = withText "World DSL program" $ \t -> case runParser parseWExp t of - Left err -> error (errorBundlePretty err) + Left err -> fail (errorBundlePretty err) Right wexp -> return wexp diff --git a/src/swarm-scenario/Swarm/Game/World/Render.hs b/src/swarm-scenario/Swarm/Game/World/Render.hs --- a/src/swarm-scenario/Swarm/Game/World/Render.hs +++ b/src/swarm-scenario/Swarm/Game/World/Render.hs @@ -2,7 +2,17 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- GameState- and TUI-independent world rendering. -module Swarm.Game.World.Render where +module Swarm.Game.World.Render ( + FailureMode (..), + RenderOpts (..), + RenderComputationContext (..), + OuputFormat (..), + ColorableCell, + getDisplayGrid, + doRenderCmd, + getRenderableGrid, + renderImage, +) where import Codec.Picture import Control.Applicative ((<|>)) @@ -10,18 +20,23 @@ import Control.Effect.Lift (Lift, sendIO) import Control.Effect.Throw import Control.Lens (view, (^.)) -import Data.Colour.SRGB (RGB (..)) +import Control.Monad.Extra (guarded) +import Control.Monad.Logger +import Control.Monad.Trans (MonadIO) +import Data.Aeson import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (fromMaybe) import Data.Tuple.Extra (both) +import GHC.Generics (Generic) import Linear (V2 (..)) +import Swarm.Failure (SystemFailure, simpleErrorHandle) import Swarm.Game.Display (defaultChar) import Swarm.Game.Entity.Cosmetic -import Swarm.Game.Failure (SystemFailure, simpleErrorHandle) import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Scenario +import Swarm.Game.Scenario.Style (HexColor (..)) import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Center @@ -29,16 +44,42 @@ import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Rasterize import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.State.Landscape import Swarm.Game.Universe import Swarm.Game.World.Coords import Swarm.Game.World.Gen (Seed) -import Swarm.Language.Pretty (prettyString) -import Swarm.Util (surfaceEmpty) +import Swarm.Pretty (prettyText) +import Swarm.Util (failT) import Swarm.Util.Content import Swarm.Util.Erasable (erasableToMaybe) -import System.IO (hPutStrLn, stderr) +import Swarm.Util.Yaml +newtype OneBitColor = OneBitColor Bool + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + +instance ToPixel OneBitColor where + toPixel (OneBitColor b) = case b of + False -> PixelRGBA8 0 0 0 255 + True -> PixelRGBA8 255 255 255 255 + +data ColorableCell + = OneBit OneBitColor + | Hex HexColor + +instance ToPixel ColorableCell where + toPixel (OneBit x) = toPixel x + toPixel (Hex x) = toPixel x + +instance FromJSON ColorableCell where + parseJSON x = + try OneBit + <|> try Hex + where + try f = f <$> parseJSON x + +instance FromJSONE e ColorableCell + data OuputFormat = ConsoleText | PngImage @@ -47,13 +88,17 @@ = Terminate | RenderBlankImage +data RenderComputationContext = RenderComputationContext + { _renderSeed :: Maybe Seed + , gridSize :: Maybe AreaDimensions + } + -- | Command-line options for configuring the app. data RenderOpts = RenderOpts - { renderSeed :: Maybe Seed + { renderComputation :: RenderComputationContext -- ^ Explicit seed chosen by the user. , outputFormat :: OuputFormat , outputFilepath :: FilePath - , gridSize :: Maybe AreaDimensions , failureMode :: FailureMode } @@ -62,38 +107,6 @@ where facadeChar (EntityFacade _ d) = view defaultChar d -getDisplayColor :: M.Map WorldAttr PreservableColor -> PCell EntityFacade -> PixelRGBA8 -getDisplayColor aMap c = - maybe transparent mkPixelColor $ getTerrainEntityColor aMap c - where - transparent = PixelRGBA8 0 0 0 0 - -mkPixelColor :: PreservableColor -> PixelRGBA8 -mkPixelColor h = PixelRGBA8 r g b 255 - where - RGB r g b = flattenBg $ fromHiFi h - --- | Since terminals can customize these named --- colors using themes or explicit user overrides, --- these color assignments are somewhat arbitrary. -namedToTriple :: NamedColor -> RGBColor -namedToTriple = \case - White -> RGB 208 207 204 - BrightRed -> RGB 246 97 81 - Red -> RGB 192 28 40 - Green -> RGB 38 162 105 - Blue -> RGB 18 72 139 - BrightYellow -> RGB 233 173 12 - Yellow -> RGB 162 115 76 - -fromHiFi :: PreservableColor -> ColorLayers RGBColor -fromHiFi = fmap $ \case - Triple x -> x - -- The triples we've manually assigned for named - -- ANSI colors do not need to be round-tripped, since - -- those triples are not inputs to the VTY attribute creation. - AnsiColor x -> namedToTriple x - -- | When output size is not explicitly provided, -- uses natural map bounds (if a map exists). getBoundingBox :: @@ -106,7 +119,7 @@ where upperLeftLocation = if null maybeSize && not (isEmpty mapAreaDims) - then ul scenarioWorld + then gridPosition $ area scenarioWorld else vc .+^ ((`div` 2) <$> V2 (negate w) h) mkBoundingBox areaDimens upperLeftLoc = @@ -119,7 +132,7 @@ mapAreaDims = getGridDimensions worldArea areaDims@(AreaDimensions w h) = fromMaybe (AreaDimensions 20 10) $ - maybeSize <|> surfaceEmpty isEmpty mapAreaDims + maybeSize <|> guarded (not . isEmpty) mapAreaDims getDisplayGrid :: Location -> @@ -138,13 +151,21 @@ firstScenarioWorld = NE.head $ view scenarioWorlds sLandscape -getRenderableGrid :: +getRenderableGridFromPath :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => RenderOpts -> FilePath -> - m (Grid (PCell EntityFacade), M.Map WorldAttr PreservableColor) -getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize _) fp = do + m ThumbnailRenderContext +getRenderableGridFromPath (RenderOpts ctx _ _ _) fp = do (myScenario, _gsi) <- loadStandaloneScenario fp + getRenderableGrid ctx myScenario + +getRenderableGrid :: + Has (Lift IO) sig m => + RenderComputationContext -> + Scenario -> + m ThumbnailRenderContext +getRenderableGrid (RenderComputationContext maybeSeed maybeSize) myScenario = do let sLandscape = myScenario ^. scenarioLandscape theSeed <- sendIO $ arbitrateSeed maybeSeed sLandscape @@ -155,35 +176,57 @@ view planar $ determineStaticViewCenter sLandscape worldTuples - return (getDisplayGrid vc sLandscape myLandscape maybeSize, sLandscape ^. scenarioCosmetics) + return $ + ThumbnailRenderContext + (getDisplayGrid vc sLandscape myLandscape maybeSize) + (sLandscape ^. scenarioCosmetics) doRenderCmd :: RenderOpts -> FilePath -> IO () -doRenderCmd opts@(RenderOpts _ asPng _ _ _) mapPath = +doRenderCmd opts@(RenderOpts _ asPng _ _) mapPath = case asPng of ConsoleText -> printScenarioMap =<< renderScenarioMap opts mapPath PngImage -> renderScenarioPng opts mapPath renderScenarioMap :: RenderOpts -> FilePath -> IO [String] renderScenarioMap opts fp = simpleErrorHandle $ do - (grid, _) <- getRenderableGrid opts fp + ThumbnailRenderContext grid _ <- getRenderableGridFromPath opts fp return $ getRows $ getDisplayChar <$> grid +data ThumbnailRenderContext + = ThumbnailRenderContext + (Grid (PCell EntityFacade)) + (M.Map WorldAttr PreservableColor) + +renderImage :: + ThumbnailRenderContext -> + Image PixelRGBA8 +renderImage (ThumbnailRenderContext grid aMap) = + makeImage $ getTerrainEntityColor aMap <$> grid + +renderImageHandleFailure :: + (MonadFail m, MonadIO m) => + RenderOpts -> + Either SystemFailure ThumbnailRenderContext -> + LoggingT m (Image PixelRGBA8) +renderImageHandleFailure opts result = + case result of + Left err -> handleFailure err + Right ctx -> return $ renderImage ctx + where + handleFailure err = case failureMode opts of + Terminate -> failT $ pure errorMsg + RenderBlankImage -> do + logWarnN errorMsg + let s = maybe (1, 1) (both fromIntegral . asTuple) $ gridSize $ renderComputation opts + return $ uncurry (generateImage $ \_x _y -> PixelRGBA8 0 0 0 255) s + where + errorMsg = prettyText err + renderScenarioPng :: RenderOpts -> FilePath -> IO () renderScenarioPng opts fp = do - result <- runThrow $ getRenderableGrid opts fp - img <- case result of - Left (err :: SystemFailure) -> case failureMode opts of - Terminate -> fail errorMsg - RenderBlankImage -> do - hPutStrLn stderr errorMsg - let s = maybe (1, 1) (both fromIntegral . asTuple) $ gridSize opts - return $ uncurry (generateImage $ \_x _y -> PixelRGBA8 0 0 0 255) s - where - errorMsg :: String - errorMsg = prettyString err - Right (grid, aMap) -> return $ (makeImage . getDisplayColor) aMap grid + result <- runThrow $ getRenderableGridFromPath opts fp + img <- runStderrLoggingT $ renderImageHandleFailure opts result writePng (outputFilepath opts) img printScenarioMap :: [String] -> IO () -printScenarioMap = - sendIO . mapM_ putStrLn +printScenarioMap = sendIO . mapM_ putStrLn diff --git a/src/swarm-scenario/Swarm/Game/World/Syntax.hs b/src/swarm-scenario/Swarm/Game/World/Syntax.hs --- a/src/swarm-scenario/Swarm/Game/World/Syntax.hs +++ b/src/swarm-scenario/Swarm/Game/World/Syntax.hs @@ -28,7 +28,7 @@ import Swarm.Game.Robot (TRobot, trobotName) import Swarm.Game.Terrain import Swarm.Game.World.Coords -import Swarm.Language.Pretty +import Swarm.Pretty (PrettyPrec (..)) import Swarm.Util (showT) import Swarm.Util.Erasable diff --git a/src/swarm-scenario/Swarm/Game/World/Typecheck.hs b/src/swarm-scenario/Swarm/Game/World/Typecheck.hs --- a/src/swarm-scenario/Swarm/Game/World/Typecheck.hs +++ b/src/swarm-scenario/Swarm/Game/World/Typecheck.hs @@ -23,10 +23,10 @@ import Control.Algebra (Has) import Control.Effect.Reader (Reader, ask) import Control.Effect.Throw (Throw, throwError) +import Data.Foldable (Foldable (..)) import Data.Foldable qualified as F import Data.Functor.Const qualified as F import Data.Kind (Type) -import Data.List (foldl') import Data.List.Extra (enumerate) import Data.List.NonEmpty qualified as NE import Data.Map (Map) @@ -39,10 +39,10 @@ import Swarm.Game.Land import Swarm.Game.Terrain import Swarm.Game.World.Syntax -import Swarm.Language.Pretty +import Swarm.Pretty (PrettyPrec (..), pparens, ppr) import Swarm.Util (showT) import Swarm.Util.Erasable -import Prelude hiding (lookup) +import Prelude hiding (Foldable (..), lookup) ------------------------------------------------------------ -- Type classes for monoidal world values @@ -268,6 +268,7 @@ Unbound :: Text -> CheckErr BadType :: Some (TTerm g) -> TTy b -> CheckErr BadDivType :: TTy a -> CheckErr + BadInferOp :: [SomeTy] -> Op -> CheckErr UnknownImport :: Text -> CheckErr NotAThing :: Text -> CellTag -> CheckErr NotAnything :: Text -> CheckErr @@ -289,6 +290,7 @@ hsep [squotes (ppr t), "has type", squotes (ppr tty), "and cannot be given type", squotes (ppr ty)] BadDivType ty -> "Division operator used at type" <+> squotes (ppr ty) + BadInferOp tys op -> "Bad call to inferOp" <+> pretty (show tys) <+> pretty (show op) UnknownImport key -> "Import" <+> squotes (pretty key) <+> "not found" NotAThing item tag -> squotes (pretty item) <+> "is not" <+> ppr tag NotAnything item -> "Cannot resolve cell item" <+> squotes (pretty item) @@ -541,7 +543,8 @@ inferOp [SomeTy tyA] Mask = Some (TTyWorld TTyBool :->: TTyWorld tyA :->: TTyWorld tyA) <$> checkEmpty tyA (return $ embed CMask) inferOp [SomeTy tyA] Overlay = Some (tyA :->: tyA :->: tyA) <$> checkOver tyA (return $ embed COver) inferOp [SomeTy tyA] IMap = Some (TTyWorld TTyInt :->: TTyWorld TTyInt :->: TTyWorld tyA :->: TTyWorld tyA) <$> checkNotFun tyA (return $ embed CIMap) -inferOp tys op = error $ "bad call to inferOp: " ++ show tys ++ " " ++ show op +-- In theory, this last case should never happen. +inferOp tys op = throwError $ BadInferOp tys op -- | Given a raw operator and the terms the operator is applied to, -- select which types should be supplied as the type arguments to diff --git a/src/swarm-topography/Swarm/Game/Location.hs b/src/swarm-topography/Swarm/Game/Location.hs --- a/src/swarm-topography/Swarm/Game/Location.hs +++ b/src/swarm-topography/Swarm/Game/Location.hs @@ -20,7 +20,6 @@ toDirection, toAbsDirection, nearestDirection, - fromDirection, isCardinal, north, south, @@ -30,6 +29,7 @@ -- ** Utility functions manhattan, euclidean, + asVector, getLocsInArea, getElemsInArea, @@ -192,14 +192,6 @@ index = round $ fromIntegral (length orderedDirs) * angle orderedDirs = Util.enumerateNonEmpty --- | Convert a 'Direction' into a corresponding 'Heading'. Note that --- this only does something reasonable for 'DNorth', 'DSouth', 'DEast', --- and 'DWest'---other 'Direction's return the zero vector. -fromDirection :: Direction -> Heading -fromDirection = \case - DAbsolute x -> toHeading x - _ -> zero - -- | Manhattan distance between world locations. manhattan :: Location -> Location -> Int32 manhattan (Location x1 y1) (Location x2 y2) = abs (x1 - x2) + abs (y1 - y2) @@ -207,6 +199,10 @@ -- | Euclidean distance between world locations. euclidean :: Location -> Location -> Double euclidean p1 p2 = norm (fromIntegral <$> (p2 .-. p1)) + +-- | Converts a 'Point' to a vector offset from the 'origin'. +asVector :: Location -> V2 Int32 +asVector (P vec) = vec -- | Get all the locations that are within a certain manhattan -- distance from a given location. diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs @@ -4,10 +4,14 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.Area where +import Data.Aeson (ToJSON) +import Data.Function (on) import Data.Int (Int32) import Data.List qualified as L +import Data.List.NonEmpty qualified as NE import Data.Maybe (listToMaybe) import Data.Semigroup +import GHC.Generics (Generic) import Linear (V2 (..)) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Grid @@ -18,10 +22,19 @@ { rectWidth :: Int32 , rectHeight :: Int32 } + deriving (Show, Eq, Generic, ToJSON) getGridDimensions :: Grid a -> AreaDimensions getGridDimensions g = getAreaDimensions $ getRows g +getNEGridDimensions :: NonEmptyGrid a -> AreaDimensions +getNEGridDimensions (NonEmptyGrid xs) = + (AreaDimensions `on` fromIntegral) + (NE.length firstRow) + (NE.length xs) + where + firstRow = NE.head xs + asTuple :: AreaDimensions -> (Int32, Int32) asTuple (AreaDimensions x y) = (x, y) @@ -75,6 +88,7 @@ fillGrid (AreaDimensions _ 0) _ = EmptyGrid fillGrid (AreaDimensions w h) x = Grid + . NonEmptyGrid . stimes h . pure . stimes w diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs @@ -2,63 +2,86 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.Grid ( Grid (..), + NonEmptyGrid (..), gridToVec, - mapIndexedMembers, + mapWithCoords, + mapWithCoordsNE, allMembers, - mapRows, + allMembersNE, + mapRowsNE, getRows, mkGrid, + getNonEmptyGrid, ) where +import Control.Lens.Indexed (FunctorWithIndex, imap) import Data.Aeson (ToJSON (..)) +import Data.Foldable qualified as F import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Semigroup +import Data.Tuple.Extra (both) import Data.Vector qualified as V +import GHC.Generics (Generic) import Swarm.Game.World.Coords import Prelude hiding (zipWith) +newtype NonEmptyGrid c = NonEmptyGrid (NonEmpty (NonEmpty c)) + deriving (Generic, Show, Eq, Functor, Foldable, Traversable, ToJSON) + +instance FunctorWithIndex Coords NonEmptyGrid where + imap f (NonEmptyGrid g) = + NonEmptyGrid $ + imap (\i -> imap (\j -> f (Coords $ both fromIntegral (i, j)))) g + data Grid c = EmptyGrid - | Grid (NonEmpty (NonEmpty c)) + | Grid (NonEmptyGrid c) deriving (Show, Eq, Functor, Foldable, Traversable) mkGrid :: [[a]] -> Grid a mkGrid rows = fromMaybe EmptyGrid $ do rowsNE <- NE.nonEmpty =<< mapM NE.nonEmpty rows - return $ Grid rowsNE + return $ Grid $ NonEmptyGrid rowsNE +getNonEmptyGrid :: Grid a -> Maybe (NonEmptyGrid a) +getNonEmptyGrid = \case + EmptyGrid -> Nothing + Grid x -> Just x + getRows :: Grid a -> [[a]] getRows EmptyGrid = [] -getRows (Grid g) = NE.toList . NE.map NE.toList $ g +getRows (Grid (NonEmptyGrid g)) = NE.toList . NE.map NE.toList $ g -- | Since the derived 'Functor' instance applies to the -- type parameter that is nested within lists, we define -- an explicit function for mapping over the enclosing lists. -mapRows :: (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty b)) -> Grid a -> Grid b -mapRows _ EmptyGrid = EmptyGrid -mapRows f (Grid rows) = Grid $ f rows +mapRowsNE :: + (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty b)) -> + NonEmptyGrid a -> + NonEmptyGrid b +mapRowsNE f (NonEmptyGrid rows) = NonEmptyGrid $ f rows +allMembersNE :: NonEmptyGrid c -> NonEmpty c +allMembersNE (NonEmptyGrid g) = sconcat g + allMembers :: Grid a -> [a] allMembers EmptyGrid = [] -allMembers g = concat . getRows $ g +allMembers g = F.toList g -mapIndexedMembers :: (Coords -> a -> b) -> Grid a -> [b] -mapIndexedMembers _ EmptyGrid = [] -mapIndexedMembers f (Grid g) = - NE.toList $ - sconcat $ - NE.zipWith (\i -> NE.zipWith (\j -> f (Coords (i, j))) nonemptyCount) nonemptyCount g - where - nonemptyCount = NE.iterate succ 0 +mapWithCoordsNE :: (Coords -> a -> b) -> NonEmptyGrid a -> NonEmpty b +mapWithCoordsNE f = allMembersNE . imap f +mapWithCoords :: (Coords -> a -> b) -> Grid a -> [b] +mapWithCoords _ EmptyGrid = [] +mapWithCoords f (Grid g) = NE.toList $ mapWithCoordsNE f g + -- | Converts linked lists to vectors to facilitate -- random access when assembling the image gridToVec :: Grid a -> V.Vector (V.Vector a) -gridToVec EmptyGrid = V.empty -gridToVec (Grid g) = V.fromList . map (V.fromList . NE.toList) $ NE.toList g +gridToVec g = V.fromList . map V.fromList $ getRows g instance (ToJSON a) => ToJSON (Grid a) where toJSON EmptyGrid = toJSON ([] :: [a]) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Modify.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Modify.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Modify.hs @@ -0,0 +1,35 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Captures the various possibilities of cell +-- modification as a sum type for use by the structure recognizer +-- (see 'Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking.entityModified'). +module Swarm.Game.Scenario.Topography.Modify where + +import Data.Function (on) +import Swarm.Game.Scenario.Topography.Terraform + +-- | Compare to 'WorldUpdate' in "Swarm.Game.World" +data CellUpdate e + = NoChange (Maybe e) + | Modified (CellModification e) + +getModification :: CellUpdate e -> Maybe (CellModification e) +getModification (NoChange _) = Nothing +getModification (Modified x) = Just x + +classifyModification :: + Eq b => + (a -> b) -> + -- | before + Maybe a -> + -- | after + Maybe a -> + CellUpdate a +classifyModification _ Nothing Nothing = NoChange Nothing +classifyModification _ Nothing (Just x) = Modified $ Add x +classifyModification _ (Just x) Nothing = Modified $ Remove x +classifyModification f (Just x) (Just y) = + if ((/=) `on` f) x y + then Modified $ Swap x y + else NoChange $ Just x diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs @@ -21,6 +21,7 @@ -- precise control of ordering. module Swarm.Game.Scenario.Topography.Navigation.Waypoint where +import Data.Aeson (ToJSONKey) import Data.Text qualified as T import Data.Yaml as Y import GHC.Generics (Generic) @@ -42,7 +43,7 @@ deriving (Show, Eq, Functor) newtype WaypointName = WaypointName T.Text - deriving (Show, Eq, Ord, Generic, FromJSON) + deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, ToJSONKey) -- | Metadata about a waypoint data WaypointConfig = WaypointConfig diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs @@ -9,19 +9,17 @@ module Swarm.Game.Scenario.Topography.Placement where import Data.List.NonEmpty qualified as NE -import Data.Text (Text) import Data.Yaml as Y -import GHC.Generics (Generic) import Swarm.Game.Location -import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Area ( + AreaDimensions (..), + ) import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Structure.Named ( + StructureName, + ) import Swarm.Language.Syntax.Direction (AbsoluteDir (..)) - -newtype StructureName = StructureName Text - deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) - -getStructureName :: StructureName -> Text -getStructureName (StructureName sn) = sn +import Swarm.Util (applyWhen) -- | Orientation transformations are applied before translation. data Orientation = Orientation @@ -49,21 +47,28 @@ transposeLoc (Location x y) = Location (-y) (-x) flipV (Location x y) = Location x $ -(height - 1) - y flipH (Location x y) = Location (width - 1 - x) y - flipping = if shouldFlip then flipV else id + flipping = applyWhen shouldFlip flipV rotational = case upDir of DNorth -> id DSouth -> flipH . flipV DEast -> transposeLoc . flipV DWest -> transposeLoc . flipH +applyOrientationTransform :: + Orientation -> + Grid a -> + Grid a +applyOrientationTransform _ EmptyGrid = EmptyGrid +applyOrientationTransform f (Grid g) = Grid $ applyOrientationTransformNE f g + -- | affine transformation -applyOrientationTransform :: Orientation -> Grid a -> Grid a -applyOrientationTransform (Orientation upDir shouldFlip) = - mapRows f +applyOrientationTransformNE :: Orientation -> NonEmptyGrid a -> NonEmptyGrid a +applyOrientationTransformNE (Orientation upDir shouldFlip) = + mapRowsNE f where f = rotational . flipping flipV = NE.reverse - flipping = if shouldFlip then flipV else id + flipping = applyWhen shouldFlip flipV rotational = case upDir of DNorth -> id DSouth -> NE.transpose . flipV . NE.transpose . flipV diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs @@ -6,26 +6,56 @@ module Swarm.Game.Scenario.Topography.ProtoCell ( SignpostableCell (..), StructurePalette (..), + StructureMarker (..), ) where import Control.Applicative ((<|>)) -import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Map (Map, fromList, toList) +import Data.Text qualified as T +import Data.Tuple (swap) import Data.Yaml as Y +import GHC.Generics (Generic) import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig) +import Swarm.Game.Scenario.Topography.Placement +import Swarm.Game.Scenario.Topography.Structure.Named (StructureName) +import Swarm.Util (quote) import Swarm.Util.Yaml newtype StructurePalette e = StructurePalette - {unPalette :: KeyMap (SignpostableCell e)} + {unPalette :: Map Char (SignpostableCell e)} deriving (Eq, Show) instance (FromJSONE e a) => FromJSONE e (StructurePalette a) where parseJSONE = - withObjectE "palette" $ - fmap StructurePalette . mapM parseJSONE + withObjectE "palette" $ \v -> do + m <- mapM parseJSONE v + -- We swap the tuples twice so we can traverse over the second + -- element of the tuple in between. + swappedPairs <- mapM (verifyChar . swap) $ toList $ KM.toMap m + return . StructurePalette . fromList $ map swap swappedPairs + where + verifyChar = traverse $ ensureSingleChar . K.toString + ensureSingleChar [x] = return x + ensureSingleChar x = + fail $ + T.unpack $ + T.unwords + [ "Palette entry is not a single character:" + , quote $ T.pack x + ] --- | Supplements a cell with waypoint information +data StructureMarker = StructureMarker + { name :: StructureName + , orientation :: Maybe Orientation + } + deriving (Eq, Show, Generic, FromJSON) + +-- | Supplements a cell with waypoint and/or structure placement information data SignpostableCell c = SignpostableCell { waypointCfg :: Maybe WaypointConfig + , structureMarker :: Maybe StructureMarker , standardCell :: c } deriving (Eq, Show) @@ -33,9 +63,10 @@ instance (FromJSONE e a) => FromJSONE e (SignpostableCell a) where parseJSONE x = withObjectE "SignpostableCell" objParse x - <|> (SignpostableCell Nothing <$> parseJSONE x) + <|> (SignpostableCell Nothing Nothing <$> parseJSONE x) where objParse v = do waypointCfg <- liftE $ v .:? "waypoint" + structureMarker <- liftE $ v .:? "structure" standardCell <- v ..: "cell" pure $ SignpostableCell {..} diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs @@ -9,10 +9,18 @@ import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Grid -makeImage :: Pixel px => (a -> px) -> Grid a -> Image px -makeImage computeColor g = +class ToPixel a where + toPixel :: a -> PixelRGBA8 + +instance ToPixel a => ToPixel (Maybe a) where + toPixel = maybe transparent toPixel + where + transparent = PixelRGBA8 0 0 0 0 + +makeImage :: ToPixel a => Grid a -> Image PixelRGBA8 +makeImage g = generateImage (pixelRenderer vecGrid) (fromIntegral w) (fromIntegral h) where vecGrid = gridToVec g AreaDimensions w h = getGridDimensions g - pixelRenderer vg x y = computeColor $ (vg V.! y) V.! x + pixelRenderer vg x y = toPixel $ (vg V.! y) V.! x diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs @@ -9,15 +9,12 @@ -- as well as logic for combining them. module Swarm.Game.Scenario.Topography.Structure where -import Control.Monad (unless) -import Data.Aeson.Key qualified as Key -import Data.Aeson.KeyMap qualified as KeyMap +import Control.Monad (forM_, unless) +import Data.List (intercalate) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M -import Data.Maybe (catMaybes) -import Data.Set (Set) +import Data.Maybe (catMaybes, fromMaybe) import Data.Set qualified as Set -import Data.Text (Text) import Data.Text qualified as T import Data.Yaml as Y import Swarm.Game.Location @@ -25,31 +22,13 @@ import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Scenario.Topography.Placement import Swarm.Game.Scenario.Topography.ProtoCell +import Swarm.Game.Scenario.Topography.Structure.Named import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.Structure.Recognition.Static import Swarm.Game.World.Coords -import Swarm.Language.Syntax.Direction (AbsoluteDir) import Swarm.Util (failT, showT) import Swarm.Util.Yaml -data NamedArea a = NamedArea - { name :: StructureName - , recognize :: Set AbsoluteDir - -- ^ whether this structure should be registered for automatic recognition - -- and which orientations shall be recognized. - -- The supplied direction indicates which cardinal direction the - -- original map's "North" has been re-oriented to. - -- E.g., 'DWest' represents a rotation of 90 degrees counter-clockwise. - , description :: Maybe Text - -- ^ will be UI-facing only if this is a recognizable structure - , structure :: a - } - deriving (Eq, Show, Functor) - -isRecognizable :: NamedArea a -> Bool -isRecognizable = not . null . recognize - -type NamedGrid c = NamedArea (Grid c) - type NamedStructure c = NamedArea (PStructure c) data PStructure c = Structure @@ -65,18 +44,6 @@ data Placed c = Placed Placement (NamedStructure c) deriving (Show) --- | For use in registering recognizable pre-placed structures -data LocatedStructure = LocatedStructure - { placedName :: StructureName - , upDirection :: AbsoluteDir - , cornerLoc :: Location - } - deriving (Show) - -instance HasLocation LocatedStructure where - modifyLoc f (LocatedStructure x y originalLoc) = - LocatedStructure x y $ f originalLoc - data MergedStructure c = MergedStructure (PositionedGrid c) [LocatedStructure] [Originated Waypoint] instance (FromJSONE e a) => FromJSONE e (NamedStructure (Maybe a)) where @@ -100,19 +67,27 @@ fail "Grid is not rectangular!" return g +parseStructure :: + StructurePalette c -> + [NamedStructure (Maybe c)] -> + Object -> + Parser (PStructure (Maybe c)) +parseStructure pal structures v = do + explicitPlacements <- v .:? "placements" .!= [] + waypointDefs <- v .:? "waypoints" .!= [] + maybeMaskChar <- v .:? "mask" + rawGrid <- v .:? "map" .!= EmptyGrid + (maskedArea, mapWaypoints, palettePlacements) <- paintMap maybeMaskChar pal rawGrid + let area = PositionedGrid origin maskedArea + waypoints = waypointDefs <> mapWaypoints + placements = explicitPlacements <> palettePlacements + return Structure {..} + instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where parseJSONE = withObjectE "structure definition" $ \v -> do pal <- v ..:? "palette" ..!= StructurePalette mempty structures <- v ..:? "structures" ..!= [] - liftE $ do - placements <- v .:? "placements" .!= [] - waypointDefs <- v .:? "waypoints" .!= [] - maybeMaskChar <- v .:? "mask" - rawGrid <- v .:? "map" .!= EmptyGrid - (maskedArea, mapWaypoints) <- paintMap maybeMaskChar pal rawGrid - let area = PositionedGrid origin maskedArea - waypoints = waypointDefs <> mapWaypoints - return Structure {..} + liftE $ parseStructure pal structures v -- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw -- string into a nested list of 'PCell' values by looking up each @@ -123,34 +98,51 @@ Maybe Char -> StructurePalette c -> Grid Char -> - m (Grid (Maybe c), [Waypoint]) + m (Grid (Maybe c), [Waypoint], [Placement]) paintMap maskChar pal g = do nestedLists <- mapM toCell g - let usedChars = Set.fromList $ map T.singleton $ allMembers g - unusedChars = - filter (`Set.notMember` usedChars) - . M.keys - . KeyMap.toMapText - $ unPalette pal + forM_ maskChar $ \c -> + unless (Set.notMember c paletteKeys) $ + fail $ + unwords + [ "Mask character" + , ['"', c, '"'] + , "overlaps palette entry" + ] - unless (null unusedChars) $ + unless (Set.null unusedPaletteChars) $ fail $ unwords [ "Unused characters in palette:" - , T.unpack $ T.intercalate ", " unusedChars + , intercalate ", " $ map pure $ Set.toList unusedPaletteChars ] let cells = fmap standardCell <$> nestedLists - getWp coords maybeAugmentedCell = do - wpCfg <- waypointCfg =<< maybeAugmentedCell - return . Waypoint wpCfg . coordsToLoc $ coords - wps = catMaybes $ mapIndexedMembers getWp nestedLists + wps = catMaybes $ mapWithCoords getWp nestedLists - return (cells, wps) + let extraPlacements = + catMaybes $ mapWithCoords getStructureMarker nestedLists + + return (cells, wps, extraPlacements) where + getStructureMarker coords maybeAugmentedCell = do + StructureMarker sName orientation <- structureMarker =<< maybeAugmentedCell + return + . Placement sName + . Pose (coordsToLoc coords) + $ fromMaybe defaultOrientation orientation + + getWp coords maybeAugmentedCell = do + wpCfg <- waypointCfg =<< maybeAugmentedCell + return . Waypoint wpCfg . coordsToLoc $ coords + + usedChars = Set.fromList $ allMembers g + paletteKeys = M.keysSet $ unPalette pal + unusedPaletteChars = Set.difference paletteKeys usedChars + toCell c = if Just c == maskChar then return Nothing - else case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of + else case M.lookup c (unPalette pal) of Nothing -> failT ["Char not in world palette:", showT c] Just cell -> return $ Just cell diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -7,6 +7,10 @@ -- as well as logic for combining them. module Swarm.Game.Scenario.Topography.Structure.Assembly ( mergeStructures, + makeStructureMap, + + -- * Exposed for unit tests: + foldLayer, ) where @@ -22,13 +26,15 @@ import Linear.Affine import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area -import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Scenario.Topography.Placement import Swarm.Game.Scenario.Topography.Structure +import Swarm.Game.Scenario.Topography.Structure.Named import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.Structure.Recognition.Static import Swarm.Language.Syntax.Direction (directionJsonModifier) import Swarm.Util (commaList, quote, showT) +import Swarm.Util.Graph -- | Destructively overlays one direct child structure -- upon the input structure. @@ -40,14 +46,14 @@ Either Text (MergedStructure (Maybe a)) overlaySingleStructure inheritedStrucDefs - (Placed p@(Placement _ pose@(Pose loc orientation)) ns) + (Placed p@(Placement _sName pose@(Pose loc orientation)) ns) (MergedStructure inputArea inputPlacements inputWaypoints) = do MergedStructure overlayArea overlayPlacements overlayWaypoints <- mergeStructures inheritedStrucDefs (WithParent p) $ structure ns let mergedWaypoints = inputWaypoints <> map (fmap $ placeOnArea overlayArea) overlayWaypoints mergedPlacements = inputPlacements <> map (placeOnArea overlayArea) overlayPlacements - mergedArea = overlayGridExpanded (gridContent inputArea) pose overlayArea + mergedArea = overlayGridExpanded inputArea pose overlayArea return $ MergedStructure mergedArea mergedPlacements mergedWaypoints where @@ -55,6 +61,18 @@ offsetLoc (coerce loc) . modifyLoc (reorientLandmark orientation $ getGridDimensions overArea) +makeStructureMap :: [NamedStructure a] -> M.Map StructureName (NamedStructure a) +makeStructureMap = M.fromList . map (name &&& id) + +type GraphEdge a = (NamedStructure a, StructureName, [StructureName]) + +makeGraphEdges :: [NamedStructure a] -> [GraphEdge a] +makeGraphEdges = + map makeGraphNodeWithEdges + where + makeGraphNodeWithEdges s = + (s, name s, map src $ placements $ structure s) + -- | Overlays all of the "child placements", such that the children encountered later -- in the YAML file supersede the earlier ones (dictated by using 'foldl' instead of 'foldr'). mergeStructures :: @@ -62,51 +80,66 @@ Parentage Placement -> PStructure (Maybe a) -> Either Text (MergedStructure (Maybe a)) -mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = do +mergeStructures inheritedStrucDefs parentPlacement baseStructure = do + failOnCyclicGraph "Structure" (getStructureName . name) gEdges + overlays <- left (elaboratePlacement parentPlacement <>) $ mapM (validatePlacement structureMap) subPlacements - let wrapPlacement (Placed z ns) = - LocatedStructure - (name ns) - (up $ orient structPose) - (offset structPose) - where - structPose = structurePose z + foldLayer structureMap origArea overlays originatedWaypoints + where + Structure origArea subStructures subPlacements subWaypoints = baseStructure - wrappedOverlays = - map wrapPlacement $ - filter (\(Placed _ ns) -> isRecognizable ns) overlays + originatedWaypoints = map (Originated parentPlacement) subWaypoints + -- deeper definitions override the outer (toplevel) ones + structureMap = M.union (makeStructureMap subStructures) inheritedStrucDefs + gEdges = makeGraphEdges $ M.elems structureMap + +-- | NOTE: Each successive overlay may alter the coordinate origin. +-- We make sure this new origin is propagated to subsequent sibling placements. +foldLayer :: + M.Map StructureName (NamedStructure (Maybe a)) -> + PositionedGrid (Maybe a) -> + [Placed (Maybe a)] -> + [Originated Waypoint] -> + Either Text (MergedStructure (Maybe a)) +foldLayer structureMap origArea overlays originatedWaypoints = foldlM (flip $ overlaySingleStructure structureMap) (MergedStructure origArea wrappedOverlays originatedWaypoints) overlays where - originatedWaypoints = map (Originated parentPlacement) subWaypoints + wrappedOverlays = + map wrapPlacement $ + filter (\(Placed _ ns) -> isRecognizable ns) overlays - -- deeper definitions override the outer (toplevel) ones - structureMap = - M.union - (M.fromList $ map (name &&& id) subStructures) - inheritedStrucDefs + wrapPlacement (Placed z ns) = + LocatedStructure + (OrientedStructure (name ns) (up $ orient structPose)) + (offset structPose) + where + structPose = structurePose z -- * Grid manipulation overlayGridExpanded :: - Grid (Maybe a) -> + PositionedGrid (Maybe a) -> Pose -> PositionedGrid (Maybe a) -> PositionedGrid (Maybe a) overlayGridExpanded - inputGrid - (Pose loc orientation) - (PositionedGrid _ overlayArea) = - PositionedGrid origin inputGrid <> positionedOverlay + baseGrid + (Pose yamlPlacementOffset orientation) + -- The 'childAdjustedOrigin' is the sum of origin adjustments + -- to completely assemble some substructure. + (PositionedGrid childAdjustedOrigin overlayArea) = + baseGrid <> positionedOverlay where reorientedOverlayCells = applyOrientationTransform orientation overlayArea - positionedOverlay = PositionedGrid loc reorientedOverlayCells + placementAdjustedByOrigin = childAdjustedOrigin .+^ asVector yamlPlacementOffset + positionedOverlay = PositionedGrid placementAdjustedByOrigin reorientedOverlayCells -- * Validation diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Named.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Named.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Named.hs @@ -0,0 +1,32 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Structure.Named where + +import Data.Set (Set) +import Data.Text (Text) +import Data.Yaml +import GHC.Generics (Generic) +import Swarm.Language.Syntax.Direction (AbsoluteDir) + +newtype StructureName = StructureName Text + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + +getStructureName :: StructureName -> Text +getStructureName (StructureName sn) = sn + +data NamedArea a = NamedArea + { name :: StructureName + , recognize :: Set AbsoluteDir + -- ^ whether this structure should be registered for automatic recognition + -- and which orientations shall be recognized. + -- The supplied direction indicates which cardinal direction the + -- original map's "North" has been re-oriented to. + -- E.g., 'DWest' represents a rotation of 90 degrees counter-clockwise. + , description :: Maybe Text + -- ^ will be UI-facing only if this is a recognizable structure + , structure :: a + } + deriving (Eq, Show, Functor, Foldable, Traversable) + +isRecognizable :: NamedArea a -> Bool +isRecognizable = not . null . recognize diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs @@ -6,13 +6,18 @@ -- Generic overlay operations on grids module Swarm.Game.Scenario.Topography.Structure.Overlay ( PositionedGrid (..), + + -- * Exported for unit tests + computeMergedArea, + OverlayPair (..), ) where import Control.Applicative +import Control.Lens (view) import Data.Function (on) import Data.Int (Int32) import Data.Tuple (swap) -import Linear +import Linear.V2 (R1 (_x), R2 (_y), V2 (..)) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Grid @@ -20,10 +25,15 @@ data PositionedGrid a = PositionedGrid { gridPosition :: Location + -- ^ location of the upper-left cell , gridContent :: Grid a } deriving (Eq) +instance HasLocation (PositionedGrid a) where + modifyLoc f (PositionedGrid originalLoc g) = + PositionedGrid (f originalLoc) g + instance Show (PositionedGrid a) where show (PositionedGrid p g) = unwords @@ -45,16 +55,27 @@ , _southeastCorner :: Location } +getNorthwesternExtent :: Location -> Location -> Location +getNorthwesternExtent ul1 ul2 = + Location westernMostX northernMostY + where + westernMostX = (min `on` view _x) ul1 ul2 + northernMostY = (max `on` view _y) ul1 ul2 + +getSoutheasternExtent :: Location -> Location -> Location +getSoutheasternExtent br1 br2 = + Location easternMostX southernMostY + where + easternMostX = (max `on` view _x) br1 br2 + southernMostY = (min `on` view _y) br1 br2 + -- | @r1 <> r2@ is the smallest rectangle that contains both @r1@ and @r2@. instance Semigroup SubsumingRect where - SubsumingRect (Location ulx1 uly1) (Location brx1 bry1) - <> SubsumingRect (Location ulx2 uly2) (Location brx2 bry2) = - SubsumingRect (Location westernMostX northernMostY) (Location easternMostX southernMostY) - where - westernMostX = min ulx1 ulx2 - northernMostY = max uly1 uly2 - easternMostX = max brx1 brx2 - southernMostY = min bry1 bry2 + SubsumingRect ul1 br1 <> SubsumingRect ul2 br2 = + SubsumingRect northwesternExtent southeasternExtent + where + northwesternExtent = getNorthwesternExtent ul1 ul2 + southeasternExtent = getSoutheasternExtent br1 br2 getSubsumingRect :: PositionedGrid a -> SubsumingRect getSubsumingRect (PositionedGrid loc g) = @@ -74,7 +95,7 @@ zipGridRows dims (OverlayPair paddedBaseRows paddedOverlayRows) = mkGrid $ (pad2D paddedBaseRows . pad2D paddedOverlayRows) blankGrid where - -- Right-bias; that is, take the last non-empty value + -- Right-biased; that is, takes the last non-empty value pad2D = zipPadded $ zipPadded $ flip (<|>) blankGrid = getRows $ fillGrid dims empty @@ -95,40 +116,45 @@ -- of the base layer. instance (Alternative f) => Semigroup (PositionedGrid (f a)) where a1@(PositionedGrid baseLoc baseGrid) <> a2@(PositionedGrid overlayLoc overlayGrid) = - PositionedGrid newOrigin combinedGrid + PositionedGrid newUpperLeftCornerPosition combinedGrid where mergedSize = computeMergedArea $ OverlayPair a1 a2 combinedGrid = zipGridRows mergedSize paddedOverlayPair - -- We subtract the base origin from the - -- overlay position, such that the displacement vector - -- will have: + -- We create a vector from the overlay position, + -- such that the displacement vector will have: -- \* negative X component if the origin must be shifted east -- \* positive Y component if the origin must be shifted south - originDelta@(V2 deltaX deltaY) = overlayLoc .-. baseLoc - -- Note that the adjustment vector will only ever have - -- a non-negative X component (i.e. loc of upper-left corner must be shifted east) and - -- a non-positive Y component (i.e. loc of upper-left corner must be shifted south). - -- We don't have to adjust the origin if the base layer lies - -- to the northwest of the overlay layer. - clampedDelta = V2 (min 0 deltaX) (max 0 deltaY) - newOrigin = baseLoc .-^ clampedDelta + upperLeftCornersDelta = overlayLoc .-. baseLoc + newUpperLeftCornerPosition = getNorthwesternExtent baseLoc overlayLoc + paddedOverlayPair = - padSouthwest originDelta $ + padNorthwest upperLeftCornersDelta $ OverlayPair baseGrid overlayGrid --- | NOTE: We only make explicit grid adjustments for +-- | +-- 'deltaX' and 'deltaY' refer to the positioning of the *overlay grid* +-- relative to the *base grid*. +-- A negative 'deltaY' means that the top edge of the overlay +-- lies to the south of the top edge of the base grid. +-- A positive 'deltaX' means that the left edge of the overlay +-- lies to the east of the left edge of base grid. +-- +-- We add padding to either the overlay grid or the base grid +-- so as to align their upper-left corners. +-- +-- NOTE: We only make explicit grid adjustments for -- left/top padding. Any padding that is needed on the right/bottom -- of either grid will be taken care of by the 'zipPadded' function. -- -- TODO(#2004): The return type should be 'Grid'. -padSouthwest :: +padNorthwest :: Alternative f => V2 Int32 -> OverlayPair (Grid (f a)) -> OverlayPair [[f a]] -padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) = +padNorthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) = OverlayPair paddedBaseGrid paddedOverlayGrid where prefixPadDimension delta f = f (padding <>) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs @@ -4,23 +4,24 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Public interface for structure recognizer. +-- +-- Note that we only support "recognition" of structures defined at the +-- scenario-global level. module Swarm.Game.Scenario.Topography.Structure.Recognition where import Control.Lens import GHC.Generics (Generic) import Swarm.Game.Scenario.Topography.Structure.Recognition.Log import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -- | -- The type parameters, `b`, and `a`, correspond --- to 'StructureCells' and 'Entity', respectively. -data StructureRecognizer b a = StructureRecognizer - { _automatons :: RecognizerAutomatons b a - , _foundStructures :: FoundRegistry b a +-- to 'Cell' and 'Entity', respectively. +data RecognitionState b a = RecognitionState + { _foundStructures :: FoundRegistry b a -- ^ Records the top-left corner of the found structure , _recognitionLog :: [SearchLog a] } deriving (Generic) -makeLenses ''StructureRecognizer +makeLenses ''RecognitionState diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs @@ -5,58 +5,69 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Log where import Data.Aeson -import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty.Extra qualified as NE import GHC.Generics (Generic) import Servant.Docs (ToSample) import Servant.Docs qualified as SD import Swarm.Game.Location (Location) +import Swarm.Game.Scenario.Topography.Structure.Named (StructureName, name) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Static ( + OrientedStructure, + ) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.Universe (Cosmic) +import Swarm.Language.Syntax.Direction (AbsoluteDir) -type StructureRowContent e = [Maybe e] -type WorldRowContent e = [Maybe e] +renderSharedNames :: ConsolidatedRowReferences b a -> NonEmpty StructureName +renderSharedNames = + NE.nubOrd . NE.map (name . originalItem . entityGrid . wholeStructure) . referencingRows -data MatchingRowFrom = MatchingRowFrom - { rowIdx :: Int32 - , structure :: OriginalName +data ParticipatingEntity e = ParticipatingEntity + { entity :: e + , searchOffsets :: InspectionOffsets } - deriving (Generic, ToJSON) - -newtype HaystackPosition = HaystackPosition Int - deriving (Generic, ToJSON) + deriving (Functor, Generic, ToJSON) -data HaystackContext e = HaystackContext - { worldRow :: WorldRowContent e - , haystackPosition :: HaystackPosition +data IntactPlacementLog e = IntactPlacementLog + { intactnessFailure :: Maybe (StructureIntactnessFailure e) + , placedStructure :: PositionedStructure OrientedStructure } deriving (Functor, Generic, ToJSON) -data FoundRowCandidate e = FoundRowCandidate - { haystackContext :: HaystackContext e - , structureContent :: StructureRowContent e - , rowCandidates :: [MatchingRowFrom] - } +data ChunkMatchFailureReason e + = ChunkMatchFailureReason (NonEmpty StructureName) (RowMismatchReason e) deriving (Functor, Generic, ToJSON) -data ParticipatingEntity e = ParticipatingEntity - { entity :: e - , searchOffsets :: InspectionOffsets +data FoundChunkComparison e = FoundChunkComparison + { foundChunkKeys :: [NonEmpty e] + , referenceChunkKeys :: [NonEmpty e] } deriving (Functor, Generic, ToJSON) -data IntactPlacementLog = IntactPlacementLog - { isIntact :: Bool - , sName :: OriginalName - , locUpperLeft :: Cosmic Location - } - deriving (Generic, ToJSON) +data RowMismatchReason e + = NoKeysSubset (FoundChunkComparison e) + | -- | NOTE: we should never see 'EmptyIntersection', + -- since the earlier 'NoKeysSubset' condition + -- results in an empty intersection + EmptyIntersection + deriving (Functor, Generic, ToJSON) data SearchLog e - = FoundParticipatingEntity (ParticipatingEntity e) - | StructureRemoved OriginalName - | FoundRowCandidates [FoundRowCandidate e] - | FoundCompleteStructureCandidates [OriginalName] - | IntactStaticPlacement [IntactPlacementLog] + = IntactStaticPlacement [IntactPlacementLog e] + | StartSearchAt (Cosmic Location) InspectionOffsets + | FoundParticipatingEntity (ParticipatingEntity e) + | FoundCompleteStructureCandidates [(OrientedStructure, Cosmic Location)] + | RecognizedSingleStructure (OrientedStructure, Cosmic Location) + | -- | this is actually internally used as a (Map (NonEmpty e) (NonEmpty Int)), + -- but the requirements of Functor force us to invert the mapping + FoundPiecewiseChunks [(NonEmpty Int, NonEmpty e)] + | ExpectedChunks (NonEmpty [NonEmpty e]) + | WorldRowContent [Maybe e] + | ChunksMatchingExpected [ChunkedRowMatch (NonEmpty StructureName) e] + | ChunkFailures [ChunkMatchFailureReason e] + | ChunkIntactnessVerification (IntactPlacementLog e) + | StructureRemoved StructureName deriving (Functor, Generic) instance (ToJSON e) => ToJSON (SearchLog e) where @@ -71,7 +82,7 @@ instance ToSample (SearchLog e) where toSamples _ = SD.noSamples -data StructureLocation = StructureLocation OriginalName (Cosmic Location) +data StructureLocation = StructureLocation StructureName (Cosmic Location, AbsoluteDir) deriving (Generic, ToJSON) instance ToSample StructureLocation where diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs @@ -0,0 +1,190 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Precomputation for structure recognizer. +-- +-- = Search process overview +-- +-- 2D structures may be defined at the +-- . +-- Upon scenario load, all of the predefined structures that are marked +-- as @"recognize"@ are compiled into searcher state machines. +-- +-- When an entity is placed on any cell in the world, the +-- 'Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking.entityModified' +-- function is called, which looks up a customized searcher based +-- on the type of placed entity. +-- +-- The first searching stage looks for any member row of all participating +-- structure definitions that contains the placed entity. +-- If we observe a row in the world that happens to occur in a structure, we use both +-- the horizontal found offset and the index of the row within this structure to compute +-- the expected world location of the candidate structure. +-- Then we perform a full scan of that candidate structure against the world to verify +-- the match. +-- +-- Upon locating a complete structure, it is added to a registry +-- (see 'Swarm.Game.Scenario.Topography.Structure.Recognition.Registry.FoundRegistry'), which +-- supports lookups by either name or by location (using two different +-- maps maintained in parallel). The map by location is used to remove +-- a structure from the registry if a member entity is changed. +module Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute ( + -- * Main external interface + mkAutomatons, + + -- * Types + GenericEntLocator, + + -- * Helper functions + populateStaticFoundStructures, + lookupStaticPlacements, + ensureStructureIntact, +) where + +import Control.Arrow ((&&&)) +import Control.Lens ((^.)) +import Control.Monad (forM_, unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (except, runExceptT) +import Data.Either.Combinators (leftToMaybe) +import Data.Hashable (Hashable) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (catMaybes, mapMaybe) +import Data.Set qualified as Set +import Data.Tuple (swap) +import Data.Tuple.Extra (dupe) +import Swarm.Game.Location (Location, asVector) +import Swarm.Game.Scenario.Topography.Area (getNEGridDimensions, rectWidth) +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransformNE) +import Swarm.Game.Scenario.Topography.Structure.Named +import Swarm.Game.Scenario.Topography.Structure.Recognition.Prep ( + mkEntityLookup, + ) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry ( + FoundRegistry, + foundByLocation, + populateStaticFoundStructures, + ) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Static +import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Universe (Cosmic (..), offsetBy, planar) +import Swarm.Game.World.Coords (coordsToLoc) +import Swarm.Language.Syntax.Direction (AbsoluteDir) +import Swarm.Util (histogram) + +-- | Interface that provides monadic access to +-- querying entities at locations. +-- The provider may be a 'State' monad or just +-- a 'Reader'. +-- +-- 's' is the state variable, 'a' is the return type. +type GenericEntLocator s a = Cosmic Location -> s (AtomicKeySymbol a) + +-- | Create Aho-Corasick matchers that will recognize all of the +-- provided structure definitions +mkAutomatons :: + (Ord a, Hashable a) => + (b -> NonEmptyGrid (AtomicKeySymbol a)) -> + [NamedArea b] -> + Either RedundantOrientations (RecognizerAutomatons b a) +mkAutomatons extractor rawGrids = do + onlyNonempties <- mapM checkSymmetry extractedItems + let rotatedGrids = concatMap (extractGrids . grid) onlyNonempties + infos = + M.fromList $ + map ((name . originalItem . grid . annotatedGrid &&& id) . process) onlyNonempties + return $ + RecognizerAutomatons + infos + (mkEntityLookup rotatedGrids) + where + extractedItems = map (uncurry ExtractedArea . fmap (extractor . structure) . dupe) rawGrids + + process g = StructureInfo g entGrid countsMap + where + entGrid = extractedGrid $ grid g + countsMap = histogram . catMaybes . NE.toList $ allMembersNE entGrid + +extractOrientedGrid :: + ExtractedArea b a -> + AbsoluteDir -> + StructureWithGrid b a +extractOrientedGrid (ExtractedArea x neGrid) d = + StructureWithGrid d w $ + ExtractedArea x $ + applyOrientationTransformNE (Orientation d False) neGrid + where + w = RowWidth . rectWidth . getNEGridDimensions $ neGrid + +-- | +-- At this point, we have already ensured that orientations +-- redundant by rotational symmetry have been excluded +-- (i.e. at Scenario validation time). +extractGrids :: + ExtractedArea b a -> + [StructureWithGrid b a] +extractGrids x = + map (extractOrientedGrid x) orientations + where + orientations = Set.toList $ recognize $ originalItem x + +-- | The output list of 'FoundStructure' records is not yet +-- vetted; the 'ensureStructureIntact' function will subsequently +-- filter this list. +lookupStaticPlacements :: + StaticStructureInfo b a -> + [FoundStructure b a] +lookupStaticPlacements (StaticStructureInfo theAutomatons thePlacements) = + concatMap f $ M.toList thePlacements + where + definitionMap = theAutomatons ^. originalStructureDefinitions + + f (subworldName, locatedList) = mapMaybe g locatedList + where + g (LocatedStructure (OrientedStructure theName d) loc) = do + sGrid <- M.lookup theName definitionMap + return $ + PositionedStructure (Cosmic subworldName loc) $ + extractOrientedGrid (grid $ annotatedGrid sGrid) d + +-- | Matches definitions against the placements. +-- Fails fast (short-circuits) if a non-matching +-- cell is encountered. +-- +-- Returns 'Nothing' if there is no discrepancy between the match subject and world content. +-- Returns the first observed mismatch cell otherwise. +ensureStructureIntact :: + (Monad s, Hashable a) => + FoundRegistry b a -> + GenericEntLocator s a -> + FoundStructure b a -> + s (Maybe (StructureIntactnessFailure a)) +ensureStructureIntact registry entLoader (PositionedStructure upperLeft (StructureWithGrid _ _ (ExtractedArea _ g))) = do + fmap leftToMaybe . runExceptT $ mapM checkLoc allLocPairs + where + gridArea = getNEGridDimensions g + checkLoc (maybeTemplateEntity, loc) = + forM_ maybeTemplateEntity $ \x -> do + e <- lift $ entLoader loc + + forM_ (M.lookup loc $ foundByLocation registry) $ \s -> + errorPrefix + . AlreadyUsedBy + . distillLabel + $ structureWithGrid s + + unless (e == Just x) + . errorPrefix + $ DiscrepantEntity + $ EntityDiscrepancy x e + where + errorPrefix = + except + . Left + . StructureIntactnessFailure (loc ^. planar) gridArea + + f = fmap ((upperLeft `offsetBy`) . asVector . coordsToLoc) . swap + allLocPairs = mapWithCoordsNE (curry f) g diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs @@ -1,56 +1,53 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Game.Scenario.Topography.Structure.Recognition.Prep (mkEntityLookup) where +module Swarm.Game.Scenario.Topography.Structure.Recognition.Prep ( + mkEntityLookup, + binTuplesHM, +) where import Control.Arrow ((&&&)) +import Control.Lens.Indexed (imap) import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Data.Hashable (Hashable) import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE -import Data.Maybe (catMaybes) +import Data.List.Split (wordsBy) +import Data.Maybe (catMaybes, mapMaybe) import Data.Semigroup (sconcat) import Data.Tuple (swap) +import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -import Text.AhoCorasick +import Text.AhoCorasick (makeStateMachine) +-- | Given all candidate structures, explode them into annotated rows. +-- These annotations entail both the row index with the original structure +-- and a reference to the original structure definition. +-- +-- This operation may result in multiple entries that contain the same contents +-- (but different annotations), either because the same contents appear +-- in multiple rows within the same structure, or occur across structures. allStructureRows :: [StructureWithGrid b a] -> [StructureRow b a] allStructureRows = - concatMap transformRows + concatMap $ NE.toList . transformRows where - transformRows :: StructureWithGrid b a -> [StructureRow b a] - transformRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g - -mkOffsets :: Foldable f => Int32 -> f a -> InspectionOffsets -mkOffsets pos xs = - InspectionOffsets (pure (negate pos)) $ - pure $ - fromIntegral (length xs) - 1 - pos + transformRows g = imap (StructureRow g . fromIntegral) rows + where + NonEmptyGrid rows = extractedGrid $ entityGrid g --- | Given each possible row of entities observed in the world, --- yield a searcher that can determine whether adjacent --- rows constitute a complete structure. -mkRowLookup :: - (Hashable a, Eq a) => - NE.NonEmpty (StructureRow b a) -> - AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a) -mkRowLookup neList = - AutomatonInfo participatingEnts bounds sm +-- | If this entity is encountered in the world, +-- how far left of it and how far right of it do we need to +-- scan the world row to ensure we can recognize every possible +-- structure that features this entity? +mkOffsets :: Int32 -> RowWidth -> InspectionOffsets +mkOffsets pos (RowWidth w) = + InspectionOffsets + (subtractPosFrom 0) + (subtractPosFrom rightMostShapeRowIndex) where - mkSmTuple = entityGrid &&& id - tuples = NE.toList $ NE.map (mkSmTuple . wholeStructure) neList - - -- All of the unique entities across all of the full candidate structures - participatingEnts = - HS.fromList $ - concatMap (concatMap catMaybes . fst) tuples - - deriveRowOffsets :: StructureRow b a -> InspectionOffsets - deriveRowOffsets (StructureRow (StructureWithGrid _ _ g) rwIdx _) = - mkOffsets rwIdx g - - bounds = sconcat $ NE.map deriveRowOffsets neList - sm = makeStateMachine tuples + subtractPosFrom minuend = pure $ minuend - pos + rightMostShapeRowIndex = w - 1 -- | Make the first-phase lookup map, keyed by 'Entity', -- along with automatons whose key symbols are "Maybe Entity". @@ -58,64 +55,107 @@ -- Each automaton in this first layer will attempt to match the -- underlying world row against all rows within all structures -- (so long as they contain the keyed entity). +-- +-- = Preparation steps +-- +-- 1. Consolidate all identical rows across all structures into a map +-- 2. Consolidate all entities across these rows into an entity-keyed lookup map +-- 3. Extract the contiguous chunks from each unique row +-- 4. Put the expected indices of these chunks into a lookup structure +-- 5. Prepare Aho-Corasick state machines for recognizing these chunks mkEntityLookup :: (Hashable a, Eq a) => [StructureWithGrid b a] -> - HM.HashMap a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a)) + HM.HashMap a (AutomatonInfo b a) mkEntityLookup grids = - HM.map mkValues rowsByEntityParticipation + HM.map mkRowAutomatons rowsByEntityParticipation where - rowsAcrossAllStructures = allStructureRows grids - - -- The input here are all rows across all structures - -- that share the same entity sequence. - mkSmValue ksms singleRows = - StructureSearcher sm2D ksms singleRows + -- Produces an automaton to evaluate whenever a given entity + -- is encountered. + mkRowAutomatons neList = + AutomatonInfo bounds $ + PiecewiseRecognition chunksStateMachine extractedChunksForLookup where - structureRowsNE = NE.map myRow singleRows - sm2D = mkRowLookup structureRowsNE + bounds = sconcat $ NE.map expandedOffsets neList - mkValues neList = AutomatonInfo participatingEnts bounds sm - where - participatingEnts = - HS.fromList - (concatMap (catMaybes . fst) tuples) + -- Prepare lookup structure for use with results of the + -- Aho-Corasick matcher. + extractedChunksForLookup = NE.map f neList + where + f x = RowChunkMatchingReference (myRow x) (mkRightMap x) + mkRightMap = binTuplesHM . map (chunkContents &&& chunkStartPos) . contiguousChunks - tuples = HM.toList $ HM.mapWithKey mkSmValue groupedByUniqueRow + extractedChunksForStateMachine = + HS.fromList . concat . NE.toList $ + NE.map (map chunkContents . contiguousChunks) neList - groupedByUniqueRow = binTuplesHM $ NE.toList $ NE.map (rowContent . myRow &&& id) neList - bounds = sconcat $ NE.map expandedOffsets neList - sm = makeStateMachine tuples + -- We wrap the entities with 'Just' since the Aho-Corasick + -- matcher needs to compare against world cells, which are of 'Maybe' type. + chunksStateMachine = + makeStateMachine $ + map (NE.toList . fmap Just &&& id) $ + HS.toList extractedChunksForStateMachine -- The values of this map are guaranteed to contain only one - -- entry per row of a given structure. + -- entry per row of each structure, even if some of those + -- rows contain repetition of the same entity. rowsByEntityParticipation = - binTuplesHM $ - map (myEntity &&& id) $ - concatMap explodeRowEntities rowsAcrossAllStructures + binTuplesHM + . map (myEntity &&& id) + . concatMap explodeRowEntities + $ structureRowsByContent - deriveEntityOffsets :: PositionWithinRow b a -> InspectionOffsets - deriveEntityOffsets (PositionWithinRow pos r) = - mkOffsets pos $ rowContent r + -- Consolidate all identical rows, whether those rows appear in + -- same structure or a different structures. + structureRowsByContent = + map (\(x, y) -> ConsolidatedRowReferences x y . gridWidth . wholeStructure $ NE.head y) + . HM.toList + . binTuplesHM + . map (rowContent &&& id) + $ allStructureRows grids - -- The members of "rowMembers" are of 'Maybe' type; the 'Nothing's - -- are dropped but accounted for when indexing the columns. - explodeRowEntities :: - (Hashable a, Eq a) => - StructureRow b a -> - [SingleRowEntityOccurrences b a] - explodeRowEntities r@(StructureRow _ _ rowMembers) = - map f $ HM.toList $ binTuplesHM unconsolidated - where - f (e, occurrences) = - SingleRowEntityOccurrences r e occurrences $ - sconcat $ - NE.map deriveEntityOffsets occurrences - unconsolidated = - map swap $ - catMaybes $ - zipWith (\idx -> fmap (PositionWithinRow idx r,)) [0 ..] rowMembers +-- | Utilizes the convenient 'wordsBy' function +-- from the "split" package. +getContiguousChunks :: SymbolSequence a -> [PositionedChunk a] +getContiguousChunks rowMembers = + map mkChunk + . mapMaybe (NE.nonEmpty . mapMaybe sequenceA) + . wordsBy (null . snd) + $ zip [0 :: Int ..] rowMembers + where + mkChunk xs = PositionedChunk (fst $ NE.head xs) (NE.map snd xs) +-- | All of the occurrences of each unique entity within a row +-- are consolidated into one record, in which the repetitions are noted. +-- +-- The members of "rowMembers" are of 'Maybe' type; the 'Nothing's +-- are dropped but accounted for positionally when indexing the columns. +explodeRowEntities :: + (Hashable a, Eq a) => + ConsolidatedRowReferences b a -> + [SingleRowEntityOccurrences b a] +explodeRowEntities annotatedRow@(ConsolidatedRowReferences rowMembers _ width) = + map f $ HM.toList $ binTuplesHM unconsolidatedEntityOccurrences + where + chunks = getContiguousChunks $ NE.toList rowMembers + + f (e, occurrences) = + SingleRowEntityOccurrences annotatedRow e chunks $ + sconcat $ + NE.map deriveEntityOffsets occurrences + + -- Tuples of (entity, rowOccurrenceOfEntity). + -- Only row members for which an entity exists (is not Nothing) + -- are retained here. + unconsolidatedEntityOccurrences = + map swap + . catMaybes + . NE.toList + $ imap (\idx -> fmap (PositionWithinRow (fromIntegral idx) annotatedRow,)) rowMembers + + deriveEntityOffsets :: PositionWithinRow b a -> InspectionOffsets + deriveEntityOffsets (PositionWithinRow pos _) = mkOffsets pos width + -- * Util -- | Place the second element of the tuples into bins by @@ -123,7 +163,7 @@ binTuplesHM :: (Foldable t, Hashable a, Eq a) => t (a, b) -> - HM.HashMap a (NE.NonEmpty b) + HM.HashMap a (NonEmpty b) binTuplesHM = foldr f mempty where f = uncurry (HM.insertWith (<>)) . fmap pure diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs @@ -22,22 +22,28 @@ where import Control.Arrow ((&&&)) +import Data.List (partition, sortOn) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M import Data.Map.NonEmpty (NEMap) import Data.Map.NonEmpty qualified as NEM -import Swarm.Game.Location (Location) +import Data.Maybe (listToMaybe, maybeToList) +import Data.Ord (Down (Down)) +import Data.Set qualified as Set +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Structure.Named (StructureName, name) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -import Swarm.Game.Universe (Cosmic) +import Swarm.Game.Universe (Cosmic (..)) +import Swarm.Language.Syntax.Direction (AbsoluteDir (..)) import Swarm.Util (binTuples, deleteKeys) -- | The authoritative source of which built structures currently exist. -- -- The two type parameters, `b` and `a`, correspond --- to 'StructureCells' and 'Entity', respectively. +-- to 'Cell' and 'Entity', respectively. data FoundRegistry b a = FoundRegistry - { _foundByName :: Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a)) + { _foundByName :: Map StructureName (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)) , _foundByLocation :: Map (Cosmic Location) (FoundStructure b a) } @@ -47,7 +53,7 @@ -- | We use a 'NEMap' here so that we can use the -- safe-indexing function 'indexWrapNonEmpty' in the implementation -- of the @structure@ command. -foundByName :: FoundRegistry b a -> Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a)) +foundByName :: FoundRegistry b a -> Map StructureName (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)) foundByName = _foundByName -- | This is a worldwide "mask" that prevents members of placed @@ -65,34 +71,72 @@ (deleteKeys allOccupiedCoords byLoc) where allOccupiedCoords = genOccupiedCoords fs - structureName = getName $ originalDefinition $ structureWithGrid fs + structureName = name . originalItem . entityGrid $ structureWithGrid fs upperLeft = upperLeftCorner fs + rotation = rotatedTo $ structureWithGrid fs -- NOTE: Observe similarities to -- Swarm.Game.State.removeRobotFromLocationMap - tidyDelete = NEM.nonEmptyMap . NEM.delete upperLeft + tidyDelete = NEM.nonEmptyMap . NEM.delete (upperLeft, rotation) addFound :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a -addFound fs@(FoundStructure swg loc) (FoundRegistry byName byLoc) = +addFound fs@(PositionedStructure loc swg) (FoundRegistry byName byLoc) = FoundRegistry - (M.insertWith (<>) k (NEM.singleton loc swg) byName) + (M.insertWith (<>) k (NEM.singleton (loc, rotatedTo swg) swg) byName) (M.union occupationMap byLoc) where - k = getName $ originalDefinition swg + k = name . originalItem $ entityGrid swg occupationMap = M.fromList $ map (,fs) $ genOccupiedCoords fs --- | Bulk insertion of found structures. +-- | Bulk insertion of structures statically placed in the scenario definition. -- --- Each of these shall have been re-checked in case --- a subsequent placement occludes them. -populateStaticFoundStructures :: [FoundStructure b a] -> FoundRegistry b a +-- See the docs for 'Swarm.Game.State.Initialize.initializeRecognition' for more context. +-- +-- Note that if any of these pre-placed structures overlap, we can't be sure of +-- the author's intent as to which member of the overlap should take precedence, +-- so perhaps it would be ideal to throw an error at scenario parse time. +-- +-- However, determining whether a structure is all three of: +-- 1. placed +-- 2. still recognizable +-- 3. overlapping with another recognized structure +-- occurs at a later phase than scenario parse; it requires access to the 'GameState'. +-- +-- So we just use the same sorting criteria as the one used to resolve recognition +-- conflicts at entity placement time (see [STRUCTURE RECOGNIZER CONFLICT RESOLUTION]). +populateStaticFoundStructures :: + (Eq a, Eq b) => + [FoundStructure b a] -> + FoundRegistry b a populateStaticFoundStructures allFound = FoundRegistry byName byLocation where + resolvedCollisions = resolvePreplacementCollisions allFound + mkOccupationMap fs = M.fromList $ map (,fs) $ genOccupiedCoords fs - byLocation = M.unions $ map mkOccupationMap allFound + byLocation = M.unions $ map mkOccupationMap resolvedCollisions byName = - M.map (NEM.fromList . NE.map (upperLeftCorner &&& structureWithGrid)) $ + M.map (NEM.fromList . NE.map ((upperLeftCorner &&& rotatedTo . structureWithGrid) &&& structureWithGrid)) $ binTuples $ - map (getName . originalDefinition . structureWithGrid &&& id) allFound + map (name . originalItem . entityGrid . structureWithGrid &&& id) resolvedCollisions + + resolvePreplacementCollisions foundList = + nonOverlappingFound <> maybeToList (listToMaybe overlapsByDecreasingPreference) + where + overlapsByDecreasingPreference = sortOn Down overlappingFound + + (overlappingFound, nonOverlappingFound) = + partition ((`Set.member` overlappingPlacements) . fmap distillLabel) foundList + + -- We convert the full-fledged FoundStructure record + -- to a less-expensive identity-preserving form + -- for the purpose of set membership + overlappingPlacements = + Set.fromList + . map (fmap distillLabel) + . concatMap NE.toList + . M.elems + . M.filter ((> 1) . NE.length) + . M.unionsWith (<>) + $ map (M.map pure . mkOccupationMap) foundList diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Static.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Static.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Static.hs @@ -0,0 +1,44 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Structure.Recognition.Static where + +import Data.Aeson (ToJSON) +import GHC.Generics (Generic) +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Structure.Named +import Swarm.Language.Syntax.Direction (AbsoluteDir) + +data RotationalSymmetry + = -- | Aka 1-fold symmetry + NoSymmetry + | -- | Equivalent under rotation by 180 degrees + TwoFold + | -- | Equivalent under rotation by 90 degrees + FourFold + deriving (Show, Eq) + +data SymmetryAnnotatedGrid a = SymmetryAnnotatedGrid + { symmetry :: RotationalSymmetry + , grid :: a + } + deriving (Show, Functor, Foldable, Traversable) + +data OrientedStructure = OrientedStructure + { oName :: StructureName + , oDir :: AbsoluteDir + } + deriving (Show, Eq, Ord, Generic, ToJSON) + +-- | For use in registering recognizable pre-placed structures. +-- +-- Compare to +-- 'Swarm.Game.Scenario.Topography.Structure.Recognition.Type.PositionedStructure'. +data LocatedStructure = LocatedStructure + { placedStruct :: OrientedStructure + , cornerLoc :: Location + } + deriving (Show) + +instance HasLocation LocatedStructure where + modifyLoc f (LocatedStructure x originalLoc) = + LocatedStructure x $ f originalLoc diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs @@ -6,17 +6,37 @@ -- Symmetry analysis for structure recognizer. module Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry where -import Control.Monad (unless, when) +import Control.Monad (forM_, when) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE import Data.Map qualified as M +import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as T -import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform) -import Swarm.Game.Scenario.Topography.Structure (NamedGrid) -import Swarm.Game.Scenario.Topography.Structure qualified as Structure -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (RotationalSymmetry (..), SymmetryAnnotatedGrid (..)) -import Swarm.Language.Syntax.Direction (AbsoluteDir (DSouth, DWest), getCoordinateOrientation) -import Swarm.Util (commaList, failT, histogram, showT) +import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransformNE) +import Swarm.Game.Scenario.Topography.Structure.Named (recognize) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Static (RotationalSymmetry (..), SymmetryAnnotatedGrid (..)) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Language.Syntax.Direction (AbsoluteDir (DSouth, DWest), CoordinateOrientation, getCoordinateOrientation) +import Swarm.Util (commaList, histogram, showT) +data RedundantOrientations + = TwoFoldRedundancy (NonEmpty CoordinateOrientation) + | FourFoldRedundancy (Set AbsoluteDir) + +renderRedundancy :: RedundantOrientations -> T.Text +renderRedundancy = \case + TwoFoldRedundancy redundantOrientations -> + T.unwords + [ "Redundant" + , commaList $ map showT $ NE.toList redundantOrientations + , "orientations supplied with two-fold symmetry." + ] + FourFoldRedundancy _xs -> + T.unwords + [ "Redundant orientations supplied; with four-fold symmetry, just supply 'north'." + ] + -- | Warns if any recognition orientations are redundant -- by rotational symmetry. -- We can accomplish this by testing only two rotations: @@ -29,23 +49,17 @@ -- 2-fold symmetry. -- Warn if two opposite orientations were supplied. checkSymmetry :: - (MonadFail m, Eq a) => NamedGrid a -> m (SymmetryAnnotatedGrid (NamedGrid a)) -checkSymmetry ng = do + Eq a => + ExtractedArea b a -> + Either RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a)) +checkSymmetry x@(ExtractedArea origObject originalRows) = do case symmetryType of FourFold -> - when (Set.size suppliedOrientations > 1) - . failT - . pure - $ T.unwords ["Redundant orientations supplied; with four-fold symmetry, just supply 'north'."] + when (Set.size suppliedOrientations > 1) . Left $ + FourFoldRedundancy suppliedOrientations TwoFold -> - unless (null redundantOrientations) - . failT - . pure - $ T.unwords - [ "Redundant" - , commaList $ map showT redundantOrientations - , "orientations supplied with two-fold symmetry." - ] + forM_ (NE.nonEmpty redundantOrientations) $ + Left . TwoFoldRedundancy where redundantOrientations = map fst @@ -56,15 +70,14 @@ $ Set.toList suppliedOrientations _ -> return () - return $ SymmetryAnnotatedGrid ng symmetryType + return $ SymmetryAnnotatedGrid symmetryType x where symmetryType | quarterTurnRows == originalRows = FourFold | halfTurnRows == originalRows = TwoFold | otherwise = NoSymmetry - quarterTurnRows = applyOrientationTransform (Orientation DWest False) originalRows - halfTurnRows = applyOrientationTransform (Orientation DSouth False) originalRows + quarterTurnRows = applyOrientationTransformNE (Orientation DWest False) originalRows + halfTurnRows = applyOrientationTransformNE (Orientation DSouth False) originalRows - suppliedOrientations = Structure.recognize ng - originalRows = Structure.structure ng + suppliedOrientations = recognize origObject diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs @@ -0,0 +1,372 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Online operations for structure recognizer. +-- +-- See "Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute" for +-- details of the structure recognition process. +module Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking ( + RecognitionActiveStatus (..), + entityModified, + entityModifiedLoggable, +) where + +import Control.Arrow (left, (&&&)) +import Control.Lens ((%~), (&), (.~), (^.)) +import Control.Monad (foldM, forM_, guard, unless) +import Control.Monad.Extra (findM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Control.Monad.Trans.Writer.Strict +import Data.Either (partitionEithers) +import Data.Either.Extra (maybeToEither) +import Data.Function (on) +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Hashable (Hashable) +import Data.IntSet qualified as IS +import Data.IntSet.NonEmpty (NEIntSet) +import Data.IntSet.NonEmpty qualified as NEIS +import Data.List (sortOn) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Ord (Down (..)) +import Data.Semigroup (Max (..), Min (..)) +import Data.Tuple (swap) +import Linear (V2 (..)) +import Swarm.Game.Location (Location) +import Swarm.Game.Scenario.Topography.Structure.Named (name) +import Swarm.Game.Scenario.Topography.Structure.Recognition +import Swarm.Game.Scenario.Topography.Structure.Recognition.Log +import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (GenericEntLocator, ensureStructureIntact) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Prep (binTuplesHM) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Terraform +import Swarm.Game.Universe +import Text.AhoCorasick + +data RecognitionActiveStatus + = RecognizeNewStructures + | -- | Do not add new recognitions to the registry. + -- This is useful if one needs to construct a larger structure + -- for which other smaller structures contained within it + -- would otherwise be recognized first, precluding the larger + -- structure from ever being recognized. + -- Removing elements of a previously recognized structure + -- will still cause it to be removed from the registry. + DisableNewRecognition + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | A hook called from the centralized entity update function, +-- 'Swarm.Game.Step.Util.updateEntityAt'. +entityModified :: + (Monad s, Hashable a, Eq b) => + GenericEntLocator s a -> + CellModification a -> + Cosmic Location -> + RecognizerAutomatons b a -> + RecognitionState b a -> + s (RecognitionState b a) +entityModified entLoader modification cLoc autoRecognizer oldRecognitionState = do + (val, accumulatedLogs) <- + runWriterT $ + entityModifiedLoggable RecognizeNewStructures entLoader modification cLoc autoRecognizer oldRecognitionState + return $ + val + & recognitionLog %~ (reverse accumulatedLogs <>) + +-- | This handles structure detection upon addition of an entity, +-- and structure de-registration upon removal of an entity. +-- Also handles atomic entity swaps. +entityModifiedLoggable :: + (Monoid (f (SearchLog a)), Monad m, Hashable a, Eq b, Applicative f) => + RecognitionActiveStatus -> + (Cosmic Location -> m (AtomicKeySymbol a)) -> + CellModification a -> + Cosmic Location -> + RecognizerAutomatons b a -> + RecognitionState b a -> + WriterT (f (SearchLog a)) m (RecognitionState b a) +entityModifiedLoggable activeStatus entLoader modification cLoc autoRecognizer oldRecognitionState = do + case modification of + Add newEntity -> doAddition newEntity oldRecognitionState + Remove _ -> doRemoval oldRecognitionState + Swap _ newEntity -> doRemoval oldRecognitionState >>= doAddition newEntity + where + entLookup = autoRecognizer ^. automatonsByEntity + + doAddition newEntity = case activeStatus of + RecognizeNewStructures -> maybe return logAndRegister $ HM.lookup newEntity entLookup + DisableNewRecognition -> return + where + logAndRegister finder s = do + tell . pure . FoundParticipatingEntity $ + ParticipatingEntity + newEntity + (finder ^. inspectionOffsets) + newFoundStructures <- registerRowMatches entLoader cLoc finder $ s ^. foundStructures + return $ s & foundStructures .~ newFoundStructures + + doRemoval sOld = + -- Entity was removed; may need to remove registered structure. + maybe return logAndRemove structureAtLoc sOld + where + structureAtLoc = M.lookup cLoc $ foundByLocation $ sOld ^. foundStructures + logAndRemove fs s = do + tell $ pure $ StructureRemoved structureName + return $ s & foundStructures %~ removeStructure fs + where + structureName = name . originalItem . entityGrid $ structureWithGrid fs + +-- | In case this cell would match a candidate structure, +-- ensures that the entity in this cell is not already +-- participating in a registered structure. +-- +-- Furthermore, treating cells in registered structures +-- as 'Nothing' has the effect of "masking" them out, +-- so that they can overlap empty cells within the bounding +-- box of the candidate structure. +candidateEntityAt :: + (Monad s, Hashable a) => + GenericEntLocator s a -> + FoundRegistry b a -> + Cosmic Location -> + s (AtomicKeySymbol a) +candidateEntityAt entLoader registry cLoc = runMaybeT $ do + guard $ M.notMember cLoc $ foundByLocation registry + MaybeT $ entLoader cLoc + +-- | Excludes entities that are already part of a +-- registered found structure. +getWorldRow :: + (Monad s, Hashable a) => + GenericEntLocator s a -> + FoundRegistry b a -> + Cosmic Location -> + InspectionOffsets -> + s [AtomicKeySymbol a] +getWorldRow entLoader registry cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) = do + mapM getCandidate horizontalOffsets + where + getCandidate = candidateEntityAt entLoader registry + horizontalOffsets = map mkLoc [offsetLeft .. offsetRight] + mkLoc x = cLoc `offsetBy` V2 x 0 + +-- | This runs once per non-overlapping subset of found chunks +checkChunksCombination :: + (Monoid (f (SearchLog a)), Applicative f, Monad m, Hashable a, Eq b) => + Cosmic Location -> + InspectionOffsets -> + NE.NonEmpty (RowChunkMatchingReference b a) -> + [Position (NE.NonEmpty a)] -> + WriterT (f (SearchLog a)) m [FoundStructure b a] +checkChunksCombination + cLoc + horizontalOffsets + rowChunkReferences + candidatesChunked = do + tell . pure . FoundPiecewiseChunks . map swap . HM.toList $ + fmap NEIS.elems foundRowChunksLookup + + tell . pure . ChunkFailures $ candidateFailures + + tell . pure . ChunksMatchingExpected $ + map (modifyChunkedRowMatch $ fmap renderSharedNames) candidateExpected + + return structurePositionsToCheck + where + structurePositionsToCheck = concatMap mkFoundStructures candidateExpected + + candidateExpected = concatMap NE.toList candidateExpectedLists + + foundRowChunksLookup = + fmap NEIS.fromList $ + binTuplesHM $ + map (pVal &&& pIndex) candidatesChunked + + (candidateFailures, candidateExpectedLists) = + partitionEithers $ + map (checkCandidateAgainstObservedChunks horizontalOffsets foundRowChunksLookup) $ + NE.toList rowChunkReferences + + mkFoundStructures x = + NE.toList $ NE.map mkFoundStructure . referencingRows . chunkStructure $ foundChunkRow x + where + mkFoundStructure r = + PositionedStructure + (cLoc `offsetBy` theOffset) + (wholeStructure r) + where + theOffset = V2 (horizontalStructPos $ foundChunkRow x) (rowIndex r) + + modifyChunkedRowMatch f (ChunkedRowMatch x y) = ChunkedRowMatch x (f y) + +checkCandidateAgainstObservedChunks :: + Hashable e => + InspectionOffsets -> + HM.HashMap (NE.NonEmpty e) NEIntSet -> + RowChunkMatchingReference b e -> + Either (ChunkMatchFailureReason e) (NE.NonEmpty (ChunkedRowMatch (ConsolidatedRowReferences b e) e)) +checkCandidateAgainstObservedChunks horizontalOffsets foundRowChunksLookup (RowChunkMatchingReference r chunkPositionMap) = + left (ChunkMatchFailureReason $ renderSharedNames r) $ do + unless isKeysSubset . Left $ + NoKeysSubset $ + (FoundChunkComparison `on` HS.toList) foundChunksKeys referenceChunksKeys + + nonEmptyPairs <- + maybeToEither EmptyIntersection $ + NE.nonEmpty sortedByAlignmentChoices + + let maybeViables = do + possibles <- seedPossibleOffsets $ snd $ NE.head nonEmptyPairs + foldM findCoveringOffsets possibles $ NE.map (snd . snd) nonEmptyPairs + + viableRowOffsets <- maybeToEither EmptyIntersection maybeViables + return $ NE.map mkRowMatch $ NEIS.toList viableRowOffsets + where + theIntersection = + HM.intersectionWith + FoundAndExpectedChunkPositions + foundRowChunksLookup + modifiedChunkPositionMap + intersectionWithSizeDifferences = HM.map (sizeDifference &&& id) theIntersection + where + sizeDifference x = (subtract `on` NEIS.size) (expectedPositions x) (foundPositions x) + + -- Remove the pairings that have fewer occurrences than the required number. + -- The 'fst' element of the tuple is the difference between the "observed" and "required" count. + withSufficientCoverage = HM.filter ((>= 0) . fst) intersectionWithSizeDifferences + sortedByAlignmentChoices = sortOn (fst . snd) $ HM.toList withSufficientCoverage + + isKeysSubset = referenceChunksKeys `HS.isSubsetOf` foundChunksKeys + + mkRowMatch rowOffset = + ChunkedRowMatch + (map swap $ HM.toList theIntersection) + (FoundRowFromChunk rowOffset horizontalStructurePosition r) + where + horizontalStructurePosition = fromIntegral rowOffset + getMin (startOffset horizontalOffsets) + + modifiedChunkPositionMap = fmap NEIS.fromList chunkPositionMap + foundChunksKeys = HM.keysSet foundRowChunksLookup + referenceChunksKeys = HM.keysSet chunkPositionMap + +-- | Search for any structure row that happens to +-- contain the placed entity. +registerRowMatches :: + (Monoid (f (SearchLog a)), Applicative f, Monad s, Hashable a, Eq b) => + GenericEntLocator s a -> + Cosmic Location -> + AutomatonInfo b a -> + FoundRegistry b a -> + WriterT (f (SearchLog a)) s (FoundRegistry b a) +registerRowMatches entLoader cLoc (AutomatonInfo horizontalOffsets pwMatcher) registry = do + tell $ pure $ StartSearchAt cLoc horizontalOffsets + + tell . pure . ExpectedChunks $ + NE.map (HM.keys . confirmationMap) rowChunkReferences + + entitiesRow <- + lift $ + getWorldRow + entLoader + registry + cLoc + horizontalOffsets + + tell . pure . WorldRowContent $ entitiesRow + + let candidatesChunked = findAll pwSM entitiesRow + unrankedCandidateStructures <- checkCombo candidatesChunked + + -- [STRUCTURE RECOGNIZER CONFLICT RESOLUTION] + -- We only allow an entity to participate in one structure at a time, + -- so multiple matches require a tie-breaker. + -- The largest structure (by area) shall win. + -- Sort by decreasing order of preference + -- (see the Ord instance of 'FoundStructure'). + let rankedCandidates = sortOn Down unrankedCandidateStructures + tell . pure . FoundCompleteStructureCandidates $ + map getStructInfo rankedCandidates + + -- We should not check all of the structures, which can be expensive. + -- Instead, we ranked the candidates by preference a-priori + -- and now choose the first one that is verified. + maybeIntactStructure <- findM validateIntactness2d rankedCandidates + + forM_ maybeIntactStructure $ + tell . pure . RecognizedSingleStructure . getStructInfo + + return $ maybe id addFound maybeIntactStructure registry + where + PiecewiseRecognition pwSM rowChunkReferences = pwMatcher + + getStructInfo (PositionedStructure loc swg) = (distillLabel swg, loc) + + validateIntactness2d fs = do + maybeIntactnessFailure <- lift $ ensureStructureIntact registry entLoader fs + tell . pure . ChunkIntactnessVerification + $ IntactPlacementLog + maybeIntactnessFailure + $ PositionedStructure (upperLeftCorner fs) (distillLabel . structureWithGrid $ fs) + + return $ null maybeIntactnessFailure + + checkCombo = checkChunksCombination cLoc horizontalOffsets rowChunkReferences + +-- | +-- For a given "chunk", there could be multiple recurrences. +-- However, the position of each recurrence is unique +-- (i.e. the chunk cannot exist twice at the same location). +-- +-- Either: +-- A) An observed chunk is "superfluous" w.r.t. matching the candidate, or +-- B) It is necessary for the match. +-- +-- The lowest-numbered "reference position" (i.e. in the structure definition) +-- of a given chunk must align with exactly one "observed position". +-- +-- The difference between the "observed" position of the chunk that aligns with the +-- lowest-numbered "reference position" shall be the global "row offset" applied to our observations. +-- This row offset value applies to all "chunks" (both identical and distinct) that comprise the row. +-- +-- If a given chunk occurrence is necessary for the match, then we may attempt to use it to compute +-- the "row offset" by taking its position minus the lowest-numbered "reference position". +-- +-- We can iterate over each occurrence position in ascending order. +-- In the ideal case, the first such candidate ends up being the the actual, valid, offset. +-- Otherwise, we know that all invalid offset candidates encountered before the first valid +-- offset constitute "superfluous" chunks. +-- +-- Note that there may exist multiple valid "row offsets". +-- At most, there will be +-- {number of observed occurrences} minus {number of required occurrences} +-- such offsets. +-- +-- = Performance notes +-- +-- We only have to do this computation once, and only for the "smallest" size discrepancy +-- between occurrences and references of a chunk. This generates the "seed" pool of possible offsets. +-- All subsequent chunks will merely filter on this initial set. +seedPossibleOffsets :: (Int, FoundAndExpectedChunkPositions) -> Maybe NEIntSet +seedPossibleOffsets (sizeDifference, FoundAndExpectedChunkPositions found expected) = + NEIS.nonEmptySet $ IS.fromList possibleOffsets + where + possibleOffsets = + NE.take (sizeDifference + 1) $ + NE.map (subtract (NEIS.findMin expected)) $ + NEIS.toAscList found + +-- | Return all of the offsets that are viable for repetitions of this chunk. +-- +-- Note that if there are an equal number of observed occurrences +-- and expected occurrences, then there is only one possible offset. +-- If there are N expected and (N + 1) observed, then there are 2 possible offsets. +findCoveringOffsets :: NEIntSet -> FoundAndExpectedChunkPositions -> Maybe NEIntSet +findCoveringOffsets possibleOffsets x = + NEIS.nonEmptySet $ NEIS.filter (isCoveredWithOffset x) possibleOffsets + +isCoveredWithOffset :: FoundAndExpectedChunkPositions -> Int -> Bool +isCoveredWithOffset (FoundAndExpectedChunkPositions found expected) offset = + NEIS.map (+ offset) expected `NEIS.isSubsetOf` found diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs @@ -19,31 +19,30 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Type where import Control.Arrow ((&&&)) -import Control.Lens (makeLenses) +import Control.Lens (Lens', makeLenses) import Data.Aeson (ToJSON) import Data.Function (on) import Data.HashMap.Strict (HashMap) -import Data.HashSet (HashSet) import Data.Int (Int32) +import Data.IntSet.NonEmpty (NEIntSet) +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Maybe (catMaybes) import Data.Ord (Down (Down)) import Data.Semigroup (Max, Min) -import Data.Text (Text) import GHC.Generics (Generic) -import Linear (V2 (..)) -import Swarm.Game.Location (Location) +import Swarm.Game.Location (Location, asVector) import Swarm.Game.Scenario.Topography.Area -import Swarm.Game.Universe (Cosmic, offsetBy) +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Structure.Named (NamedArea, StructureName, name) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Static +import Swarm.Game.Universe (Cosmic, SubworldName, offsetBy) +import Swarm.Game.World.Coords (coordsToLoc) import Swarm.Language.Syntax.Direction (AbsoluteDir) +import Swarm.Util.Lens (makeLensesNoSigs) import Text.AhoCorasick (StateMachine) --- | A 'NamedStructure' has its own newtype name ('StructureName'), but we --- standardize on 'Text' here to avoid parameterizing our 'NamedOriginal' --- datatype on bespoke name types. -type OriginalName = Text - -- | A "needle" consisting of a single cell within -- the haystack (a row of cells) to be searched. -- @@ -66,15 +65,6 @@ -- @ type SymbolSequence a = [AtomicKeySymbol a] --- | This is returned as a value of the 1-D searcher. --- It contains search automatons customized to the 2-D structures --- that may possibly contain the row found by the 1-D searcher. -data StructureSearcher b a = StructureSearcher - { automaton2D :: AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a) - , needleContent :: SymbolSequence a - , singleRowItems :: NE.NonEmpty (SingleRowEntityOccurrences b a) - } - -- | -- Position specific to a single entity within a horizontal row. -- @@ -89,9 +79,31 @@ data PositionWithinRow b a = PositionWithinRow { _position :: Int32 -- ^ horizontal index of the entity within the row - , structureRow :: StructureRow b a + , structureRow :: ConsolidatedRowReferences b a } +-- | A chunkified version of a structure row. +-- Each unique structure row will need to test one of these +-- against the world row being examined. +data RowChunkMatchingReference b a = RowChunkMatchingReference + { locatableRows :: ConsolidatedRowReferences b a + , confirmationMap :: HashMap (NonEmpty a) (NonEmpty Int) + } + +data PiecewiseRecognition b a = PiecewiseRecognition + { piecewiseSM :: StateMachine (AtomicKeySymbol a) (NonEmpty a) + , picewiseLookup :: NonEmpty (RowChunkMatchingReference b a) + -- ^ A lookup structure for use with results of the + -- Aho-Corasick matcher. This lookup will determine whether + -- the discontiguous "chunks" found by the matcher occur at + -- the right positions with respect to the reference structure. + } + +data PositionedChunk a = PositionedChunk + { chunkStartPos :: Int + , chunkContents :: NonEmpty a + } + -- Represents all of the locations that particular entity -- occurs within a specific row of a particular structure. -- @@ -104,12 +116,15 @@ -- -- this record will contain two entries in its 'entityOccurrences' field. data SingleRowEntityOccurrences b a = SingleRowEntityOccurrences - { myRow :: StructureRow b a + { myRow :: ConsolidatedRowReferences b a , myEntity :: a - , entityOccurrences :: NE.NonEmpty (PositionWithinRow b a) + , contiguousChunks :: [PositionedChunk a] , expandedOffsets :: InspectionOffsets } +newtype RowWidth = RowWidth Int32 + deriving (Eq) + -- | A a specific row within a particular structure. -- -- === Example @@ -124,55 +139,44 @@ -- it's 'rowIndex' is @2@. -- -- The two type parameters, `b` and `a`, correspond --- to 'StructureCells' and 'Entity', respectively. +-- to 'Cell' and 'Entity', respectively. data StructureRow b a = StructureRow { wholeStructure :: StructureWithGrid b a , rowIndex :: Int32 -- ^ vertical index of the row within the structure - , rowContent :: SymbolSequence a + , rowContent :: NonEmpty (AtomicKeySymbol a) } --- | This wrapper facilitates naming the original structure --- (i.e. the "payload" for recognition) --- for the purpose of both UI display and internal uniqueness, --- while remaining agnostic to its internals. -data NamedOriginal a = NamedOriginal - { getName :: OriginalName - , orig :: a +-- | Represents all rows across all structures that share +-- a particular row content +data ConsolidatedRowReferences b a = ConsolidatedRowReferences + { sharedRowContent :: NonEmpty (AtomicKeySymbol a) + , referencingRows :: NonEmpty (StructureRow b a) + , theRowWidth :: RowWidth } + +data ExtractedArea b a = ExtractedArea + { originalItem :: NamedArea b + , extractedGrid :: NonEmptyGrid (AtomicKeySymbol a) + } deriving (Show, Eq) -- | The original definition of a structure, bundled -- with its grid of cells having been extracted for convenience. -- -- The two type parameters, `b` and `a`, correspond --- to 'StructureCells' and 'Entity', respectively. +-- to 'Cell' and 'Entity', respectively. data StructureWithGrid b a = StructureWithGrid - { originalDefinition :: NamedOriginal b - , rotatedTo :: AbsoluteDir - , entityGrid :: [SymbolSequence a] + { rotatedTo :: AbsoluteDir + , gridWidth :: RowWidth + , entityGrid :: ExtractedArea b a } deriving (Eq) -data RotationalSymmetry - = -- | Aka 1-fold symmetry - NoSymmetry - | -- | Equivalent under rotation by 180 degrees - TwoFold - | -- | Equivalent under rotation by 90 degrees - FourFold - deriving (Show, Eq) - -data SymmetryAnnotatedGrid a = SymmetryAnnotatedGrid - { namedGrid :: a - , symmetry :: RotationalSymmetry - } - deriving (Show) - -- | Structure definitions with precomputed metadata for consumption by the UI data StructureInfo b a = StructureInfo - { annotatedGrid :: SymmetryAnnotatedGrid b - , entityProcessedGrid :: [SymbolSequence a] + { annotatedGrid :: SymmetryAnnotatedGrid (ExtractedArea b a) + , entityProcessedGrid :: NonEmptyGrid (AtomicKeySymbol a) , entityCounts :: Map a Int } @@ -203,13 +207,9 @@ InspectionOffsets l1 r1 <> InspectionOffsets l2 r2 = InspectionOffsets (l1 <> l2) (r1 <> r2) --- | Each automaton shall be initialized to recognize --- a certain subset of structure rows, that may either --- all be within one structure, or span multiple structures. -data AutomatonInfo en k v = AutomatonInfo - { _participatingEntities :: HashSet en - , _inspectionOffsets :: InspectionOffsets - , _automaton :: StateMachine k v +data AutomatonInfo v k = AutomatonInfo + { _inspectionOffsets :: InspectionOffsets + , _piecewiseRecognizer :: PiecewiseRecognition v k } deriving (Generic) @@ -218,10 +218,10 @@ -- | The complete set of data needed to identify applicable -- structures, based on a just-placed entity. data RecognizerAutomatons b a = RecognizerAutomatons - { _originalStructureDefinitions :: Map OriginalName (StructureInfo b a) + { _originalStructureDefinitions :: Map StructureName (StructureInfo b a) -- ^ all of the structures that shall participate in automatic recognition. -- This list is used only by the UI and by the 'Floorplan' command. - , _automatonsByEntity :: HashMap a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a)) + , _automatonsByEntity :: HashMap a (AutomatonInfo b a) } deriving (Generic) @@ -231,14 +231,75 @@ -- These are the elements that are stored in the 'FoundRegistry'. -- -- The two type parameters, `b` and `a`, correspond --- to 'StructureCells' and 'Entity', respectively. -data FoundStructure b a = FoundStructure - { structureWithGrid :: StructureWithGrid b a - , upperLeftCorner :: Cosmic Location +-- to 'Cell' and 'Entity', respectively. +type FoundStructure b a = PositionedStructure (StructureWithGrid b a) + +-- | NOTE: A structure's name + orientation + position will uniquely +-- identify it in the world. Note that position alone is not sufficient; +-- due to transparency, a completely intact smaller structure can co-exist +-- within a larger structure, both sharing the same upper-left coordinate. +-- However, two identical structures (with identical orientation) cannot +-- occupy the same space. +-- +-- Compare "PositionedStructure OrientedStructure" to: +-- "Swarm.Game.Scenario.Topography.Structure.Recognition.Static.LocatedStructure" +data PositionedStructure s = PositionedStructure + { upperLeftCorner :: Cosmic Location + , structureWithGrid :: s } - deriving (Eq) + deriving (Eq, Functor, Generic, ToJSON) --- | Ordering is by increasing preference between simultaneously +deriving instance (Ord (PositionedStructure OrientedStructure)) + +data FoundRowFromChunk a = FoundRowFromChunk + { chunkOffsetFromSearchBorder :: Int + , horizontalStructPos :: Int32 + , chunkStructure :: a + } + deriving (Functor, Generic, ToJSON) + +-- | The located occurrences of a specific contiguous chunk of entities. +-- Note that an identical chunk may recur more than once in a structure row. +-- This record represents all of the recurrences of one such chunk. +-- +-- Any different chunks contained within a row will be described by +-- their own instance of this record. +data FoundAndExpectedChunkPositions = FoundAndExpectedChunkPositions + { foundPositions :: NEIntSet + , expectedPositions :: NEIntSet + } + deriving (Generic, ToJSON) + +data ChunkedRowMatch a e = ChunkedRowMatch + { positionsComparison :: [(FoundAndExpectedChunkPositions, NonEmpty e)] + , foundChunkRow :: FoundRowFromChunk a + } + deriving (Functor, Generic, ToJSON) + +data EntityDiscrepancy e = EntityDiscrepancy + { expectedEntity :: e + , observedEntity :: AtomicKeySymbol e + } + deriving (Functor, Generic, ToJSON) + +distillLabel :: StructureWithGrid b a -> OrientedStructure +distillLabel swg = OrientedStructure (name $ originalItem $ entityGrid swg) (rotatedTo swg) + +data IntactnessFailureReason e + = DiscrepantEntity (EntityDiscrepancy e) + | AlreadyUsedBy OrientedStructure + deriving (Functor, Generic, ToJSON) + +data StructureIntactnessFailure e = StructureIntactnessFailure + { failedOnIndex :: Location + , totalSize :: AreaDimensions + , reason :: IntactnessFailureReason e + } + deriving (Functor, Generic, ToJSON) + +-- | +-- [STRUCTURE RECOGNIZER CONFLICT RESOLUTION] +-- Ordering is by increasing preference between simultaneously -- completed structures. -- The preference heuristic is for: -- @@ -251,15 +312,29 @@ instance (Eq b, Eq a) => Ord (FoundStructure b a) where compare = compare `on` (f1 &&& f2) where - f1 = computeArea . getAreaDimensions . entityGrid . structureWithGrid + f1 = computeArea . getNEGridDimensions . extractedGrid . entityGrid . structureWithGrid f2 = Down . upperLeftCorner -- | Yields coordinates that are occupied by an entity of a placed structure. -- Cells within the rectangular bounds of the structure that are unoccupied -- are not included. genOccupiedCoords :: FoundStructure b a -> [Cosmic Location] -genOccupiedCoords (FoundStructure swg loc) = - concatMap catMaybes . zipWith mkRow [0 ..] $ entityGrid swg +genOccupiedCoords (PositionedStructure loc swg) = + catMaybes . NE.toList . mapWithCoordsNE f . extractedGrid $ entityGrid swg where - mkCol y x ent = loc `offsetBy` V2 x (negate y) <$ ent - mkRow rowIdx = zipWith (mkCol rowIdx) [0 ..] + -- replaces an "occupied" grid cell with its location + f cellLoc maybeEnt = ((loc `offsetBy`) . asVector . coordsToLoc $ cellLoc) <$ maybeEnt + +data StaticStructureInfo b a = StaticStructureInfo + { _staticAutomatons :: RecognizerAutomatons b a + , _staticPlacements :: Map SubworldName [LocatedStructure] + } + +makeLensesNoSigs ''StaticStructureInfo + +-- | Recognition engine for statically-defined structures +staticAutomatons :: Lens' (StaticStructureInfo b a) (RecognizerAutomatons b a) + +-- | A record of the static placements of structures, so that they can be +-- added to the "recognized" list upon scenario initialization +staticPlacements :: Lens' (StaticStructureInfo b a) (Map SubworldName [LocatedStructure]) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Terraform.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Terraform.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Terraform.hs @@ -0,0 +1,10 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Terraform where + +data CellModification e + = -- | Fields represent what existed in the cell "before" and "after", in that order. + -- The values are guaranteed to be different. + Swap e e + | Remove e + | Add e diff --git a/src/swarm-topography/Swarm/Game/Universe.hs b/src/swarm-topography/Swarm/Game/Universe.hs --- a/src/swarm-topography/Swarm/Game/Universe.hs +++ b/src/swarm-topography/Swarm/Game/Universe.hs @@ -10,9 +10,11 @@ module Swarm.Game.Universe where import Control.Lens (makeLenses, view) +import Data.Aeson (ToJSONKey) import Data.Function (on) import Data.Int (Int32) import Data.Text (Text) +import Data.Text qualified as T import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, withText, (.:)) import GHC.Generics (Generic) import Linear (V2 (..)) @@ -22,7 +24,7 @@ -- * Referring to subworlds data SubworldName = DefaultRootSubworld | SubworldName Text - deriving (Show, Eq, Ord, Generic, ToJSON) + deriving (Show, Eq, Ord, Generic, ToJSON, ToJSONKey) instance FromJSON SubworldName where parseJSON = withText "subworld name" $ return . SubworldName @@ -47,7 +49,7 @@ { _subworld :: SubworldName , _planar :: a } - deriving (Show, Eq, Ord, Functor, Generic, ToJSON) + deriving (Show, Eq, Ord, Functor, Generic, ToJSON, ToJSONKey) makeLenses ''Cosmic @@ -82,3 +84,17 @@ offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location offsetBy loc v = fmap (.+^ v) loc + +-- ** Rendering + +locationToString :: Location -> String +locationToString (Location x y) = + unwords $ map show [x, y] + +renderCoordsString :: Cosmic Location -> String +renderCoordsString (Cosmic sw coords) = + unwords $ locationToString coords : suffix + where + suffix = case sw of + DefaultRootSubworld -> [] + SubworldName swName -> ["in", T.unpack swName] diff --git a/src/swarm-tournament/Swarm/Web/Tournament.hs b/src/swarm-tournament/Swarm/Web/Tournament.hs --- a/src/swarm-tournament/Swarm/Web/Tournament.hs +++ b/src/swarm-tournament/Swarm/Web/Tournament.hs @@ -19,6 +19,7 @@ app, ) where +import Codec.Picture import Commonmark qualified as Mark (commonmark, renderHtml) import Control.Lens hiding (Context) import Control.Monad.IO.Class (liftIO) @@ -51,10 +52,12 @@ setMaxRequestNumFiles, ) import Servant +import Servant.JuicyPixels (PNG) import Servant.Multipart import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) import Swarm.Game.Scenario (ScenarioMetadata, scenarioMetadata) import Swarm.Game.State (Sha1 (..)) +import Swarm.Game.World.Render import Swarm.Web.Auth import Swarm.Web.Tournament.Database.Query import Swarm.Web.Tournament.Type @@ -90,6 +93,7 @@ :<|> "api" :> "private" :> "upload" :> "solution" :> Header "Referer" TL.Text :> AuthProtect "cookie-auth" :> MultipartForm Mem (MultipartData Mem) :> Verb 'POST 303 '[JSON] (Headers '[Header "Location" TL.Text] SolutionFileCharacterization) :<|> "scenario" :> Capture "sha1" Sha1 :> "metadata" :> Get '[JSON] ScenarioMetadata :<|> "scenario" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text + :<|> "scenario" :> Capture "sha1" Sha1 :> "thumbnail" :> Get '[PNG] DynamicImage :<|> "solution" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text :<|> "list" :> "games" :> Get '[JSON] [TournamentGame] :<|> "list" :> "game" :> Capture "sha1" Sha1 :> Get '[JSON] GameWithSolutions @@ -104,6 +108,7 @@ :<|> uploadSolution appData :<|> getScenarioMetadata appData :<|> downloadRedactedScenario appData + :<|> renderThumbnail appData :<|> downloadSolution appData :<|> listScenarios :<|> listSolutions @@ -122,7 +127,7 @@ tournamentsApiHtml :: LBS.ByteString tournamentsApiHtml = encodeUtf8 - . either (error . show) (Mark.renderHtml @()) + . either (TL.pack . show) (Mark.renderHtml @()) . Mark.commonmark "" $ T.pack "No documentation at this time." @@ -260,6 +265,18 @@ withExceptT DecodingFailure . except . decodeUtf8' . LBS.fromStrict $ encodeWith defaultEncodeOptions redactedDict +renderThumbnail :: AppData -> Sha1 -> Handler DynamicImage +renderThumbnail (AppData _ _ persistenceLayer _) scenarioSha1 = do + Handler . withExceptT toServantError $ do + doc <- + ExceptT $ + maybeToEither (DatabaseRetrievalFailure scenarioSha1) + <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1 + + s <- withExceptT RetrievedInstantiationFailure $ initScenarioObjectWithEnv doc + g <- getRenderableGrid (RenderComputationContext Nothing Nothing) s + return $ ImageRGBA8 $ renderImage g + listScenarios :: Handler [TournamentGame] listScenarios = Handler . liftIO . withConnection databaseFilename $ runReaderT listGames @@ -295,6 +312,8 @@ doLocalDevelopmentLogin authStorage envType maybeRefererUrl = case envType of ProdDeployment -> error "Login bypass not available in production" + -- The above call to `error` can cause the tournament server to + -- crash on startup, but not the game itself. LocalDevelopment user -> doLoginResponse authStorage refererUrl user where @@ -368,7 +387,6 @@ -- files there. -- Instead, we manually stub the paths that are used as redirects -- so that the web API invocation does not 404 when looking for them. - serveDirectoryEmbedded [ (TL.unpack defaultRedirectPage, "Hello World!") , (TL.unpack defaultSolutionSubmissionRedirectPage, "Hello World!") diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs b/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs --- a/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs +++ b/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs @@ -8,7 +8,7 @@ module Swarm.Web.Tournament.Validate where import Control.Arrow (left) -import Control.Carrier.Accum.FixedStrict (evalAccum) +import Control.Carrier.Accum.Strict (evalAccum) import Control.Carrier.Throw.Either (runThrow) import Control.Lens import Control.Monad (unless) @@ -22,15 +22,15 @@ import Data.Text.Encoding (decodeUtf8') import Data.Yaml (decodeEither', parseEither) import Servant.Multipart +import Swarm.Failure (SystemFailure) import Swarm.Game.CESK (continue) -import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Robot.Concrete (machine) import Swarm.Game.Scenario import Swarm.Game.Scenario.Scoring.CodeSize (codeMetricsFromSyntax) -import Swarm.Game.Scenario.Status (emptyLaunchParams) +import Swarm.Game.Scenario.Status (ScenarioWith (..), emptyLaunchParams) import Swarm.Game.State import Swarm.Game.State.Initialize (scenarioToGameState) -import Swarm.Game.State.Runtime (initGameStateConfig, initScenarioInputs) +import Swarm.Game.State.Runtime (RuntimeOptions (..), initGameStateConfig, initScenarioInputs, pauseOnObjectiveCompletion) import Swarm.Game.State.Substate (initState, seed) import Swarm.Game.Step.Validate (playUntilWin) import Swarm.Language.Pipeline @@ -183,11 +183,17 @@ withExceptT (ScenarioEnvironmentFailure . ContextInitializationFailure) . ExceptT . runThrow - $ evalAccum (mempty :: Seq SystemFailure) initGameStateConfig + . evalAccum (mempty :: Seq SystemFailure) + . initGameStateConfig + $ RuntimeOptions + { startPaused = False + , pauseOnObjectiveCompletion = False + , loadTestScenarios = False + } let scenarioInputs = gsiScenarioInputs $ initState gsc scenarioObject <- initScenarioObject scenarioInputs content - gs <- liftIO $ scenarioToGameState scenarioObject emptyLaunchParams gsc + gs <- liftIO $ scenarioToGameState (ScenarioWith scenarioObject Nothing) emptyLaunchParams gsc return (gs, scenarioObject) verifySolution :: diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs b/src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs --- a/src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs +++ b/src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs @@ -12,7 +12,7 @@ import Data.Text qualified as T import Data.Text.Encoding.Error (UnicodeException) import Data.Yaml (ParseException) -import Swarm.Game.Failure (SystemFailure) +import Swarm.Failure (SystemFailure) import Swarm.Game.State (Sha1 (..)) import Swarm.Util (parens, showT) import System.Time.Extra (Seconds, showDuration) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -26,27 +26,27 @@ handleInfoPanelEvent, ) where --- See Note [liftA2 re-export from Prelude] -import Prelude hiding (Applicative (..)) - import Brick hiding (Direction, Location) +import Brick.Animation (stopAnimationManager) import Brick.Focus import Brick.Keybindings qualified as B import Brick.Widgets.Dialog -import Brick.Widgets.Edit (Editor, applyEdit, handleEditorEvent) -import Brick.Widgets.List (handleListEvent) +import Brick.Widgets.Edit (Editor, applyEdit, editContentsL, handleEditorEvent) +import Brick.Widgets.List (handleListEvent, listElements) import Brick.Widgets.List qualified as BL -import Control.Applicative (pure) +import Brick.Widgets.TabularList.Grid qualified as BG +import Control.Applicative ((<|>)) import Control.Category ((>>>)) import Control.Lens as Lens -import Control.Monad (unless, void, when) +import Control.Monad (forM_, unless, void, when) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execState) +import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M -import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) import Data.Set (Set) import Data.Set qualified as S import Data.Text (Text) @@ -60,8 +60,11 @@ import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend)) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Land -import Swarm.Game.ResourceLoading (getSwarmHistoryPath) import Swarm.Game.Robot.Concrete +import Swarm.Game.Scenario (scenarioMetadata, scenarioName) +import Swarm.Game.Scenario.Scoring.Best (scenarioBestByTime) +import Swarm.Game.Scenario.Scoring.GenericMetrics +import Swarm.Game.Scenario.Status (ScenarioPath (..), ScenarioWith (..), getScenario) import Swarm.Game.ScenarioInfo import Swarm.Game.State import Swarm.Game.State.Landscape @@ -83,10 +86,12 @@ import Swarm.Language.Typecheck ( ContextualTypeErr (..), ) -import Swarm.Language.Value (Value (VKey), envTypes) +import Swarm.Language.Value (Value (VKey), emptyEnv, envTypes) import Swarm.Log +import Swarm.ResourceLoading (getSwarmHistoryPath) import Swarm.TUI.Controller.EventHandlers import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) +import Swarm.TUI.Controller.UpdateUI import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Controller qualified as EC import Swarm.TUI.Editor.Model @@ -95,71 +100,87 @@ import Swarm.TUI.Launch.Prep (prepareLaunchDialog) import Swarm.TUI.List import Swarm.TUI.Model -import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.Dialog hiding (Completed) +import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name -import Swarm.TUI.Model.Popup (progressPopups) import Swarm.TUI.Model.Repl import Swarm.TUI.Model.StateUpdate -import Swarm.TUI.Model.Structure import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay +import Swarm.TUI.View.Popup (startPopupAnimation) +import Swarm.TUI.View.Robot +import Swarm.TUI.View.Robot.Type import Swarm.Util hiding (both, (<<.=)) -import Swarm.Version (NewReleaseFailure (..)) --- ~~~~ Note [liftA2 re-export from Prelude] --- --- As of base-4.18 (GHC 9.6), liftA2 is re-exported from Prelude. See --- https://github.com/haskell/core-libraries-committee/issues/50 . In --- order to compile warning-free on both GHC 9.6 and older versions, --- we hide the import of Applicative functions from Prelude and import --- explicitly from Control.Applicative. In theory, if at some point --- in the distant future we end up dropping support for GHC < 9.6 then --- we could get rid of both explicit imports and just get liftA2 and --- pure implicitly from Prelude. - -- | The top-level event handler for the TUI. handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleEvent = \case - -- the query for upstream version could finish at any time, so we have to handle it here - AppEvent (UpstreamVersion ev) -> do - let logReleaseEvent l sev e = runtimeState . eventLog %= logEvent l sev "Release" (T.pack $ show e) - case ev of - Left e -> - let sev = case e of - FailedReleaseQuery {} -> Error - OnDevelopmentBranch {} -> Info - _ -> Warning - in logReleaseEvent SystemLog sev e - Right _ -> pure () - runtimeState . upstreamRelease .= ev - e -> do - -- Handle popup display at the very top level, so it is - -- unaffected by any other state, e.g. even when starting or - -- quitting a game, moving around the menu, the popup - -- display will continue as normal. - upd <- case e of - AppEvent Frame -> Brick.zoom (uiState . uiPopups) progressPopups - _ -> pure False +handleEvent e = do + playing <- use $ uiState . uiPlaying + case e of + -- the query for upstream version could finish at any time, so we have to handle it here + AppEvent (UpstreamVersion ev) -> handleUpstreamVersionResponse ev + AppEvent (Web (RunWebCode {..})) | not playing -> liftIO . webReply $ Rejected NoActiveGame + AppEvent (PopupEvent event) -> event >> continueWithoutRedraw + _ -> do + -- Handle popup display at the very top level, so it is + -- unaffected by any other state, e.g. even when starting or + -- quitting a game, moving around the menu, the popup + -- display will continue as normal. + popupAnimState <- use $ playState . progression . uiPopupAnimationState + forceRedraw <- case popupAnimState of + AnimInactive -> do + Brick.zoom (playState . progression . uiPopups) nextPopup + startPopupIfNeeded + pure False + AnimScheduled -> pure False + AnimActive _ -> pure True - s <- get - if s ^. uiState . uiPlaying - then handleMainEvent upd e - else do - e & case s ^. uiState . uiMenu of - -- If we reach the NoMenu case when uiPlaying is False, just - -- quit the app. We should actually never reach this code (the - -- quitGame function would have already halted the app). - NoMenu -> const halt - MainMenu l -> handleMainMenuEvent l - NewGameMenu l -> - if s ^. uiState . uiLaunchConfig . controls . fileBrowser . fbIsDisplayed - then handleFBEvent - else case s ^. uiState . uiLaunchConfig . controls . isDisplayedFor of - Nothing -> handleNewGameMenuEvent l - Just siPair -> handleLaunchOptionsEvent siPair - MessagesMenu -> handleMainMessagesEvent - AchievementsMenu l -> handleMainAchievementsEvent l - AboutMenu -> pressAnyKey (MainMenu (mainMenu About)) + if playing + then handleMainEvent forceRedraw e + else handleMenuEvent e +startPopupIfNeeded :: EventM Name AppState () +startPopupIfNeeded = do + mPopup <- use $ playState . progression . uiPopups . currentPopup + case mPopup of + Just popup -> do + -- Ensures we don't grab another popup while waiting for the animation manager to start the event. + -- The animation state will be set to AnimActive when the animation manager actually starts the animation + playState . progression . uiPopupAnimationState .= AnimScheduled + animMgr <- use animationMgr + startPopupAnimation animMgr popup + Nothing -> pure () + +-- | Halt the app, properly cleaning up the animation manager. +haltApp :: EventM Name AppState () +haltApp = use animationMgr >>= stopAnimationManager >> halt + +handleUpstreamVersionResponse :: Either (Severity, Text) String -> EventM Name AppState () +handleUpstreamVersionResponse ev = do + case ev of + Left (sev, e) -> runtimeState . eventLog %= logEvent SystemLog sev "Release" e + Right _ -> pure () + runtimeState . upstreamRelease .= ev + +handleMenuEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleMenuEvent e = + use (uiState . uiMenu) >>= \case + -- If we reach the NoMenu case when uiPlaying is False, just + -- quit the app. We should actually never reach this code (the + -- quitGame function would have already halted the app). + NoMenu -> haltApp + MainMenu l -> handleMainMenuEvent l e + NewGameMenu l -> do + launchControls <- use $ uiState . uiLaunchConfig . controls + if launchControls ^. fileBrowser . fbIsDisplayed + then handleFBEvent e + else case launchControls ^. isDisplayedFor of + Nothing -> handleNewGameMenuEvent l e + Just siPair -> handleLaunchOptionsEvent siPair e + MessagesMenu -> handleMainMessagesEvent e + AchievementsMenu l -> handleMainAchievementsEvent l e + AboutMenu -> pressAnyKey (MainMenu (mainMenu About)) e + -- | The event handler for the main menu. -- -- TODO: #2010 Finish porting Controller to KeyEventHandlers @@ -167,43 +188,65 @@ BL.List Name MainMenuEntry -> BrickEvent Name AppEvent -> EventM Name AppState () handleMainMenuEvent menu = \case Key V.KEnter -> - case snd <$> BL.listSelectedElement menu of - Nothing -> pure () - Just x0 -> case x0 of - NewGame -> do - cheat <- use $ uiState . uiCheatMode - ss <- use $ runtimeState . scenarios - uiState . uiMenu .= NewGameMenu (pure $ mkScenarioList cheat ss) - Tutorial -> do - -- Set up the menu stack as if the user had chosen "New Game > Tutorials" - cheat <- use $ uiState . uiCheatMode - ss <- use $ runtimeState . scenarios - let tutorialCollection = getTutorials ss - topMenu = - BL.listFindBy - ((== tutorialsDirname) . T.unpack . scenarioItemName) - (mkScenarioList cheat ss) - tutorialMenu = mkScenarioList cheat tutorialCollection - menuStack = tutorialMenu :| pure topMenu - uiState . uiMenu .= NewGameMenu menuStack + forM_ (snd <$> BL.listSelectedElement menu) $ \case + NewGame -> do + ss <- use $ playState . progression . scenarios + uiState . uiMenu .= NewGameMenu (pure $ mkScenarioList $ pathifyCollection ss) + Tutorial -> do + ss <- use $ playState . progression . scenarios - -- 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 siPair) -> siPair - _ -> error "No first tutorial found!" - _ -> error "No first tutorial found!" - startGame firstTutorial Nothing - Achievements -> uiState . uiMenu .= AchievementsMenu (BL.list AchievementList (V.fromList listAchievements) 1) - Messages -> do - runtimeState . eventLog . notificationsCount .= 0 - uiState . uiMenu .= MessagesMenu - About -> do - uiState . uiMenu .= AboutMenu - attainAchievement $ GlobalAchievement LookedAtAboutScreen - Quit -> halt - CharKey 'q' -> halt - ControlChar 'q' -> halt + -- Extract the first unsolved tutorial challenge + let tutorialCollection = getTutorials ss + tutorials = scenarioCollectionToList tutorialCollection + -- Find first unsolved tutorial, or first tutorial if all are solved + firstUnsolved :: Maybe (ScenarioItem ScenarioInfo) + firstUnsolved = find unsolved tutorials <|> listToMaybe tutorials + unsolved = \case + SISingle (ScenarioWith _ si) -> case si ^. scenarioStatus of + Played _ _ best + | Metric Completed _ <- best ^. scenarioBestByTime -> False + | otherwise -> True + _ -> True + _ -> False + + case firstUnsolved of + Just (SISingle firstUnsolvedInfo) -> do + let firstUnsolvedName = firstUnsolvedInfo ^. getScenario . scenarioMetadata . scenarioName + + -- Now set up the menu stack as if the user had chosen "New Game > Tutorials > t" + -- where t is the tutorial scenario we identified as the first unsolved one + let topMenu = + BL.listFindBy + ((== tutorialsDirname) . T.unpack . scenarioItemName) + (mkScenarioList $ pathifyCollection ss) + tutorialMenu = + BL.listFindBy + ((== firstUnsolvedName) . scenarioItemName) + (mkScenarioList $ pathifyCollection tutorialCollection) + menuStack = tutorialMenu :| pure topMenu + + -- Finally, set the menu stack, and start the scenario! + uiState . uiMenu .= NewGameMenu menuStack + + let remainingTutorials = maybe mempty (getScenariosAfterSelection tutorialMenu) $ BL.listSelected tutorialMenu + startGame (pathifyCollection firstUnsolvedInfo :| remainingTutorials) Nothing + + -- This shouldn't normally happen, but it could if the + -- correct data files aren't installed. In that case, log + -- an error. + _ -> runtimeState . eventLog %= logEvent SystemLog Error "Tutorials" "No tutorials found!" + Achievements -> uiState . uiMenu .= AchievementsMenu (BL.list AchievementList (V.fromList listAchievements) 1) + Messages -> do + runtimeState . eventLog . notificationsCount .= 0 + uiState . uiMenu .= MessagesMenu + About -> do + uiState . uiMenu .= AboutMenu + Brick.zoom (playState . progression) $ + attainAchievement $ + GlobalAchievement LookedAtAboutScreen + Quit -> haltApp + CharKey 'q' -> haltApp + ControlChar 'q' -> haltApp VtyEvent ev -> do menu' <- nestEventM' menu (handleListEvent ev) uiState . uiMenu .= MainMenu menu' @@ -243,33 +286,38 @@ -- TODO: #2010 Finish porting Controller to KeyEventHandlers handleNewGameMenuEvent :: - NonEmpty (BL.List Name ScenarioItem) -> + NonEmpty (BL.List Name (ScenarioItem ScenarioPath)) -> BrickEvent Name AppEvent -> EventM Name AppState () handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case Key V.KEnter -> - case snd <$> BL.listSelectedElement curMenu of - Nothing -> pure () - Just (SISingle siPair) -> invalidateCache >> startGame siPair Nothing - Just (SICollection _ c) -> do - cheat <- use $ uiState . uiCheatMode - uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList cheat c) scenarioStack) + forM_ (BL.listSelectedElement curMenu) $ \(pos, item) -> case item of + SISingle siPair -> do + invalidateCache + let remaining = getScenariosAfterSelection curMenu pos + startGame (siPair :| remaining) Nothing + SICollection _ c -> uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList c) scenarioStack) CharKey 'o' -> showLaunchDialog CharKey 'O' -> showLaunchDialog Key V.KEsc -> exitNewGameMenu scenarioStack CharKey 'q' -> exitNewGameMenu scenarioStack - ControlChar 'q' -> halt + ControlChar 'q' -> haltApp VtyEvent ev -> do menu' <- nestEventM' curMenu (handleListEvent ev) uiState . uiMenu .= NewGameMenu (menu' :| rest) _ -> pure () where showLaunchDialog = case snd <$> BL.listSelectedElement curMenu of - Just (SISingle siPair) -> Brick.zoom (uiState . uiLaunchConfig) $ prepareLaunchDialog siPair + Just (SISingle (ScenarioWith s (ScenarioPath p))) -> do + ss <- use $ playState . progression . scenarios + let si = getScenarioInfoFromPath ss p + Brick.zoom (uiState . uiLaunchConfig) $ prepareLaunchDialog $ ScenarioWith s si _ -> pure () -exitNewGameMenu :: NonEmpty (BL.List Name ScenarioItem) -> EventM Name AppState () -exitNewGameMenu stk = do +exitNewGameMenu :: + NonEmpty (BL.List Name (ScenarioItem ScenarioPath)) -> + EventM Name AppState () +exitNewGameMenu stk = uiState . uiMenu .= case snd (NE.uncons stk) of @@ -287,70 +335,96 @@ let keyHandler = s ^. keyEventHandling . keyDispatchers . to mainGameDispatcher case ev of AppEvent ae -> case ae of - Frame - -- If the game is paused, don't run any game ticks, but do redraw the screen - -- if a redraw is forced. - | s ^. gameState . temporal . paused -> unless forceRedraw continueWithoutRedraw - | otherwise -> runFrameUI forceRedraw - Web (RunWebCode c) -> runBaseWebCode c - _ -> continueWithoutRedraw + -- If the game is paused, don't run any game ticks, but do redraw if needed. + Frame -> + if s ^. playState . scenarioState . gameState . temporal . paused + then updateAndRedrawUI forceRedraw + else runFrameUI forceRedraw + Web (RunWebCode e r) -> Brick.zoom (playState . scenarioState) $ runBaseWebCode e r + -- UpstreamVersion event should already be handled by top-level handler, so + -- in theory this case cannot happen. + UpstreamVersion _ -> pure () + -- PopupEvent event should already be handled by top-level handler, so this shouldn't happen. + PopupEvent _ -> pure () VtyEvent (V.EvResize _ _) -> invalidateCache - EscapeKey | Just m <- s ^. uiState . uiGameplay . uiModal -> closeModal m + EscapeKey + | Just m <- s ^. playState . scenarioState . uiGameplay . uiDialogs . uiModal -> + Brick.zoom (playState . scenarioState) $ + if s ^. playState . scenarioState . uiGameplay . uiDialogs . uiRobot . isDetailsOpened + then uiGameplay . uiDialogs . uiRobot . isDetailsOpened .= False + else closeModal m -- Pass to key handler (allows users to configure bindings) -- See Note [how Swarm event handlers work] VtyEvent (V.EvKey k m) | isJust (B.lookupVtyEvent k m keyHandler) -> void $ B.handleKey keyHandler k m -- pass keys on to modal event handler if a modal is open VtyEvent vev - | isJust (s ^. uiState . uiGameplay . uiModal) -> handleModalEvent vev + | isJust (s ^. playState . scenarioState . uiGameplay . uiDialogs . uiModal) -> handleModalEvent vev MouseDown (TerrainListItem pos) V.BLeft _ _ -> - uiState . uiGameplay . uiWorldEditor . terrainList %= BL.listMoveTo pos + playState . scenarioState . uiGameplay . uiWorldEditor . terrainList %= BL.listMoveTo pos MouseDown (EntityPaintListItem pos) V.BLeft _ _ -> - uiState . uiGameplay . uiWorldEditor . entityPaintList %= BL.listMoveTo pos - MouseDown WorldPositionIndicator _ _ _ -> uiState . uiGameplay . uiWorldCursor .= Nothing + playState . scenarioState . uiGameplay . uiWorldEditor . entityPaintList %= BL.listMoveTo pos + MouseDown WorldPositionIndicator _ _ _ -> + playState . scenarioState . uiGameplay . uiWorldCursor .= Nothing MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc -> -- Eye Dropper tool - EC.handleMiddleClick mouseLoc + Brick.zoom (playState . scenarioState) $ EC.handleMiddleClick mouseLoc MouseDown (FocusablePanel WorldPanel) V.BRight _ mouseLoc -> -- Eraser tool - EC.handleRightClick mouseLoc + Brick.zoom (playState . scenarioState) $ EC.handleRightClick mouseLoc MouseDown (FocusablePanel WorldPanel) V.BLeft [V.MCtrl] mouseLoc -> -- Paint with the World Editor - EC.handleCtrlLeftClick mouseLoc + Brick.zoom (playState . scenarioState) $ EC.handleCtrlLeftClick mouseLoc MouseDown n _ _ mouseLoc -> case n of - FocusablePanel WorldPanel -> do + FocusablePanel WorldPanel -> Brick.zoom (playState . scenarioState) $ do mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc shouldUpdateCursor <- EC.updateAreaBounds mouseCoordsM when shouldUpdateCursor $ - uiState . uiGameplay . uiWorldCursor .= mouseCoordsM + uiGameplay . uiWorldCursor .= mouseCoordsM REPLInput -> handleREPLEvent ev + (UIShortcut "Help") -> Brick.zoom (playState . scenarioState) $ toggleMidScenarioModal HelpModal + (UIShortcut "Robots") -> Brick.zoom (playState . scenarioState) $ toggleMidScenarioModal RobotsModal + (UIShortcut "Commands") -> Brick.zoom (playState . scenarioState) $ toggleDiscoveryNotificationModal CommandsModal availableCommands + (UIShortcut "Recipes") -> Brick.zoom (playState . scenarioState) $ toggleDiscoveryNotificationModal RecipesModal availableRecipes + (UIShortcut "Messages") -> Brick.zoom (playState . scenarioState) toggleMessagesModal + (UIShortcut "pause") -> Brick.zoom (playState . scenarioState) $ whenRunningPlayState safeTogglePause + (UIShortcut "unpause") -> Brick.zoom (playState . scenarioState) $ whenRunningPlayState safeTogglePause + (UIShortcut "step") -> whenRunningAppState runSingleTick + (UIShortcut "speed-up") -> Brick.zoom (playState . scenarioState) $ whenRunningPlayState . modify $ adjustTPS (+) + (UIShortcut "speed-down") -> Brick.zoom (playState . scenarioState) $ whenRunningPlayState . modify $ adjustTPS (-) + (UIShortcut "hide REPL") -> Brick.zoom (playState . scenarioState) toggleREPLVisibility + (UIShortcut "show REPL") -> Brick.zoom (playState . scenarioState) toggleREPLVisibility + (UIShortcut "debug") -> showCESKDebug + (UIShortcut "hide robots") -> Brick.zoom (playState . scenarioState . uiGameplay) hideRobots + (UIShortcut "goal") -> Brick.zoom (playState . scenarioState) viewGoal _ -> continueWithoutRedraw - MouseUp n _ _mouseLoc -> do - case n of - InventoryListItem pos -> uiState . uiGameplay . uiInventory . uiInventoryList . traverse . _2 %= BL.listMoveTo pos - x@(WorldEditorPanelControl y) -> do - uiState . uiGameplay . uiWorldEditor . editorFocusRing %= focusSetCurrent x - EC.activateWorldEditorFunction y - _ -> return () - flip whenJust setFocus $ case n of - -- Adapt click event origin to the right panel. For the world - -- view, we just use 'Brick.Widgets.Core.clickable'. However, - -- the other panels all have a viewport, requiring us to - -- explicitly set their focus here. - InventoryList -> Just RobotPanel - InventoryListItem _ -> Just RobotPanel - InfoViewport -> Just InfoPanel - REPLViewport -> Just REPLPanel - REPLInput -> Just REPLPanel - WorldEditorPanelControl _ -> Just WorldEditorPanel - _ -> Nothing - case n of - FocusablePanel x -> setFocus x - _ -> return () + MouseUp n _ _mouseLoc -> + Brick.zoom (playState . scenarioState) $ do + case n of + InventoryListItem pos -> uiGameplay . uiInventory . uiInventoryList . traverse . _2 %= BL.listMoveTo pos + x@(WorldEditorPanelControl y) -> do + uiGameplay . uiWorldEditor . editorFocusRing %= focusSetCurrent x + EC.activateWorldEditorFunction y + _ -> return () + flip whenJust setFocus $ case n of + -- Adapt click event origin to the right panel. For the world + -- view, we just use 'Brick.Widgets.Core.clickable'. However, + -- the other panels all have a viewport, requiring us to + -- explicitly set their focus here. + InventoryList -> Just RobotPanel + InventoryListItem _ -> Just RobotPanel + InfoViewport -> Just InfoPanel + REPLViewport -> Just REPLPanel + REPLInput -> Just REPLPanel + WorldEditorPanelControl _ -> Just WorldEditorPanel + _ -> Nothing + case n of + FocusablePanel x -> setFocus x + _ -> return () -- dispatch any other events to the focused panel handler _ev -> do - fring <- use $ uiState . uiGameplay . uiFocusRing + fring <- use $ playState . scenarioState . uiGameplay . uiFocusRing case focusGetCurrent fring of Just (FocusablePanel x) -> case x of REPLPanel -> handleREPLEvent ev @@ -360,17 +434,17 @@ wh <- use $ keyEventHandling . keyDispatchers . to worldDispatcher void $ B.handleKey wh k m WorldPanel | otherwise -> continueWithoutRedraw - WorldEditorPanel -> EC.handleWorldEditorPanelEvent ev + WorldEditorPanel -> Brick.zoom (playState . scenarioState) $ EC.handleWorldEditorPanelEvent ev RobotPanel -> handleRobotPanelEvent ev InfoPanel -> handleInfoPanelEvent infoScroll ev _ -> continueWithoutRedraw -closeModal :: Modal -> EventM Name AppState () +closeModal :: Modal -> EventM Name ScenarioState () closeModal m = do safeAutoUnpause - uiState . uiGameplay . uiModal .= Nothing + uiGameplay . uiDialogs . uiModal .= Nothing -- message modal is not autopaused, so update notifications when leaving it - when ((m ^. modalType) == MessagesModal) $ do + when (m ^. modalType == MidScenarioModal MessagesModal) $ do t <- use $ gameState . temporal . ticks gameState . messageInfo . lastSeenMessageTime .= t @@ -378,49 +452,80 @@ handleModalEvent :: V.Event -> EventM Name AppState () handleModalEvent = \case V.EvKey V.KEnter [] -> do - mdialog <- preuse $ uiState . uiGameplay . uiModal . _Just . modalDialog - toggleModal QuitModal - case dialogSelection =<< mdialog of - Just (Button QuitButton, _) -> quitGame - Just (Button KeepPlayingButton, _) -> toggleModal KeepPlayingModal - Just (Button StartOverButton, StartOver currentSeed siPair) -> do - invalidateCache - restartGame currentSeed siPair - Just (Button NextButton, Next siPair) -> do - quitGame - invalidateCache - startGame siPair Nothing - _ -> return () - ev -> do - Brick.zoom (uiState . uiGameplay . uiModal . _Just . modalDialog) (handleDialogEvent ev) - modal <- preuse $ uiState . uiGameplay . uiModal . _Just . modalType + modal <- preuse $ playState . scenarioState . uiGameplay . uiDialogs . uiModal . _Just . modalType case modal of - Just TerrainPaletteModal -> - refreshList $ uiState . uiGameplay . uiWorldEditor . terrainList - Just EntityPaletteModal -> do - refreshList $ uiState . uiGameplay . uiWorldEditor . entityPaintList - Just GoalModal -> case ev of - V.EvKey (V.KChar '\t') [] -> uiState . uiGameplay . uiGoal . focus %= focusNext + Just (MidScenarioModal RobotsModal) -> do + robotDialog <- use $ playState . scenarioState . uiGameplay . uiDialogs . uiRobot + unless (robotDialog ^. isDetailsOpened) $ do + g <- use $ playState . scenarioState . gameState + let widget = robotDialog ^. robotsGridList + forM_ (getSelectedRobot g widget) $ \rob -> Brick.zoom (playState . scenarioState . uiGameplay . uiDialogs . uiRobot) $ do + isDetailsOpened .= True + Brick.zoom robotDetailsPaneState $ updateRobotDetailsPane rob + _ -> do + menu <- use $ uiState . uiMenu + + mdialog <- preuse $ playState . scenarioState . uiGameplay . uiDialogs . uiModal . _Just . modalDialog + Brick.zoom playState $ toggleEndScenarioModal QuitModal menu + + let isNoMenu = case menu of + NoMenu -> True + _ -> False + + case dialogSelection =<< mdialog of + Just (Button QuitButton, _) -> quitGame isNoMenu + Just (Button KeepPlayingButton, _) -> Brick.zoom playState $ toggleEndScenarioModal KeepPlayingModal menu + Just (Button StartOverButton, StartOver currentSeed siPair) -> do + invalidateCache + restartGame currentSeed siPair + Just (Button NextButton, Next remainingScenarios) -> do + quitGame isNoMenu + invalidateCache + startGame remainingScenarios Nothing + _ -> return () + ev -> Brick.zoom (playState . scenarioState) $ do + Brick.zoom (uiGameplay . uiDialogs . uiModal . _Just . modalDialog) (handleDialogEvent ev) + modal <- preuse $ uiGameplay . uiDialogs . uiModal . _Just . modalType + case modal of + Just (MidScenarioModal TerrainPaletteModal) -> + refreshList $ uiGameplay . uiWorldEditor . terrainList + Just (MidScenarioModal EntityPaletteModal) -> refreshList $ uiGameplay . uiWorldEditor . entityPaintList + Just (MidScenarioModal GoalModal) -> case ev of + V.EvKey (V.KChar '\t') [] -> uiGameplay . uiDialogs . uiGoal . focus %= focusNext _ -> do - focused <- use $ uiState . uiGameplay . uiGoal . focus + focused <- use $ uiGameplay . uiDialogs . uiGoal . focus case focusGetCurrent focused of Just (GoalWidgets w) -> case w of ObjectivesList -> do - lw <- use $ uiState . uiGameplay . uiGoal . listWidget + lw <- use $ uiGameplay . uiDialogs . uiGoal . listWidget newList <- refreshGoalList lw - uiState . uiGameplay . uiGoal . listWidget .= newList + uiGameplay . uiDialogs . uiGoal . listWidget .= newList GoalSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev) _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) - Just StructuresModal -> case ev of - V.EvKey (V.KChar '\t') [] -> uiState . uiGameplay . uiStructure . structurePanelFocus %= focusNext + Just (MidScenarioModal StructuresModal) -> case ev of + V.EvKey (V.KChar '\t') [] -> uiGameplay . uiDialogs . uiStructure . structurePanelFocus %= focusNext _ -> do - focused <- use $ uiState . uiGameplay . uiStructure . structurePanelFocus + focused <- use $ uiGameplay . uiDialogs . uiStructure . structurePanelFocus case focusGetCurrent focused of Just (StructureWidgets w) -> case w of StructuresList -> - refreshList $ uiState . uiGameplay . uiStructure . structurePanelListWidget + refreshList $ uiGameplay . uiDialogs . uiStructure . structurePanelListWidget StructureSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev) _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) + Just (MidScenarioModal RobotsModal) -> do + uiGame <- use uiGameplay + g <- use gameState + Brick.zoom (uiGameplay . uiDialogs . uiRobot) $ case ev of + V.EvKey (V.KChar '\t') [] -> robotDetailsPaneState . detailFocus %= focusNext + _ -> do + isInDetailsMode <- use isDetailsOpened + if isInDetailsMode + then Brick.zoom (robotDetailsPaneState . logsList) $ handleListEvent ev + else do + Brick.zoom robotsGridList $ BG.handleGridListEvent (robotGridRenderers uiGame g) ev + -- Ensure list widget content is updated immediately + mRob <- use $ robotsGridList . to (getSelectedRobot g) + forM_ mRob $ Brick.zoom robotDetailsPaneState . updateRobotDetailsPane _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) where refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection @@ -432,19 +537,20 @@ -- * saves current scenario status (InProgress/Completed) -- * advances the menu to the next scenario IF the current one was won -- * returns to the previous menu -quitGame :: EventM Name AppState () -quitGame = do +quitGame :: Bool -> EventM Name AppState () +quitGame isNoMenu = do -- Write out REPL history. - history <- use $ uiState . uiGameplay . uiREPL . replHistory + history <- use $ playState . scenarioState . uiGameplay . uiREPL . replHistory let hist = mapMaybe getREPLSubmitted $ getLatestREPLHistoryItems maxBound history liftIO $ (`T.appendFile` T.unlines hist) =<< getSwarmHistoryPath True -- Save scenario status info. - saveScenarioInfoOnQuit + dOps <- use $ uiState . uiDebugOptions + Brick.zoom playState $ saveScenarioInfoOnQuit dOps -- Automatically advance the menu to the next scenario iff the -- player has won the current one. - wc <- use $ gameState . winCondition + wc <- use $ playState . scenarioState . gameState . winCondition case wc of WinConditions (Won _ _) _ -> uiState . uiMenu %= advanceMenu _ -> return () @@ -452,10 +558,9 @@ -- Either quit the entire app (if the scenario was chosen directly -- from the command line) or return to the menu (if the scenario was -- chosen from the menu). - menu <- use $ uiState . uiMenu - case menu of - NoMenu -> halt - _ -> uiState . uiPlaying .= False + if isNoMenu + then haltApp + else uiState . uiPlaying .= False ------------------------------------------------------------ -- REPL events @@ -465,8 +570,9 @@ handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEvent x = do s <- get - let controlMode = s ^. uiState . uiGameplay . uiREPL . replControlMode + let controlMode = s ^. playState . scenarioState . uiGameplay . uiREPL . replControlMode let keyHandler = s ^. keyEventHandling . keyDispatchers . to replDispatcher + let menu = s ^. uiState . uiMenu case x of -- Pass to key handler (allows users to configure bindings) -- See Note [how Swarm event handlers work] @@ -475,41 +581,40 @@ void $ B.handleKey keyHandler k m -- Handle other events in a way appropriate to the current REPL -- control mode. - _ -> case controlMode of - Typing -> handleREPLEventTyping x - Piloting -> handleREPLEventPiloting x + _ -> Brick.zoom playState $ case controlMode of + Typing -> handleREPLEventTyping menu x + Piloting -> handleREPLEventPiloting menu x Handling -> case x of -- Handle keypresses using the custom installed handler - VtyEvent (V.EvKey k mods) -> runInputHandler (mkKeyCombo mods k) + VtyEvent (V.EvKey k mods) -> Brick.zoom scenarioState $ runInputHandler (mkKeyCombo mods k) -- Handle all other events normally - _ -> handleREPLEventTyping x + _ -> handleREPLEventTyping menu x -- | Run the installed input handler on a key combo entered by the user. -runInputHandler :: KeyCombo -> EventM Name AppState () +runInputHandler :: KeyCombo -> EventM Name ScenarioState () runInputHandler kc = do mhandler <- use $ gameState . gameControls . inputHandler - case mhandler of + forM_ mhandler $ \(_, handler) -> do -- Shouldn't be possible to get here if there is no input handler, but -- if we do somehow, just do nothing. - Nothing -> return () - Just (_, handler) -> do - -- Make sure the base is currently idle; if so, apply the - -- installed input handler function to a `key` value - -- representing the typed input. - working <- use $ gameState . gameControls . replWorking - unless working $ do - s <- get - let env = s ^. gameState . baseEnv - store = s ^. gameState . baseStore - handlerCESK = Out (VKey kc) store [FApp handler, FExec, FSuspend env] - gameState . baseRobot . machine .= handlerCESK - gameState %= execState (zoomRobots $ activateRobot 0) + -- Make sure the base is currently idle; if so, apply the + -- installed input handler function to a `key` value + -- representing the typed input. + working <- use $ gameState . gameControls . replWorking + unless working $ do + s <- get + let env = fromMaybe emptyEnv $ s ^? gameState . baseEnv + store = s ^. gameState . baseStore + handlerCESK = Out (VKey kc) store [FApp handler, FExec, FSuspend env] + gameState . baseRobot . machine .= handlerCESK + gameState %= execState (zoomRobots $ activateRobot 0) + -- | Handle a user "piloting" input event for the REPL. -- -- TODO: #2010 Finish porting Controller to KeyEventHandlers -handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState () -handleREPLEventPiloting x = case x of +handleREPLEventPiloting :: Menu -> BrickEvent Name AppEvent -> EventM Name PlayState () +handleREPLEventPiloting m x = case x of Key V.KUp -> inputCmd "move" Key V.KDown -> inputCmd "turn back" Key V.KLeft -> inputCmd "turn left" @@ -530,38 +635,46 @@ _ -> inputCmd "noop" where inputCmd cmdText = do - uiState . uiGameplay . uiREPL %= setCmd (cmdText <> ";") - modify validateREPLForm - handleREPLEventTyping $ Key V.KEnter + scenarioState . uiGameplay . uiREPL %= setCmd (cmdText <> ";") + Brick.zoom scenarioState $ modify validateREPLForm + handleREPLEventTyping m $ Key V.KEnter setCmd nt theRepl = theRepl & replPromptText .~ nt & replPromptType .~ CmdPrompt [] -runBaseWebCode :: (MonadState AppState m) => T.Text -> m () -runBaseWebCode uinput = do +runBaseWebCode :: (MonadState ScenarioState m, MonadIO m) => T.Text -> (WebInvocationState -> IO ()) -> m () +runBaseWebCode uinput ureply = do s <- get - unless (s ^. gameState . gameControls . replWorking) $ - runBaseCode uinput + if s ^. gameState . gameControls . replWorking + then liftIO . ureply $ Rejected AlreadyRunning + else do + gameState . gameControls . replListener .= ureply . Complete . T.unpack + runBaseCode uinput + >>= liftIO . ureply . \case + Left err -> Rejected . ParseError $ T.unpack err + Right () -> InProgress -runBaseCode :: (MonadState AppState m) => T.Text -> m () +runBaseCode :: (MonadState ScenarioState m) => T.Text -> m (Either Text ()) runBaseCode uinput = do - addREPLHistItem (mkREPLSubmission uinput) + addREPLHistItem (REPLEntry Submitted) uinput resetREPL "" (CmdPrompt []) - env <- use $ gameState . baseEnv + env <- fromMaybe emptyEnv <$> preuse (gameState . baseEnv) case processTerm' env uinput of Right mt -> do - uiState . uiGameplay . uiREPL . replHistory . replHasExecutedManualInput .= True + uiGameplay . uiREPL . replHistory . replHasExecutedManualInput .= True runBaseTerm mt + return (Right ()) Left err -> do - addREPLHistItem (mkREPLError err) + addREPLHistItem REPLError err + return (Left err) -- | Handle a user input event for the REPL. -- -- TODO: #2010 Finish porting Controller to KeyEventHandlers -handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState () -handleREPLEventTyping = \case +handleREPLEventTyping :: Menu -> BrickEvent Name AppEvent -> EventM Name PlayState () +handleREPLEventTyping m = \case -- Scroll the REPL on PageUp or PageDown Key V.KPageUp -> vScrollPage replScroll Brick.Up Key V.KPageDown -> vScrollPage replScroll Brick.Down @@ -569,15 +682,15 @@ -- On any other key event, jump to the bottom of the REPL then handle the event vScrollToEnd replScroll case k of - Key V.KEnter -> do + Key V.KEnter -> Brick.zoom scenarioState $ do s <- get - let theRepl = s ^. uiState . uiGameplay . uiREPL + let theRepl = s ^. uiGameplay . uiREPL uinput = theRepl ^. replPromptText if not $ s ^. gameState . gameControls . replWorking then case theRepl ^. replPromptType of CmdPrompt _ -> do - runBaseCode uinput + void $ runBaseCode uinput invalidateCacheEntry REPLHistoryCache SearchPrompt hist -> case lastEntry uinput hist of @@ -588,9 +701,9 @@ resetREPL found (CmdPrompt []) modify validateREPLForm else continueWithoutRedraw - Key V.KUp -> modify $ adjReplHistIndex Older - Key V.KDown -> do - repl <- use $ uiState . uiGameplay . uiREPL + Key V.KUp -> Brick.zoom scenarioState $ modify $ adjReplHistIndex Older + Key V.KDown -> Brick.zoom scenarioState $ do + repl <- use $ uiGameplay . uiREPL let hist = repl ^. replHistory uinput = repl ^. replPromptText case repl ^. replPromptType of @@ -599,46 +712,54 @@ -- Special case for hitting "Down" arrow while entering a new non-empty input: -- save the input in the history and make the REPL blank. do - addREPLHistItem (mkREPLSaved uinput) + addREPLHistItem (REPLEntry Stashed) uinput resetREPL "" (CmdPrompt []) modify validateREPLForm -- Otherwise, just move around in the history as normal. _ -> modify $ adjReplHistIndex Newer - ControlChar 'r' -> do - s <- get - let uinput = s ^. uiState . uiGameplay . uiREPL . replPromptText - case s ^. uiState . uiGameplay . uiREPL . replPromptType of - CmdPrompt _ -> uiState . uiGameplay . uiREPL . replPromptType .= SearchPrompt (s ^. uiState . uiGameplay . uiREPL . replHistory) - SearchPrompt rh -> case lastEntry uinput rh of - Nothing -> pure () - Just found -> uiState . uiGameplay . uiREPL . replPromptType .= SearchPrompt (removeEntry found rh) - CharKey '\t' -> do + ControlChar 'r' -> + Brick.zoom (scenarioState . uiGameplay . uiREPL) $ do + uir <- get + let uinput = uir ^. replPromptText + case uir ^. replPromptType of + CmdPrompt _ -> replPromptType .= SearchPrompt (uir ^. replHistory) + SearchPrompt rh -> forM_ (lastEntry uinput rh) $ \found -> + replPromptType .= SearchPrompt (removeEntry found rh) + CharKey '\t' -> Brick.zoom scenarioState $ do s <- get let names = s ^.. gameState . baseEnv . envTypes . to assocs . traverse . _1 - uiState . uiGameplay . uiREPL %= tabComplete (CompletionContext (s ^. gameState . creativeMode)) names (s ^. gameState . landscape . terrainAndEntities . entityMap) + uiGameplay . uiREPL %= tabComplete (CompletionContext (s ^. gameState . creativeMode)) names (s ^. gameState . landscape . terrainAndEntities . entityMap) modify validateREPLForm - EscapeKey -> do - formSt <- use $ uiState . uiGameplay . uiREPL . replPromptType + EscapeKey -> Brick.zoom scenarioState $ do + formSt <- use $ uiGameplay . uiREPL . replPromptType case formSt of CmdPrompt {} -> continueWithoutRedraw SearchPrompt _ -> resetREPL "" (CmdPrompt []) ControlChar 'd' -> do - text <- use $ uiState . uiGameplay . uiREPL . replPromptText + text <- use $ scenarioState . uiGameplay . uiREPL . replPromptText if text == T.empty - then toggleModal QuitModal + then toggleEndScenarioModal QuitModal m else continueWithoutRedraw MetaKey V.KBS -> - uiState . uiGameplay . uiREPL . replPromptEditor %= applyEdit TZ.deletePrevWord + Brick.zoom scenarioState $ + uiGameplay . uiREPL . replPromptEditor %= applyEdit TZ.deletePrevWord -- finally if none match pass the event to the editor ev -> do - Brick.zoom (uiState . uiGameplay . uiREPL . replPromptEditor) $ case ev of - CharKey c | c `elem` ("([{" :: String) -> insertMatchingPair c + Brick.zoom (scenarioState . uiGameplay . uiREPL . replPromptEditor) $ case ev of + CharKey c + | c `elem` ("([{" :: String) -> insertMatchingPair c + | c `elem` (")]}" :: String) -> insertOrMovePast c _ -> handleEditorEvent ev - uiState . uiGameplay . uiREPL . replPromptType %= \case + scenarioState . uiGameplay . uiREPL . replPromptType %= \case CmdPrompt _ -> CmdPrompt [] -- reset completions on any event passed to editor SearchPrompt a -> SearchPrompt a - modify validateREPLForm + -- Now re-validate the input, unless only the cursor moved. + case ev of + Key V.KLeft -> pure () + Key V.KRight -> pure () + _ -> Brick.zoom scenarioState $ modify validateREPLForm + insertMatchingPair :: Char -> EventM Name (Editor Text Name) () insertMatchingPair c = modify . applyEdit $ TZ.insertChar c >>> TZ.insertChar (close c) >>> TZ.moveLeft where @@ -648,6 +769,16 @@ '{' -> '}' _ -> c +-- | Insert a character in an editor unless it matches the character +-- already at the cursor, in which case we just move past it +-- instead, without inserting an extra copy. +insertOrMovePast :: Char -> EventM Name (Editor Text Name) () +insertOrMovePast c = do + e <- get + modify . applyEdit $ case TZ.currentChar (e ^. editContentsL) of + Just c' | c' == c -> TZ.moveRight + _ -> TZ.insertChar c + data CompletionType = FunctionName | EntityName @@ -668,7 +799,7 @@ -- | 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 :: CompletionContext -> [Var] -> EntityMap -> REPLState -> REPLState +tabComplete :: CompletionContext -> [Text] -> EntityMap -> REPLState -> REPLState tabComplete CompletionContext {..} names em theRepl = case theRepl ^. replPromptType of SearchPrompt _ -> theRepl CmdPrompt mms @@ -715,9 +846,7 @@ FunctionName -> (possibleWords, isIdentChar) possibleWords = - names <> case ctxCreativeMode of - True -> S.toList reservedWords - False -> S.toList $ reservedWords `S.difference` creativeWords + names <> (if ctxCreativeMode then S.toList reservedWords else S.toList $ reservedWords `S.difference` creativeWords) entityNames = M.keys $ entitiesByName em @@ -729,16 +858,16 @@ -- | Validate the REPL input when it changes: see if it parses and -- typechecks, and set the color accordingly. -validateREPLForm :: AppState -> AppState +validateREPLForm :: ScenarioState -> ScenarioState validateREPLForm s = case replPrompt of CmdPrompt _ | T.null uinput -> let theType = s ^. gameState . gameControls . replStatus . replActiveType - in s & uiState . uiGameplay . uiREPL . replType .~ theType + in s & uiGameplay . uiREPL . replType .~ theType CmdPrompt _ | otherwise -> - let env = s ^. gameState . baseEnv + let env = fromMaybe emptyEnv $ s ^? gameState . baseEnv (theType, errSrcLoc) = case readTerm' defaultParserConfig uinput of Left err -> let ((_y1, x1), (_y2, x2), _msg) = showErrorPos err @@ -748,31 +877,31 @@ Right t -> (Just (t ^. sType), Right ()) Left err -> (Nothing, Left (cteSrcLoc err)) in s - & uiState . uiGameplay . uiREPL . replValid .~ errSrcLoc - & uiState . uiGameplay . uiREPL . replType .~ theType + & uiGameplay . uiREPL . replValid .~ errSrcLoc + & uiGameplay . uiREPL . replType .~ theType SearchPrompt _ -> s where - uinput = s ^. uiState . uiGameplay . uiREPL . replPromptText - replPrompt = s ^. uiState . uiGameplay . uiREPL . replPromptType + uinput = s ^. uiGameplay . uiREPL . replPromptText + replPrompt = s ^. uiGameplay . uiREPL . replPromptType -- | Update our current position in the REPL history. -adjReplHistIndex :: TimeDir -> AppState -> AppState +adjReplHistIndex :: TimeDir -> ScenarioState -> ScenarioState adjReplHistIndex d s = s - & uiState . uiGameplay . uiREPL %~ moveREPL + & uiGameplay . uiREPL %~ moveREPL & validateREPLForm where moveREPL :: REPLState -> REPLState moveREPL theRepl = newREPL - & (if replIndexIsAtInput (theRepl ^. replHistory) then saveLastEntry else id) - & (if oldEntry /= newEntry then showNewEntry else id) + & applyWhen (replIndexIsAtInput (theRepl ^. replHistory)) saveLastEntry + & applyWhen (oldEntry /= newEntry) showNewEntry where -- new AppState after moving the repl index newREPL :: REPLState newREPL = theRepl & replHistory %~ moveReplHistIndex d oldEntry - saveLastEntry = replLast .~ (theRepl ^. replPromptText) + saveLastEntry = replLast .~ theRepl ^. replPromptText showNewEntry = (replPromptEditor .~ newREPLEditor newEntry) . (replPromptType .~ CmdPrompt []) -- get REPL data getCurrEntry = fromMaybe (theRepl ^. replLast) . getCurrentItemText . view replHistory @@ -786,7 +915,7 @@ -- | Handle user events in the info panel (just scrolling). -- -- TODO: #2010 Finish porting Controller to KeyEventHandlers -handleInfoPanelEvent :: ViewportScroll Name -> BrickEvent Name AppEvent -> EventM Name AppState () +handleInfoPanelEvent :: ViewportScroll Name -> BrickEvent Name AppEvent -> EventM Name s () handleInfoPanelEvent vs = \case Key V.KDown -> vScrollBy vs 1 Key V.KUp -> vScrollBy vs (-1) @@ -797,3 +926,14 @@ Key V.KHome -> vScrollToBeginning vs Key V.KEnd -> vScrollToEnd vs _ -> return () + +-- * Util + +getScenariosAfterSelection :: + BL.GenericList n V.Vector (ScenarioItem a) -> + Int -> + [ScenarioWith a] +getScenariosAfterSelection m selIndex = + [x | SISingle x <- V.toList remaining] + where + remaining = snd $ BL.splitAt (selIndex + 1) $ listElements m diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -29,6 +29,19 @@ runFrameUI, runGameTickUI, ticksPerFrameCap, + + -- ** Event utilities + isRunning, + whenRunningAppState, + whenRunningPlayState, + runSingleTick, + adjustTPS, + toggleREPLVisibility, + showCESKDebug, + hideRobots, + toggleDiscoveryNotificationModal, + viewGoal, + toggleMessagesModal, ) where import Brick hiding (on) @@ -38,9 +51,9 @@ import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Text qualified as T -import Swarm.Game.Failure (SystemFailure (..)) +import Swarm.Failure (SystemFailure (..)) import Swarm.TUI.Controller.EventHandlers.Frame (runFrameUI, runGameTickUI, ticksPerFrameCap) -import Swarm.TUI.Controller.EventHandlers.Main (mainEventHandlers) +import Swarm.TUI.Controller.EventHandlers.Main (adjustTPS, hideRobots, isRunning, mainEventHandlers, runSingleTick, showCESKDebug, toggleDiscoveryNotificationModal, toggleMessagesModal, toggleREPLVisibility, viewGoal, whenRunningAppState, whenRunningPlayState) import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers) import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, robotEventHandlers) import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs @@ -26,7 +26,7 @@ import Swarm.TUI.Controller.Util import Swarm.TUI.Model import Swarm.TUI.Model.Achievements (popupAchievement) -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import System.Clock ticksPerFrameCap :: Int @@ -38,14 +38,13 @@ -- this may involve stepping the game any number of ticks (including -- zero). runFrameUI :: Bool -> EventM Name AppState () -runFrameUI forceRedraw = do - runFrame - redraw <- updateUI - unless (forceRedraw || redraw) continueWithoutRedraw +runFrameUI forceRedraw = Brick.zoom playState runFrame >> updateAndRedrawUI forceRedraw --- | Run the game for a single frame, without updating the UI. -runFrame :: EventM Name AppState () -runFrame = do +oneSecond :: Integer +oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds + +runFramePlayState :: EventM Name PlayState () +runFramePlayState = Brick.zoom scenarioState $ do -- Reset the needsRedraw flag. While processing the frame and stepping the robots, -- the flag will get set to true if anything changes that requires redrawing the -- world (e.g. a robot moving or disappearing). @@ -53,69 +52,79 @@ -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ . - -- Find out how long the previous frame took, by subtracting the - -- previous time from the current time. - prevTime <- use (uiState . uiGameplay . uiTiming . lastFrameTime) curTime <- liftIO $ getTime Monotonic - let frameTime = diffTimeSpec curTime prevTime - - -- Remember now as the new previous time. - uiState . uiGameplay . uiTiming . lastFrameTime .= curTime + Brick.zoom (uiGameplay . uiTiming) $ do + -- Find out how long the previous frame took, by subtracting the + -- previous time from the current time. + prevTime <- use lastFrameTime + let frameTime = diffTimeSpec curTime prevTime - -- We now have some additional accumulated time to play with. The - -- idea is to now "catch up" by doing as many ticks as are supposed - -- to fit in the accumulated time. Some accumulated time may be - -- left over, but it will roll over to the next frame. This way we - -- deal smoothly with things like a variable frame rate, the frame - -- rate not being a nice multiple of the desired ticks per second, - -- etc. - uiState . uiGameplay . uiTiming . accumulatedTime += frameTime + -- Remember now as the new previous time. + lastFrameTime .= curTime - -- Figure out how many ticks per second we're supposed to do, - -- and compute the timestep `dt` for a single tick. - lgTPS <- use (uiState . uiGameplay . uiTiming . lgTicksPerSecond) - let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds - dt - | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS) - | otherwise = oneSecond * (1 `shiftL` abs lgTPS) + -- We now have some additional accumulated time to play with. The + -- idea is to now "catch up" by doing as many ticks as are supposed + -- to fit in the accumulated time. Some accumulated time may be + -- left over, but it will roll over to the next frame. This way we + -- deal smoothly with things like a variable frame rate, the frame + -- rate not being a nice multiple of the desired ticks per second, + -- etc. + accumulatedTime += frameTime -- Update TPS/FPS counters every second - infoUpdateTime <- use (uiState . uiGameplay . uiTiming . lastInfoTime) + infoUpdateTime <- use (uiGameplay . uiTiming . lastInfoTime) let updateTime = toNanoSecs $ diffTimeSpec curTime infoUpdateTime when (updateTime >= oneSecond) $ do -- Wait for at least one second to have elapsed when (infoUpdateTime /= 0) $ do - -- set how much frame got processed per second - frames <- use (uiState . uiGameplay . uiTiming . frameCount) - uiState . uiGameplay . uiTiming . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime + Brick.zoom (uiGameplay . uiTiming) $ do + -- set how much frame got processed per second + frames <- use frameCount + uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime - -- set how much ticks got processed per frame - uiTicks <- use (uiState . uiGameplay . uiTiming . tickCount) - uiState . uiGameplay . uiTiming . uiTPF .= fromIntegral uiTicks / fromIntegral frames + -- set how much ticks got processed per frame + uiTicks <- use tickCount + uiTPF .= fromIntegral uiTicks / fromIntegral frames -- ensure this frame gets drawn gameState . needsRedraw .= True - -- Reset the counter and wait another seconds for the next update - uiState . uiGameplay . uiTiming . tickCount .= 0 - uiState . uiGameplay . uiTiming . frameCount .= 0 - uiState . uiGameplay . uiTiming . lastInfoTime .= curTime + Brick.zoom (uiGameplay . uiTiming) $ do + -- Reset the counter and wait another seconds for the next update + tickCount .= 0 + frameCount .= 0 + lastInfoTime .= curTime - -- Increment the frame count - uiState . uiGameplay . uiTiming . frameCount += 1 + Brick.zoom (uiGameplay . uiTiming) $ do + -- Increment the frame count + frameCount += 1 + frameTickCount .= 0 + +-- | Run the game for a single frame, without updating the UI. +runFrame :: EventM Name PlayState () +runFrame = do + runFramePlayState + + -- Figure out how many ticks per second we're supposed to do, + -- and compute the timestep `dt` for a single tick. + lgTPS <- use (scenarioState . uiGameplay . uiTiming . lgTicksPerSecond) + let dt + | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS) + | otherwise = oneSecond * (1 `shiftL` abs lgTPS) + -- Now do as many ticks as we need to catch up. - uiState . uiGameplay . uiTiming . frameTickCount .= 0 runFrameTicks (fromNanoSecs dt) -- | Do zero or more ticks, with each tick notionally taking the given -- timestep, until we have used up all available accumulated time, -- OR until we have hit the cap on ticks per frame, whichever comes -- first. -runFrameTicks :: TimeSpec -> EventM Name AppState () +runFrameTicks :: TimeSpec -> EventM Name PlayState () runFrameTicks dt = do - a <- use (uiState . uiGameplay . uiTiming . accumulatedTime) - t <- use (uiState . uiGameplay . uiTiming . frameTickCount) + timing <- use $ scenarioState . uiGameplay . uiTiming + let a = timing ^. accumulatedTime + t = timing ^. frameTickCount -- Ensure there is still enough time left, and we haven't hit the -- tick limit for this frame. @@ -123,7 +132,7 @@ -- If so, do a tick, count it, subtract dt from the accumulated time, -- and loop! runGameTick - Brick.zoom (uiState . uiGameplay . uiTiming) $ do + Brick.zoom (scenarioState . uiGameplay . uiTiming) $ do tickCount += 1 frameTickCount += 1 accumulatedTime -= dt @@ -131,30 +140,30 @@ -- | Run the game for a single tick, and update the UI. runGameTickUI :: EventM Name AppState () -runGameTickUI = runGameTick >> void updateUI +runGameTickUI = Brick.zoom playState runGameTick >> void updateUI -updateAchievements :: EventM Name AppState () +updateAchievements :: EventM Name PlayState () updateAchievements = do -- Merge the in-game achievements with the master list in UIState - achievementsFromGame <- use $ gameState . discovery . gameAchievements + achievementsFromGame <- use $ scenarioState . gameState . discovery . gameAchievements let wrappedGameAchievements = M.mapKeys GameplayAchievement achievementsFromGame - oldMasterAchievementsList <- use $ uiState . uiAchievements - uiState . uiAchievements %= M.unionWith (<>) wrappedGameAchievements + oldMasterAchievementsList <- use $ progression . attainedAchievements + progression . attainedAchievements %= M.unionWith (<>) wrappedGameAchievements -- Don't save to disk unless there was a change in the attainment list. let incrementalAchievements = wrappedGameAchievements `M.difference` oldMasterAchievementsList - unless (null incrementalAchievements) $ do + unless (null incrementalAchievements) $ Brick.zoom progression $ do mapM_ (popupAchievement . view achievement) incrementalAchievements - newAchievements <- use $ uiState . uiAchievements + newAchievements <- use attainedAchievements liftIO $ saveAchievementsInfo $ M.elems newAchievements -- | Run the game for a single tick (/without/ updating the UI). -- Every robot is given a certain amount of maximum computation to -- perform a single world action (like moving, turning, grabbing, -- etc.). -runGameTick :: EventM Name AppState () +runGameTick :: EventM Name PlayState () runGameTick = do - ticked <- zoomGameState gameTick + ticked <- zoomGameStateFromPlayState gameTick when ticked updateAchievements diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs @@ -6,6 +6,17 @@ -- Here is the main player configurable key event handler while playing the game. module Swarm.TUI.Controller.EventHandlers.Main ( mainEventHandlers, + isRunning, + whenRunningAppState, + whenRunningPlayState, + runSingleTick, + adjustTPS, + toggleREPLVisibility, + showCESKDebug, + hideRobots, + toggleDiscoveryNotificationModal, + viewGoal, + toggleMessagesModal, ) where import Brick @@ -13,9 +24,10 @@ import Control.Lens as Lens import Control.Monad (unless, void, when) import Control.Monad.IO.Class (liftIO) -import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot import Swarm.Game.State.Substate import Swarm.Game.Step (finishGameTick) import Swarm.TUI.Controller.EventHandlers.Frame (runGameTickUI) @@ -23,9 +35,12 @@ import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Model (isWorldEditorEnabled, worldOverdraw) import Swarm.TUI.Model +import Swarm.TUI.Model.DebugOption (DebugOption (ToggleCreative, ToggleWorldEditor)) +import Swarm.TUI.Model.Dialog.Goal import Swarm.TUI.Model.Event (MainEvent (..), SwarmEvent (..)) -import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.Menu import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import System.Clock (Clock (..), TimeSpec (..), getTime) -- | Main keybindings event handler while running the game itself. @@ -34,122 +49,170 @@ mainEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] mainEventHandlers = allHandlers Main $ \case QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) - ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) - ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) - ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) - ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) - ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) - ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) - ViewGoalEvent -> ("View scenario goal description", viewGoal) - HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) + ViewHelpEvent -> + ( "View Help screen" + , Brick.zoom (playState . scenarioState) $ toggleMidScenarioModal HelpModal + ) + ViewRobotsEvent -> + ( "View Robots screen" + , Brick.zoom (playState . scenarioState) $ toggleMidScenarioModal RobotsModal + ) + ViewRecipesEvent -> + ( "View Recipes screen" + , Brick.zoom (playState . scenarioState) $ toggleDiscoveryNotificationModal RecipesModal availableRecipes + ) + ViewCommandsEvent -> + ( "View Commands screen" + , Brick.zoom (playState . scenarioState) $ toggleDiscoveryNotificationModal CommandsModal availableCommands + ) + ViewMessagesEvent -> + ( "View Messages screen" + , Brick.zoom (playState . scenarioState) toggleMessagesModal + ) + ViewStructuresEvent -> + ( "View Structures screen" + , Brick.zoom (playState . scenarioState) $ + toggleStructuresModal (recognizerAutomatons . originalStructureDefinitions) + ) + ViewGoalEvent -> + ( "View scenario goal description" + , Brick.zoom (playState . scenarioState) viewGoal + ) + HideRobotsEvent -> ("Hide robots for a few ticks", Brick.zoom (playState . scenarioState . uiGameplay) hideRobots) ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) - PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) - RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) - IncreaseTpsEvent -> ("Double game speed", whenRunning . modify $ adjustTPS (+)) - DecreaseTpsEvent -> ("Halve game speed", whenRunning . modify $ adjustTPS (-)) - FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) - FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) - FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) - FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) - ToggleCreativeModeEvent -> ("Toggle creative mode", whenCheating toggleCreativeMode) - ToggleWorldEditorEvent -> ("Toggle world editor mode", whenCheating toggleWorldEditor) - ToggleREPLVisibilityEvent -> ("Collapse/Expand REPL panel", toggleREPLVisibility) + PauseEvent -> ("Pause or unpause the game", Brick.zoom (playState . scenarioState) $ whenRunningPlayState safeTogglePause) + RunSingleTickEvent -> ("Run game for a single tick", whenRunningAppState runSingleTick) + IncreaseTpsEvent -> ("Double game speed", Brick.zoom (playState . scenarioState) $ whenRunningPlayState . modify $ adjustTPS (+)) + DecreaseTpsEvent -> ("Halve game speed", Brick.zoom (playState . scenarioState) $ whenRunningPlayState . modify $ adjustTPS (-)) + FocusWorldEvent -> ("Set focus on the World panel", Brick.zoom (playState . scenarioState) $ setFocus WorldPanel) + FocusRobotEvent -> ("Set focus on the Robot panel", Brick.zoom (playState . scenarioState) $ setFocus RobotPanel) + FocusREPLEvent -> ("Set focus on the REPL panel", Brick.zoom (playState . scenarioState) $ setFocus REPLPanel) + FocusInfoEvent -> ("Set focus on the Info panel", Brick.zoom (playState . scenarioState) $ setFocus InfoPanel) + ToggleCreativeModeEvent -> ("Toggle creative mode", whenDebug ToggleCreative $ Brick.zoom (playState . scenarioState) toggleCreativeMode) + ToggleWorldEditorEvent -> ("Toggle world editor mode", whenDebug ToggleWorldEditor $ Brick.zoom (playState . scenarioState) toggleWorldEditor) + ToggleREPLVisibilityEvent -> ("Collapse/Expand REPL panel", Brick.zoom (playState . scenarioState) toggleREPLVisibility) + ViewBaseEvent -> ("View the base robot", Brick.zoom (playState . scenarioState) viewBase) + ToggleFPSEvent -> ("Toggle the FPS display", Brick.zoom (playState . scenarioState) toggleFPS) toggleQuitGameDialog :: EventM Name AppState () toggleQuitGameDialog = do s <- get - case s ^. gameState . winCondition of - WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal - WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal - _ -> toggleModal QuitModal + let whichModal = case s ^. playState . scenarioState . gameState . winCondition of + WinConditions (Won _ _) _ -> ScenarioFinishModal WinModal + WinConditions (Unwinnable _) _ -> ScenarioFinishModal LoseModal + _ -> QuitModal + Brick.zoom playState $ toggleEndScenarioModal whichModal $ s ^. uiState . uiMenu -toggleGameModal :: Foldable t => ModalType -> Getter GameState (t a) -> EventM Name AppState Bool +toggleGameModal :: + Foldable t => + MidScenarioModalType -> + Getter GameState (t a) -> + EventM Name ScenarioState Bool toggleGameModal m l = do s <- get let nothingToShow = null $ s ^. gameState . l - unless nothingToShow $ toggleModal m + + unless nothingToShow $ + toggleMidScenarioModal m return nothingToShow -toggleDiscoveryModal :: Foldable t => ModalType -> Lens' Discovery (t a) -> EventM Name AppState () -toggleDiscoveryModal m l = void $ toggleGameModal m (discovery . l) +toggleStructuresModal :: + Foldable t => + Lens' Landscape (t a) -> + EventM Name ScenarioState () +toggleStructuresModal l = void $ toggleGameModal StructuresModal (landscape . l) -toggleDiscoveryNotificationModal :: ModalType -> Lens' Discovery (Notifications a) -> EventM Name AppState () -toggleDiscoveryNotificationModal m l = do - nothingToShow <- toggleGameModal m (discovery . l . notificationsContent) +toggleDiscoveryNotificationModal :: + MidScenarioModalType -> + Lens' Discovery (Notifications a) -> + EventM Name ScenarioState () +toggleDiscoveryNotificationModal mt l = do + nothingToShow <- toggleGameModal mt $ discovery . l . notificationsContent unless nothingToShow $ gameState . discovery . l . notificationsCount .= 0 -toggleMessagesModal :: EventM Name AppState () +toggleMessagesModal :: EventM Name ScenarioState () toggleMessagesModal = do s <- get - nothingToShow <- toggleGameModal MessagesModal (messageNotifications . notificationsContent) + nothingToShow <- toggleGameModal MessagesModal $ messageNotifications . notificationsContent unless nothingToShow $ gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks -viewGoal :: EventM Name AppState () +viewGoal :: EventM Name ScenarioState () viewGoal = do s <- get - if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent - then toggleModal GoalModal + if hasAnythingToShow $ s ^. uiGameplay . uiDialogs . uiGoal . goalsContent + then toggleMidScenarioModal GoalModal else continueWithoutRedraw -hideRobots :: EventM Name AppState () +hideRobots :: EventM Name UIGameplay () hideRobots = do t <- liftIO $ getTime Monotonic - h <- use $ uiState . uiGameplay . uiHideRobotsUntil + h <- use uiHideRobotsUntil case h >= t of -- ignore repeated keypresses True -> continueWithoutRedraw -- hide for two seconds False -> do - uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 + uiHideRobotsUntil .= t + TimeSpec 2 0 invalidateCacheEntry WorldCache showCESKDebug :: EventM Name AppState () showCESKDebug = do s <- get - let isPaused = s ^. gameState . temporal . paused - let isCreative = s ^. gameState . creativeMode - let hasDebug = hasDebugCapability isCreative s + let isPaused = s ^. playState . scenarioState . gameState . temporal . paused + let isCreative = s ^. playState . scenarioState . gameState . creativeMode + let hasDebug = hasDebugCapability isCreative $ s ^. playState . scenarioState . gameState when (isPaused && hasDebug) $ do - debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not + debug <- playState . scenarioState . uiGameplay . uiShowDebug Lens.<%= not if debug - then gameState . temporal . gameStep .= RobotStep SBefore - else zoomGameState finishGameTick >> void updateUI + then playState . scenarioState . gameState . temporal . gameStep .= RobotStep SBefore + else zoomGameStateFromAppState finishGameTick >> void updateUI runSingleTick :: EventM Name AppState () runSingleTick = do - gameState . temporal . runStatus .= ManualPause + playState . scenarioState . gameState . temporal . runStatus .= ManualPause runGameTickUI -- | Adjust the ticks per second speed. -adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState -adjustTPS (+/-) = uiState . uiGameplay . uiTiming . lgTicksPerSecond %~ (+/- 1) +adjustTPS :: (Int -> Int -> Int) -> ScenarioState -> ScenarioState +adjustTPS (+/-) = uiGameplay . uiTiming . lgTicksPerSecond %~ (+/- 1) -toggleCreativeMode :: EventM Name AppState () +toggleCreativeMode :: EventM Name ScenarioState () toggleCreativeMode = gameState . creativeMode %= not -toggleWorldEditor :: EventM Name AppState () +toggleWorldEditor :: EventM Name ScenarioState () toggleWorldEditor = do - uiState . uiGameplay . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not + uiGameplay . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not setFocus WorldEditorPanel -toggleREPLVisibility :: EventM Name AppState () +toggleREPLVisibility :: EventM Name ScenarioState () toggleREPLVisibility = do invalidateCacheEntry WorldCache - uiState . uiGameplay . uiShowREPL %= not + uiGameplay . uiShowREPL %= not +viewBase :: EventM Name ScenarioState () +viewBase = do + invalidateCacheEntry WorldCache + gameState . robotInfo . viewCenterRule .= VCRobot 0 + +toggleFPS :: EventM Name ScenarioState () +toggleFPS = uiGameplay . uiTiming . uiShowFPS %= not + -- ---------------------------------------------- -- HELPER UTILS -- ---------------------------------------------- -isRunning :: EventM Name AppState Bool +isRunning :: EventM Name ScenarioState Bool isRunning = do - mt <- preuse $ uiState . uiGameplay . uiModal . _Just . modalType + mt <- preuse $ uiGameplay . uiDialogs . uiModal . _Just . modalType return $ maybe True isRunningModal mt -whenRunning :: EventM Name AppState () -> EventM Name AppState () -whenRunning a = isRunning >>= \r -> when r a +whenRunningAppState :: EventM Name AppState () -> EventM Name AppState () +whenRunningAppState a = Brick.zoom (playState . scenarioState) isRunning >>= \r -> when r a -whenCheating :: EventM Name AppState () -> EventM Name AppState () -whenCheating a = do - s <- get - when (s ^. uiState . uiCheatMode) a +whenRunningPlayState :: EventM Name ScenarioState () -> EventM Name ScenarioState () +whenRunningPlayState a = isRunning >>= \r -> when r a + +whenDebug :: DebugOption -> EventM Name AppState () -> EventM Name AppState () +whenDebug d a = do + debug <- use $ uiState . uiDebugOptions . contains d + when debug a diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs @@ -22,47 +22,47 @@ import Swarm.TUI.Model import Swarm.TUI.Model.Event import Swarm.TUI.Model.Repl -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay -- | Handle a user input key event for the REPL. -- -- See 'Swarm.TUI.Controller.handleREPLEvent'. replEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] replEventHandlers = allHandlers REPL $ \case - CancelRunningProgramEvent -> ("Cancel running base robot program", cancelRunningBase) - TogglePilotingModeEvent -> ("Toggle piloting mode", onlyCreative togglePilotingMode) - ToggleCustomKeyHandlingEvent -> ("Toggle custom key handling mode", toggleCustomKeyHandling) + CancelRunningProgramEvent -> ("Cancel running base robot program", Brick.zoom (playState . scenarioState) cancelRunningBase) + TogglePilotingModeEvent -> ("Toggle piloting mode", Brick.zoom (playState . scenarioState) $ onlyCreative togglePilotingMode) + ToggleCustomKeyHandlingEvent -> ("Toggle custom key handling mode", Brick.zoom (playState . scenarioState) toggleCustomKeyHandling) -- | Cancel the running base CESK machine and clear REPL input text. -- -- It is handled in top REPL handler so we can always cancel the currently running -- base program no matter what REPL control mode we are in. -cancelRunningBase :: EventM Name AppState () +cancelRunningBase :: EventM Name ScenarioState () cancelRunningBase = do working <- use $ gameState . gameControls . replWorking when working $ gameState . baseRobot . machine %= cancel - Brick.zoom (uiState . uiGameplay . uiREPL) $ do + Brick.zoom (uiGameplay . uiREPL) $ do replPromptType .= CmdPrompt [] replPromptText .= "" -togglePilotingMode :: EventM Name AppState () +togglePilotingMode :: EventM Name ScenarioState () togglePilotingMode = do s <- get - let theRepl = s ^. uiState . uiGameplay . uiREPL + let theRepl = s ^. uiGameplay . uiREPL uinput = theRepl ^. replPromptText - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + curMode = theRepl ^. replControlMode case curMode of - Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing + Piloting -> uiGameplay . uiREPL . replControlMode .= Typing _ -> if T.null uinput - then uiState . uiGameplay . uiREPL . replControlMode .= Piloting + then uiGameplay . uiREPL . replControlMode .= Piloting else do - addREPLHistItem $ mkREPLError "Please clear the REPL before engaging pilot mode." + addREPLHistItem REPLError "Please clear the REPL before engaging pilot mode." invalidateCacheEntry REPLHistoryCache -toggleCustomKeyHandling :: EventM Name AppState () +toggleCustomKeyHandling :: EventM Name ScenarioState () toggleCustomKeyHandling = do s <- get when (isJust (s ^. gameState . gameControls . inputHandler)) $ do - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode - (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling + curMode <- use $ uiGameplay . uiREPL . replControlMode + (uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs @@ -31,20 +31,23 @@ import Swarm.TUI.List import Swarm.TUI.Model import Swarm.TUI.Model.Event -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.Menu +import Swarm.TUI.Model.UI.Gameplay import Swarm.TUI.View.Util (generateModal) -- | Handle user input events in the robot panel. handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleRobotPanelEvent bev = do - search <- use $ uiState . uiGameplay . uiInventory . uiInventorySearch + search <- use $ playState . scenarioState . uiGameplay . uiInventory . uiInventorySearch keyHandler <- use $ keyEventHandling . keyDispatchers . to robotDispatcher case search of Just _ -> handleInventorySearchEvent bev Nothing -> case bev of VtyEvent ev@(V.EvKey k m) -> do handled <- handleKey keyHandler k m - unless handled $ handleInventoryListEvent ev + unless handled $ + Brick.zoom (playState . scenarioState . uiGameplay) $ + handleInventoryListEvent ev _ -> continueWithoutRedraw -- | Handle key events in the robot panel. @@ -52,31 +55,31 @@ robotEventHandlers = nonCustomizableHandlers <> customizableHandlers where nonCustomizableHandlers = - [ onKey V.KEnter "Show entity description" showEntityDescription + [ onKey V.KEnter "Show entity description" $ Brick.zoom (playState . scenarioState) showEntityDescription ] customizableHandlers = allHandlers Robot $ \case - MakeEntityEvent -> ("Make the selected entity", makeFocusedEntity) + MakeEntityEvent -> ("Make the selected entity", Brick.zoom (playState . scenarioState) makeFocusedEntity) ShowZeroInventoryEntitiesEvent -> ("Show entities with zero count in inventory", zoomInventory showZero) CycleInventorySortEvent -> ("Cycle inventory sorting type", zoomInventory cycleSort) SwitchInventorySortDirection -> ("Switch ascending/descending inventory sort", zoomInventory switchSortDirection) SearchInventoryEvent -> ("Start inventory search", zoomInventory searchInventory) -- | Display a modal window with the description of an entity. -showEntityDescription :: EventM Name AppState () +showEntityDescription :: EventM Name ScenarioState () showEntityDescription = gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal where - descriptionModal :: Entity -> EventM Name AppState () + descriptionModal :: Entity -> EventM Name ScenarioState () descriptionModal e = do s <- get resetViewport modalScroll - uiState . uiGameplay . uiModal ?= generateModal s (DescriptionModal e) + uiGameplay . uiDialogs . uiModal ?= generateModal s (DescriptionModal e) -- | Attempt to make an entity selected from the inventory, if the -- base is not currently busy. -makeFocusedEntity :: EventM Name AppState () +makeFocusedEntity :: EventM Name ScenarioState () makeFocusedEntity = gets focusedEntity >>= maybe continueWithoutRedraw makeEntity where - makeEntity :: Entity -> EventM Name AppState () + makeEntity :: Entity -> EventM Name ScenarioState () makeEntity e = do s <- get let name = e ^. entityName @@ -98,20 +101,20 @@ searchInventory = uiInventorySearch .= Just "" -- | Handle an event to navigate through the inventory list. -handleInventoryListEvent :: V.Event -> EventM Name AppState () +handleInventoryListEvent :: V.Event -> EventM Name UIGameplay () handleInventoryListEvent ev = do -- Note, refactoring like this is tempting: -- -- Brick.zoom (uiState . ... . _Just . _2) (handleListEventWithSeparators ev (is _Separator)) -- -- However, this does not work since we want to skip redrawing in the no-list case! - mList <- preuse $ uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 + mList <- preuse $ uiInventory . uiInventoryList . _Just . _2 case mList of Nothing -> continueWithoutRedraw Just l -> do when (isValidListMovement ev) $ resetViewport infoScroll l' <- nestEventM' l (handleListEventWithSeparators ev (is _Separator)) - uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 .= l' + uiInventory . uiInventoryList . _Just . _2 .= l' -- ---------------------------------------------- -- INVENTORY SEARCH @@ -127,7 +130,7 @@ -- Enter: return to regular inventory mode, and pop out the selected item Key V.KEnter -> do zoomInventory $ uiInventorySearch .= Nothing - showEntityDescription + Brick.zoom (playState . scenarioState) showEntityDescription -- Any old character: append to the current search string CharKey c -> do resetViewport infoScroll @@ -137,7 +140,7 @@ zoomInventory $ uiInventorySearch %= fmap (T.dropEnd 1) -- Handle any other event as list navigation, so we can look through -- the filtered inventory using e.g. arrow keys - VtyEvent ev -> handleInventoryListEvent ev + VtyEvent ev -> Brick.zoom (playState . scenarioState . uiGameplay) $ handleInventoryListEvent ev _ -> continueWithoutRedraw -- ---------------------------------------------- @@ -145,6 +148,6 @@ -- ---------------------------------------------- zoomInventory :: EventM Name UIInventory () -> EventM Name AppState () -zoomInventory act = Brick.zoom (uiState . uiGameplay . uiInventory) $ do +zoomInventory act = Brick.zoom (playState . scenarioState . uiGameplay . uiInventory) $ do uiInventoryShouldUpdate .= True act diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs @@ -22,27 +22,16 @@ import Swarm.TUI.Controller.Util import Swarm.TUI.Model import Swarm.TUI.Model.Event -import Swarm.TUI.Model.UI -- | Handle a user input event in the world view panel. worldEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] worldEventHandlers = allHandlers World $ \case - ViewBaseEvent -> ("View the base robot", viewBase) - ShowFpsEvent -> ("Show frames per second", showFps) MoveViewEvent d -> ("Scroll world view in the " <> directionSyntax (DAbsolute d) <> " direction", scrollViewInDir $ toHeading d) -viewBase :: EventM Name AppState () -viewBase = do - invalidateCacheEntry WorldCache - gameState . robotInfo . viewCenterRule .= VCRobot 0 - -showFps :: EventM Name AppState () -showFps = uiState . uiGameplay . uiTiming . uiShowFPS %= not - scrollViewInDir :: V2 Int32 -> EventM Name AppState () scrollViewInDir d = do - c <- use $ gameState . creativeMode - s <- use $ gameState . landscape . worldScrollable + c <- use $ playState . scenarioState . gameState . creativeMode + s <- use $ playState . scenarioState . gameState . landscape . worldScrollable when (c || s) $ scrollView (.+^ (worldScrollDist *^ d)) worldScrollDist :: Int32 @@ -56,4 +45,4 @@ -- always work, but there seems to be some sort of race condition -- where 'needsRedraw' gets reset before the UI drawing code runs. invalidateCacheEntry WorldCache - gameState . robotInfo %= modifyViewCenter (fmap update) + playState . scenarioState . gameState . robotInfo %= modifyViewCenter (fmap update) diff --git a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs --- a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs @@ -9,110 +9,109 @@ ) where -- See Note [liftA2 re-export from Prelude] -import Brick.Widgets.List qualified as BL + +import Brick import Control.Lens as Lens -import Control.Monad (forM_, unless, void, when) +import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.State (MonadState) -import Data.Maybe (fromMaybe) -import Data.Time (getZonedTime) +import Data.Maybe (listToMaybe) +import Data.Set (Set) +import Data.Time (ZonedTime, getZonedTime) import Swarm.Game.Achievement.Definitions -import Swarm.Game.Scenario.Status (updateScenarioInfoOnFinish) +import Swarm.Game.Scenario.Status import Swarm.Game.ScenarioInfo import Swarm.Game.State -import Swarm.Game.State.Runtime import Swarm.Game.State.Substate import Swarm.TUI.Model -import Swarm.TUI.Model.Achievements (attainAchievement') +import Swarm.TUI.Model.Achievements (attainAchievement, attainAchievement') +import Swarm.TUI.Model.DebugOption (DebugOption) import Swarm.TUI.Model.Repl -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import System.FilePath (splitDirectories) -import Prelude hiding (Applicative (..)) -getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) -getNormalizedCurrentScenarioPath = +getNormalizedCurrentScenarioPath :: + MonadIO m => + GameState -> + ScenarioCollection a -> + m (Maybe FilePath) +getNormalizedCurrentScenarioPath gs sc = do -- the path should be normalized and good to search in scenario collection - use (gameState . currentScenarioPath) >>= \case - Nothing -> return Nothing - Just p' -> do - gs <- use $ runtimeState . scenarios - Just <$> liftIO (normalizeScenarioPath gs p') + traverse (liftIO . normalizeScenarioPath sc . getScenarioPath) $ gs ^. currentScenarioPath -saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo) +applyCompletionAchievements :: + Bool -> + ZonedTime -> + FilePath -> + EventM n ProgressionState () +applyCompletionAchievements won t p = do + forM_ (listToMaybe $ splitDirectories p) $ \firstDir -> do + when (won && firstDir == tutorialsDirname) $ + attainAchievement' t (Just $ ScenarioPath p) $ + GlobalAchievement CompletedSingleTutorial + + -- Check if all tutorials have been completed + tutorialMap <- use $ scenarios . to getTutorials . to scMap + let isComplete (SISingle (ScenarioWith _ s)) = scenarioIsCompleted s + -- There are not currently any subcollections within the + -- tutorials, but checking subcollections recursively just seems + -- like the right thing to do + isComplete (SICollection _ (SC m)) = all isComplete m + + when (all isComplete tutorialMap) $ + attainAchievement $ + GlobalAchievement CompletedAllTutorials + +saveScenarioInfoOnFinish :: + FilePath -> + EventM n PlayState () saveScenarioInfoOnFinish p = do - initialRunCode <- use $ gameState . gameControls . initiallyRunCode + initialRunCode <- use $ scenarioState . gameState . gameControls . initiallyRunCode t <- liftIO getZonedTime - wc <- use $ gameState . winCondition + wc <- use $ scenarioState . gameState . winCondition let won = case wc of WinConditions (Won _ _) _ -> True _ -> False - ts <- use $ gameState . temporal . ticks + ts <- use $ scenarioState . gameState . temporal . ticks + saved <- use $ scenarioState . gameState . completionStatsSaved - -- NOTE: This traversal is apparently not the same one as used by - -- the scenario selection menu, so the menu needs to be updated separately. - -- See Note [scenario menu update] - let currentScenarioInfo :: Traversal' AppState ScenarioInfo - currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2 + let currentScenarioInfo :: Traversal' PlayState ScenarioInfo + currentScenarioInfo = progression . scenarios . scenarioItemByPath p . _SISingle . getScenarioInfo - replHist <- use $ uiState . uiGameplay . uiREPL . replHistory + replHist <- use $ scenarioState . uiGameplay . uiREPL . replHistory let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput - currentScenarioInfo - %= updateScenarioInfoOnFinish determinator t ts won + + -- Don't update scenario statistics if we have previously saved + -- statistics for the current scenario upon scenario completion. + unless saved $ + currentScenarioInfo + %= updateScenarioInfoOnFinish determinator t ts won + status <- preuse currentScenarioInfo - case status of - Nothing -> return () - Just si -> do - let segments = splitDirectories p - case segments of - firstDir : _ -> do - when (won && firstDir == tutorialsDirname) $ - attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial) - _ -> return () - liftIO $ saveScenarioInfo p si - return status + forM_ status $ \si -> do + liftIO $ saveScenarioInfo p si + Brick.zoom progression $ applyCompletionAchievements won t p + scenarioState . gameState . completionStatsSaved .= won + +-- | Don't save progress for developers or cheaters. +unlessCheating :: Set DebugOption -> EventM n PlayState () -> EventM n PlayState () +unlessCheating dOpts a = do + isAuto <- use $ scenarioState . uiGameplay . uiIsAutoPlay + when (null dOpts && not isAuto) a + -- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit). -saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m () -saveScenarioInfoOnFinishNocheat = do - -- Don't save progress if we are in cheat mode - cheat <- use $ uiState . uiCheatMode - unless cheat $ do +saveScenarioInfoOnFinishNocheat :: Set DebugOption -> EventM n PlayState () +saveScenarioInfoOnFinishNocheat dOpts = do + sc <- use $ progression . scenarios + gs <- use $ scenarioState . gameState + unlessCheating dOpts $ -- the path should be normalized and good to search in scenario collection - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> void $ saveScenarioInfoOnFinish p + getNormalizedCurrentScenarioPath gs sc >>= mapM_ saveScenarioInfoOnFinish -- | Write the @ScenarioInfo@ out to disk when exiting a game. -saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () -saveScenarioInfoOnQuit = do - -- Don't save progress if we are in cheat mode - -- NOTE This check is duplicated in "saveScenarioInfoOnFinishNocheat" - cheat <- use $ uiState . uiCheatMode - unless cheat $ do - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> do - maybeSi <- saveScenarioInfoOnFinish p - -- Note [scenario menu update] - -- Ensures that the scenario selection menu gets updated - -- with the high score/completion status - forM_ - maybeSi - ( uiState - . uiMenu - . _NewGameMenu - . ix 0 - . BL.listSelectedElementL - . _SISingle - . _2 - .= - ) - - -- See what scenario is currently focused in the menu. Depending on how the - -- previous scenario ended (via quit vs. via win), it might be the same as - -- currentScenarioPath or it might be different. - curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath - -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, - -- being sure to preserve the same focused scenario. - sc <- use $ runtimeState . scenarios - forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=) +saveScenarioInfoOnQuit :: Set DebugOption -> EventM n PlayState () +saveScenarioInfoOnQuit dOpts = do + sc <- use $ progression . scenarios + gs <- use $ scenarioState . gameState + unlessCheating dOpts $ + getNormalizedCurrentScenarioPath gs sc >>= mapM_ saveScenarioInfoOnFinish diff --git a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs --- a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs @@ -6,63 +6,72 @@ -- The main TUI update logic that is called from other controller parts. module Swarm.TUI.Controller.UpdateUI ( updateUI, + updateAndRedrawUI, + updateRobotDetailsPane, ) where -import Brick hiding (Direction, Location) -import Brick.Focus - -- See Note [liftA2 re-export from Prelude] + +import Brick hiding (Direction, Location, on) +import Brick.Focus import Brick.Widgets.List qualified as BL -import Control.Applicative (liftA2, pure) import Control.Lens as Lens -import Control.Monad (unless, when) +import Control.Monad (forM_, unless, when) +import Control.Monad.IO.Class (liftIO) import Data.Foldable (toList) import Data.List.Extra (enumerate) -import Data.Maybe (isNothing) +import Data.Map.Strict qualified as M +import Data.Maybe (fromMaybe, isNothing) +import Data.Set (Set) +import Data.Set qualified as S import Data.String (fromString) import Data.Text qualified as T +import Data.Vector qualified as V import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Popup (Popup (..), addPopup) import Swarm.Game.Robot +import Swarm.Game.Robot.Activity import Swarm.Game.Robot.Concrete import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Substate -import Swarm.Language.Pretty import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Types -import Swarm.Language.Value (Value (VExc, VUnit), envTydefs, prettyValue) +import Swarm.Language.Value (Value (VExc, VUnit), emptyEnv, envTydefs, prettyValue) +import Swarm.Pretty import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnFinishNocheat) import Swarm.TUI.Controller.Util import Swarm.TUI.Model -import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.DebugOption (DebugOption (..)) +import Swarm.TUI.Model.Dialog.Goal +import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name -import Swarm.TUI.Model.Popup (Popup (..), addPopup) import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import Swarm.TUI.View.Objective qualified as GR +import Swarm.TUI.View.Robot +import Swarm.TUI.View.Robot.Type import Witch (into) -import Prelude hiding (Applicative (..)) --- | Update the UI. This function is used after running the --- game for some number of ticks. -updateUI :: EventM Name AppState Bool -updateUI = do - loadVisibleRegion - - -- If the game state indicates a redraw is needed, invalidate the - -- world cache so it will be redrawn. - g <- use gameState - when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache +-- | Update the UI and redraw if needed. +-- +-- This function is used after running the game for some number of ticks. +updateAndRedrawUI :: Bool -> EventM Name AppState () +updateAndRedrawUI forceRedraw = do + redraw <- updateUI + unless (forceRedraw || redraw) continueWithoutRedraw +checkInventoryUpdated :: Maybe Robot -> EventM Name ScenarioState Bool +checkInventoryUpdated fr = do -- The hash of the robot whose inventory is currently displayed (if any) - listRobotHash <- fmap fst <$> use (uiState . uiGameplay . uiInventory . uiInventoryList) + listRobotHash <- fmap fst <$> use (uiGameplay . uiInventory . uiInventoryList) -- The hash of the focused robot (if any) - fr <- use (gameState . to focusedRobot) let focusedRobotHash = view inventoryHash <$> fr -- Check if the inventory list needs to be updated. - shouldUpdate <- use (uiState . uiGameplay . uiInventory . uiInventoryShouldUpdate) + shouldUpdate <- use (uiGameplay . uiInventory . uiInventoryShouldUpdate) -- Whether the focused robot is too far away to sense, & whether -- that has recently changed @@ -75,80 +84,114 @@ -- (either because which robot (or whether any robot) is focused -- changed, or the focused robot's inventory changed), or the -- inventory was flagged to be updated, regenerate the inventory list. - inventoryUpdated <- - if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate - then do - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - populateInventoryList $ if tooFar then Nothing else fr - uiInventoryShouldUpdate .= False - pure True - else pure False + let shouldRegenerateInventory = farChanged || listRobotHash /= focusedRobotHash || shouldUpdate + when shouldRegenerateInventory $ + Brick.zoom (uiGameplay . uiInventory) $ do + populateInventoryList $ if tooFar then Nothing else fr + uiInventoryShouldUpdate .= False + return shouldRegenerateInventory +checkReplUpdated :: GameState -> EventM Name ScenarioState Bool +checkReplUpdated g = case g ^. gameControls . replStatus of -- Now check if the base finished running a program entered at the REPL. - replUpdated <- case g ^. gameControls . replStatus of - REPLWorking pty (Just v) - -- It did, and the result was the unit value or an exception. Just reset replStatus. - | v `elem` [VUnit, VExc] -> do - gameState . gameControls . replStatus .= REPLDone (Just (pty, v)) - pure True + REPLWorking pty (Just v) + -- It did, and the result was the unit value or an exception. Just reset replStatus. + | v `elem` [VUnit, VExc] -> do + listener <- use $ gameState . gameControls . replListener + liftIO $ listener "" + gameState . gameControls . replStatus .= REPLDone (Just (pty, v)) + pure True - -- It did, and returned some other value. Create new 'it' - -- variables, pretty-print the result as a REPL output, with its - -- type, and reset the replStatus. - | otherwise -> do - itIx <- use (gameState . gameControls . replNextValueIndex) - env <- use (gameState . baseEnv) - let finalType = stripCmd (env ^. envTydefs) pty - itName = fromString $ "it" ++ show itIx - out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] - addREPLHistItem (mkREPLOutput out) - invalidateCacheEntry REPLHistoryCache - vScrollToEnd replScroll - gameState . gameControls . replStatus .= REPLDone (Just (finalType, v)) - gameState . baseEnv . at itName .= Just (Typed v finalType mempty) - gameState . baseEnv . at "it" .= Just (Typed v finalType mempty) - gameState . gameControls . replNextValueIndex %= (+ 1) - pure True + -- It did, and returned some other value. Create new 'it' + -- variables, pretty-print the result as a REPL output, with its + -- type, and reset the replStatus. + | otherwise -> do + itIx <- use (gameState . gameControls . replNextValueIndex) + env <- fromMaybe emptyEnv <$> preuse (gameState . baseEnv) + let finalType = stripCmd (env ^. envTydefs) pty + itName = fromString $ "it" ++ show itIx + out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] + addREPLHistItem REPLOutput out + listener <- use $ gameState . gameControls . replListener + liftIO $ listener out + invalidateCacheEntry REPLHistoryCache + vScrollToEnd replScroll - -- Otherwise, do nothing. - _ -> pure False + Brick.zoom gameState $ do + gameControls . replStatus .= REPLDone (Just (finalType, v)) + baseEnv . at itName .= Just (Typed v finalType mempty) + baseEnv . at "it" .= Just (Typed v finalType mempty) + gameControls . replNextValueIndex %= (+ 1) + pure True + -- Otherwise, do nothing. + _ -> pure False + +checkLogUpdated :: Maybe Robot -> EventM Name ScenarioState Bool +checkLogUpdated fr = do + -- If the inventory or info panels are currently focused, it would + -- be rude to update them right under the user's nose, so consider + -- them "sticky". They will be updated as soon as the player moves + -- the focus away. + fring <- use $ uiGameplay . uiFocusRing + let sticky = focusGetCurrent fring `elem` map (Just . FocusablePanel) [RobotPanel, InfoPanel] + + -- Check if the robot log was updated and we are allowed to change + -- the inventory+info panels. + case maybe False (view robotLogUpdated) fr && not sticky of + False -> pure False + True -> do + -- Reset the log updated flag + zoomGameStateFromScenarioState $ zoomRobots clearFocusedRobotLogUpdated + + -- Find and focus an equipped "logger" device in the inventory list. + let isLogger (EquippedEntry e) = e ^. entityName == "logger" + isLogger _ = False + focusLogger = BL.listFindBy isLogger + + uiGameplay . uiInventory . uiInventoryList . _Just . _2 %= focusLogger + + -- Now inform the UI that it should scroll the info panel to + -- the very end. + uiGameplay . uiScrollToEnd .= True + pure True + +-- | Update the UI. This function is used after running the +-- game for some number of ticks. +updateUI :: EventM Name AppState Bool +updateUI = do + g <- use $ playState . scenarioState . gameState + + Brick.zoom (playState . scenarioState . gameState) loadVisibleRegion + + -- If the game state indicates a redraw is needed, invalidate the + -- world cache so it will be redrawn. + when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache + + let fr = g ^. to focusedRobot + inventoryUpdated <- Brick.zoom (playState . scenarioState) $ checkInventoryUpdated fr + + -- Now check if the base finished running a program entered at the REPL. + replUpdated <- Brick.zoom (playState . scenarioState) $ checkReplUpdated g + -- If the focused robot's log has been updated and the UI focus -- isn't currently on the inventory or info panels, attempt to -- automatically switch to the logger and scroll all the way down so -- the new message can be seen. - uiState . uiGameplay . uiScrollToEnd .= False - logUpdated <- do - -- If the inventory or info panels are currently focused, it would - -- be rude to update them right under the user's nose, so consider - -- them "sticky". They will be updated as soon as the player moves - -- the focus away. - fring <- use $ uiState . uiGameplay . uiFocusRing - let sticky = focusGetCurrent fring `elem` map (Just . FocusablePanel) [RobotPanel, InfoPanel] - - -- Check if the robot log was updated and we are allowed to change - -- the inventory+info panels. - case maybe False (view robotLogUpdated) fr && not sticky of - False -> pure False - True -> do - -- Reset the log updated flag - zoomGameState $ zoomRobots clearFocusedRobotLogUpdated - - -- Find and focus an equipped "logger" device in the inventory list. - let isLogger (EquippedEntry e) = e ^. entityName == "logger" - isLogger _ = False - focusLogger = BL.listFindBy isLogger - - uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 %= focusLogger + playState . scenarioState . uiGameplay . uiScrollToEnd .= False + logUpdated <- Brick.zoom (playState . scenarioState) $ checkLogUpdated fr - -- Now inform the UI that it should scroll the info panel to - -- the very end. - uiState . uiGameplay . uiScrollToEnd .= True - pure True + menu <- use $ uiState . uiMenu + dOps <- use $ uiState . uiDebugOptions + goalOrWinUpdated <- Brick.zoom playState $ doGoalUpdates dOps menu - goalOrWinUpdated <- doGoalUpdates + newPopups <- Brick.zoom playState generateNotificationPopups - newPopups <- generateNotificationPopups + -- Update the robots modal only when it is enabled. See #2370. + curModal <- use $ playState . scenarioState . uiGameplay . uiDialogs . uiModal + when ((view modalType <$> curModal) == Just (MidScenarioModal RobotsModal)) $ + Brick.zoom (playState . scenarioState . uiGameplay . uiDialogs . uiRobot) $ + doRobotListUpdate dOps g let redraw = g ^. needsRedraw @@ -159,6 +202,19 @@ || newPopups pure redraw +doRobotListUpdate :: Set DebugOption -> GameState -> EventM Name RobotDisplay () +doRobotListUpdate dOps g = do + robotsGridList %= updateRobotList dOps g + rList <- use robotsGridList + let mRob = getSelectedRobot g rList + forM_ mRob $ \r -> do + Brick.zoom robotDetailsPaneState $ updateRobotDetailsPane r + +updateRobotDetailsPane :: Robot -> EventM Name RobotDetailsPaneState () +updateRobotDetailsPane rob = do + cmdHistogramList . BL.listElementsL .= V.fromList (M.toList (rob ^. activityCounts . commandsHistogram)) + logsList . BL.listElementsL .= (rob ^. robotLog) + -- | Either pops up the updated Goals modal -- or pops up the Congratulations (Win) modal, or pops -- up the Condolences (Lose) modal. @@ -171,102 +227,104 @@ -- * feedback as to the final goal the player accomplished, -- * as a summary of all of the goals of the game -- * shows the player more "optional" goals they can continue to pursue -doGoalUpdates :: EventM Name AppState Bool -doGoalUpdates = do - curGoal <- use (uiState . uiGameplay . uiGoal . goalsContent) - isCheating <- use (uiState . uiCheatMode) - curWinCondition <- use (gameState . winCondition) - announcementsSeq <- use (gameState . messageInfo . announcementQueue) - let announcementsList = toList announcementsSeq +doGoalUpdates :: Set DebugOption -> Menu -> EventM Name PlayState Bool +doGoalUpdates dOpts menu = do + curGoal <- use (scenarioState . uiGameplay . uiDialogs . uiGoal . goalsContent) + curWinCondition <- use (scenarioState . gameState . winCondition) + announcementsList <- use (scenarioState . gameState . messageInfo . announcementQueue . to toList) + let showHiddenGoals = ShowHiddenGoals `S.member` dOpts -- Decide whether we need to update the current goal text and pop -- up a modal dialog. case curWinCondition of NoWinCondition -> return False - WinConditions (Unwinnable False) x -> do - -- This clears the "flag" that the Lose dialog needs to pop up - gameState . winCondition .= WinConditions (Unwinnable True) x - openModal $ ScenarioEndModal LoseModal - saveScenarioInfoOnFinishNocheat - return True + WinConditions (Unwinnable False) x -> + setFinishState LoseModal (Unwinnable True) x WinConditions (Won False ts) x -> do - -- This clears the "flag" that the Win dialog needs to pop up - gameState . winCondition .= WinConditions (Won True ts) x - openModal $ ScenarioEndModal WinModal - saveScenarioInfoOnFinishNocheat - -- We do NOT advance the New Game menu to the next item here (we - -- used to!), because we do not know if the user is going to - -- select 'keep playing' or 'next challenge'. We maintain the - -- invariant that the current menu item is always the same as - -- the scenario currently being played. If the user either (1) - -- quits to the menu or (2) selects 'next challenge' we will - -- advance the menu at that point. - return True - WinConditions _ oc -> do - let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc + setFinishState WinModal (Won True ts) x + WinConditions _ oc -> Brick.zoom scenarioState $ do + currentModal <- preuse $ uiGameplay . uiDialogs . uiModal . _Just . modalType + let newGoalTracking = GoalTracking announcementsList $ constructGoalMap showHiddenGoals oc -- The "uiGoal" field is initialized with empty members, so we know that -- this will be the first time showing it if it will be nonempty after previously -- being empty. isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal) goalWasUpdated = isFirstGoalDisplay || not (null announcementsList) + isEnding = maybe False isEndingModal currentModal -- Decide whether to show a pop-up modal congratulating the user on -- successfully completing the current challenge. - when goalWasUpdated $ do - let hasMultiple = hasMultipleGoals newGoalTracking - defaultFocus = - if hasMultiple - then ObjectivesList - else GoalSummary - - ring = - focusRing $ - map GoalWidgets $ - if hasMultiple - then enumerate - else [GoalSummary] - + when (goalWasUpdated && not isEnding) $ do -- The "uiGoal" field is necessary at least to "persist" the data that is needed -- if the player chooses to later "recall" the goals dialog with CTRL+g. - uiState - . uiGameplay - . uiGoal - .= GoalDisplay - newGoalTracking - (GR.makeListWidget newGoalTracking) - (focusSetCurrent (GoalWidgets defaultFocus) ring) + uiGameplay . uiDialogs . uiGoal .= goalDisplay newGoalTracking -- This clears the "flag" that indicate that the goals dialog needs to be -- automatically popped up. gameState . messageInfo . announcementQueue .= mempty - hideGoals <- use $ uiState . uiGameplay . uiHideGoals - unless hideGoals $ - openModal GoalModal + showObjectives <- use $ uiGameplay . uiAutoShowObjectives + when showObjectives $ openMidScenarioModal GoalModal return goalWasUpdated + where + setFinishState :: ScenarioOutcome -> WinStatus -> ObjectiveCompletion -> EventM Name PlayState Bool + setFinishState m result x = do + -- This clears the "flag" that the Lose dialog needs to pop up + scenarioState . gameState . winCondition .= WinConditions result x + openEndScenarioModal menu $ ScenarioFinishModal m + saveScenarioInfoOnFinishNocheat dOpts + + -- We do NOT advance the New Game menu to the next item here (we + -- used to!), because we do not know if the user is going to + -- select 'keep playing' or 'next challenge'. We maintain the + -- invariant that the current menu item is always the same as + -- the scenario currently being played. If the user either (1) + -- quits to the menu or (2) selects 'next challenge' we will + -- advance the menu at that point. + return True + + goalDisplay :: GoalTracking -> GoalDisplay + goalDisplay newGoalTracking = + let multiple = hasMultipleGoals newGoalTracking + in GoalDisplay + newGoalTracking + (GR.makeListWidget newGoalTracking) + (focusSetCurrent (GoalWidgets $ goalFocus multiple) (goalFocusRing multiple)) + + goalFocus :: Bool -> GoalWidget + goalFocus hasMultiple = if hasMultiple then ObjectivesList else GoalSummary + + goalFocusRing :: Bool -> FocusRing Name + goalFocusRing hasMultiple = focusRing $ GoalWidgets <$> if hasMultiple then enumerate else [GoalSummary] + + isEndingModal :: ModalType -> Bool + isEndingModal = \case + EndScenarioModal _ -> True + _ -> False + -- | Pops up notifications when new recipes or commands are unlocked. -generateNotificationPopups :: EventM Name AppState Bool +generateNotificationPopups :: EventM Name PlayState Bool generateNotificationPopups = do - rs <- use $ gameState . discovery . availableRecipes + rs <- use $ scenarioState . gameState . discovery . availableRecipes let newRecipes = rs ^. notificationsShouldAlert when newRecipes $ do - uiState . uiPopups %= addPopup RecipesPopup - gameState . discovery . availableRecipes . notificationsShouldAlert .= False + progression . uiPopups %= addPopup RecipesPopup + scenarioState . gameState . discovery . availableRecipes . notificationsShouldAlert .= False - cs <- use $ gameState . discovery . availableCommands + cs <- use $ scenarioState . gameState . discovery . availableCommands let alertCommands = cs ^. notificationsShouldAlert when alertCommands $ do let newCommands = take (cs ^. notificationsCount) (cs ^. notificationsContent) - uiState . uiPopups %= addPopup (CommandsPopup newCommands) - gameState . discovery . availableCommands . notificationsShouldAlert .= False + progression . uiPopups %= addPopup (CommandsPopup newCommands) + scenarioState . gameState . discovery . availableCommands . notificationsShouldAlert .= False return $ newRecipes || alertCommands -- | Strips the top-level @Cmd@ from a type, if any (to compute the -- result type of a REPL command evaluation). stripCmd :: TDCtx -> Polytype -> Polytype -stripCmd tdCtx (Forall xs ty) = case whnfType tdCtx ty of - TyCmd resTy -> Forall xs resTy - _ -> Forall xs ty +stripCmd tdCtx = fmap $ \ty -> case whnfType tdCtx ty of + TyCmd resTy -> resTy + _ -> ty diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -2,6 +2,8 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause +-- +-- Keyboard key event patterns and drawing utilities module Swarm.TUI.Controller.Util where import Brick hiding (Direction) @@ -10,7 +12,7 @@ import Control.Carrier.Lift qualified as Fused import Control.Carrier.State.Lazy qualified as Fused import Control.Lens as Lens -import Control.Monad (forM_, unless, when) +import Control.Monad (forM, forM_, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO), liftIO) import Control.Monad.State (MonadState, execState) import Data.List.Extra (enumerate) @@ -33,10 +35,23 @@ import Swarm.Game.World.Coords import Swarm.Language.Capability (Capability (CDebug)) import Swarm.Language.Syntax hiding (Key) -import Swarm.TUI.Model -import Swarm.TUI.Model.Repl (REPLHistItem, REPLPrompt, REPLState, addREPLItem, replHistory, replPromptText, replPromptType) -import Swarm.TUI.Model.UI -import Swarm.TUI.View.Util (generateModal) +import Swarm.TUI.Model ( + AppState, + PlayState, + ScenarioState, + gameState, + modalScroll, + playState, + progression, + scenarioSequence, + scenarioState, + uiGameplay, + ) +import Swarm.TUI.Model.Menu +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.Repl (REPLHistItem (..), REPLHistItemType, REPLPrompt, REPLState, addREPLItem, replHistory, replPromptText, replPromptType) +import Swarm.TUI.Model.UI.Gameplay +import Swarm.TUI.View.Util (ScenarioSeriesContext (..), curMenuName, generateModal, generateScenarioEndModal) import System.Clock (Clock (..), getTime) -- | Pattern synonyms to simplify brick event handler @@ -63,29 +78,51 @@ pattern FKey :: Int -> BrickEvent n e pattern FKey c = VtyEvent (V.EvKey (V.KFun c) []) -openModal :: ModalType -> EventM Name AppState () -openModal mt = do +-- | Requires 'PlayState' for access to remaining scenario sequence +openEndScenarioModal :: Menu -> EndScenarioModalType -> EventM Name PlayState () +openEndScenarioModal m mt = do resetViewport modalScroll - newModal <- gets $ flip generateModal mt - ensurePause - uiState . uiGameplay . uiModal ?= newModal + remainingScenarios <- use $ progression . scenarioSequence + let sequenceContext = ScenarioSeriesContext remainingScenarios (curMenuName m) isNoMenu + + Brick.zoom scenarioState $ do + newModal <- gets $ generateScenarioEndModal sequenceContext mt + ensurePause + uiGameplay . uiDialogs . uiModal ?= newModal + -- Beep case mt of - ScenarioEndModal _ -> do + ScenarioFinishModal _ -> do vty <- getVtyHandle liftIO $ V.ringTerminalBell $ V.outputIface vty _ -> return () where + isNoMenu = case m of + NoMenu -> True + _ -> False + -- Set the game to AutoPause if needed + ensurePause = Brick.zoom (gameState . temporal) $ do + pause <- use paused + unless pause $ runStatus .= AutoPause + +openMidScenarioModal :: MidScenarioModalType -> EventM Name ScenarioState () +openMidScenarioModal mt = do + resetViewport modalScroll + newModal <- gets $ flip generateModal mt + ensurePause + uiGameplay . uiDialogs . uiModal ?= newModal + where + -- Set the game to AutoPause if needed ensurePause = do pause <- use $ gameState . temporal . paused - unless (pause || isRunningModal mt) $ gameState . temporal . runStatus .= AutoPause + unless (pause || isRunningModal (MidScenarioModal mt)) $ gameState . temporal . runStatus .= AutoPause -- | The running modals do not autopause the game. isRunningModal :: ModalType -> Bool isRunningModal = \case - RobotsModal -> True - MessagesModal -> True + MidScenarioModal RobotsModal -> True + MidScenarioModal MessagesModal -> True _ -> False -- | Set the game to Running if it was (auto) paused otherwise to paused. @@ -94,81 +131,123 @@ -- doesn't matter; if we are unpausing, this is critical to -- ensure the next frame doesn't think it has to catch up from -- whenever the game was paused! -safeTogglePause :: EventM Name AppState () +safeTogglePause :: EventM Name ScenarioState () safeTogglePause = do curTime <- liftIO $ getTime Monotonic - uiState . uiGameplay . uiTiming . lastFrameTime .= curTime - uiState . uiGameplay . uiShowDebug .= False + uiGameplay . uiTiming . lastFrameTime .= curTime + uiGameplay . uiShowDebug .= False p <- gameState . temporal . runStatus Lens.<%= toggleRunStatus - when (p == Running) $ zoomGameState finishGameTick + when (p == Running) $ zoomGameStateFromScenarioState finishGameTick -- | Only unpause the game if leaving autopaused modal. -- -- Note that the game could have been paused before opening -- the modal, in that case, leave the game paused. -safeAutoUnpause :: EventM Name AppState () +safeAutoUnpause :: EventM Name ScenarioState () safeAutoUnpause = do runs <- use $ gameState . temporal . runStatus when (runs == AutoPause) safeTogglePause -toggleModal :: ModalType -> EventM Name AppState () -toggleModal mt = do - modal <- use $ uiState . uiGameplay . uiModal - case modal of - Nothing -> openModal mt - Just _ -> uiState . uiGameplay . uiModal .= Nothing >> safeAutoUnpause +dismissScenarioDialog :: EventM Name ScenarioState () +dismissScenarioDialog = do + uiGameplay . uiDialogs . uiModal .= Nothing + safeAutoUnpause -setFocus :: FocusablePanel -> EventM Name AppState () -setFocus name = uiState . uiGameplay . uiFocusRing %= focusSetCurrent (FocusablePanel name) +isUIModalClosed :: ScenarioState -> Bool +isUIModalClosed s = null $ s ^. uiGameplay . uiDialogs . uiModal -immediatelyRedrawWorld :: EventM Name AppState () +toggleMidScenarioModal :: MidScenarioModalType -> EventM Name ScenarioState () +toggleMidScenarioModal mt = do + s <- get + if isUIModalClosed s + then openMidScenarioModal mt + else dismissScenarioDialog + +-- | Requires 'PlayState' for access to remaining scenario sequence +toggleEndScenarioModal :: EndScenarioModalType -> Menu -> EventM Name PlayState () +toggleEndScenarioModal mt m = do + s <- use scenarioState + if isUIModalClosed s + then openEndScenarioModal m mt + else Brick.zoom scenarioState dismissScenarioDialog + +setFocus :: FocusablePanel -> EventM Name ScenarioState () +setFocus name = uiGameplay . uiFocusRing %= focusSetCurrent (FocusablePanel name) + +immediatelyRedrawWorld :: EventM Name GameState () immediatelyRedrawWorld = do invalidateCacheEntry WorldCache loadVisibleRegion -- | Make sure all tiles covering the visible part of the world are -- loaded. -loadVisibleRegion :: EventM Name AppState () +loadVisibleRegion :: EventM Name GameState () loadVisibleRegion = do mext <- lookupExtent WorldExtent forM_ mext $ \(Extent _ _ size) -> do - gs <- use gameState - let vr = viewingRegion (gs ^. robotInfo . viewCenter) (over both fromIntegral size) - gameState . landscape . multiWorld %= M.adjust (W.loadRegion (vr ^. planar)) (vr ^. subworld) + vc <- use $ robotInfo . viewCenter + let vr = viewingRegion vc (over both fromIntegral size) + landscape . multiWorld %= M.adjust (W.loadRegion (vr ^. planar)) (vr ^. subworld) mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe (Cosmic Coords)) mouseLocToWorldCoords (Brick.Location mouseLoc) = do mext <- lookupExtent WorldExtent - case mext of - Nothing -> pure Nothing - Just ext -> do - region <- gets $ flip viewingRegion (bimap fromIntegral fromIntegral (extentSize ext)) . view (robotInfo . viewCenter) - let regionStart = unCoords (fst $ region ^. planar) - mouseLoc' = bimap fromIntegral fromIntegral mouseLoc - mx = snd mouseLoc' + fst regionStart - my = fst mouseLoc' + snd regionStart - in pure . Just $ Cosmic (region ^. subworld) $ Coords (mx, my) + forM mext $ \ext -> do + region <- gets $ flip viewingRegion (bimap fromIntegral fromIntegral (extentSize ext)) . view (robotInfo . viewCenter) + let regionStart = unCoords (fst $ region ^. planar) + mouseLoc' = bimap fromIntegral fromIntegral mouseLoc + mx = snd mouseLoc' + fst regionStart + my = fst mouseLoc' + snd regionStart + in pure $ Cosmic (region ^. subworld) $ Coords (mx, my) -hasDebugCapability :: Bool -> AppState -> Bool +hasDebugCapability :: Bool -> GameState -> Bool hasDebugCapability isCreative s = maybe isCreative (S.member CDebug . getCapabilitySet) $ - s ^? gameState . to focusedRobot . _Just . robotCapabilities + s ^? to focusedRobot . _Just . robotCapabilities -- | Resets the viewport scroll position -resetViewport :: ViewportScroll Name -> EventM Name AppState () +resetViewport :: ViewportScroll Name -> EventM Name s () resetViewport n = do vScrollToBeginning n hScrollToBeginning n -- | Modifies the game state using a fused-effect state action. -zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> m a -zoomGameState f = do +zoomGameStateFromAppState :: + (MonadState AppState m, MonadIO m) => + Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> + m a +zoomGameStateFromAppState f = do + gs <- use z + (gs', a) <- liftIO . Fused.runM . runTimeIO $ Fused.runState gs f + z .= gs' + return a + where + z :: Lens' AppState GameState + z = playState . scenarioState . gameState + +-- | Modifies the game state using a fused-effect state action. +zoomGameStateFromScenarioState :: + (MonadState ScenarioState m, MonadIO m) => + Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> + m a +zoomGameStateFromScenarioState f = do gs <- use gameState (gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f))) gameState .= gs' return a -onlyCreative :: (MonadState AppState m) => m () -> m () +-- | Modifies the game state using a fused-effect state action. +zoomGameStateFromPlayState :: + (MonadState PlayState m, MonadIO m) => + Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> + m a +zoomGameStateFromPlayState f = do + gs <- use $ scenarioState . gameState + (gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f))) + scenarioState . gameState .= gs' + return a + +onlyCreative :: (MonadState ScenarioState m) => m () -> m () onlyCreative a = do c <- use $ gameState . creativeMode when c a @@ -177,14 +256,14 @@ allHandlers :: (Ord e2, Enum e1, Bounded e1) => (e1 -> e2) -> - (e1 -> (Text, EventM Name AppState ())) -> - [KeyEventHandler e2 (EventM Name AppState)] + (e1 -> (Text, EventM Name s ())) -> + [KeyEventHandler e2 (EventM Name s)] allHandlers eEmbed f = map handleEvent1 enumerate where handleEvent1 e1 = let (n, a) = f e1 in onEvent (eEmbed e1) n a -runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () -runBaseTerm = maybe (pure ()) startBaseProgram +runBaseTerm :: (MonadState ScenarioState m) => Maybe TSyntax -> m () +runBaseTerm = mapM_ startBaseProgram where -- The player typed something at the REPL and hit Enter; this -- function takes the resulting term (if the REPL @@ -203,9 +282,12 @@ modifyResetREPL t r = (replPromptText .~ t) . (replPromptType .~ r) -- | Reset the REPL state to the given text and REPL prompt type. -resetREPL :: MonadState AppState m => Text -> REPLPrompt -> m () -resetREPL t p = uiState . uiGameplay . uiREPL %= modifyResetREPL t p +resetREPL :: MonadState ScenarioState m => Text -> REPLPrompt -> m () +resetREPL t p = uiGameplay . uiREPL %= modifyResetREPL t p -- | Add an item to the REPL history. -addREPLHistItem :: MonadState AppState m => REPLHistItem -> m () -addREPLHistItem item = uiState . uiGameplay . uiREPL . replHistory %= addREPLItem item +addREPLHistItem :: MonadState ScenarioState m => REPLHistItemType -> Text -> m () +addREPLHistItem itemType msg = do + t <- use $ gameState . temporal . ticks + let item = REPLHistItem itemType t msg + uiGameplay . uiREPL . replHistory %= addREPLItem item diff --git a/src/swarm-tui/Swarm/TUI/Editor/Controller.hs b/src/swarm-tui/Swarm/TUI/Editor/Controller.hs --- a/src/swarm-tui/Swarm/TUI/Editor/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Controller.hs @@ -17,6 +17,7 @@ import Data.Yaml qualified as Y import Graphics.Vty qualified as V import Swarm.Game.Land +import Swarm.Game.Scenario.Status import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.State import Swarm.Game.State.Landscape @@ -27,8 +28,9 @@ import Swarm.TUI.Editor.Palette import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Model +import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import Swarm.Util (hoistMaybe) import Swarm.Util.Erasable (maybeToErasable) import System.Clock @@ -37,24 +39,25 @@ -- World Editor panel events ------------------------------------------------------------ -activateWorldEditorFunction :: WorldEditorFocusable -> EventM Name AppState () -activateWorldEditorFunction BrushSelector = openModal TerrainPaletteModal -activateWorldEditorFunction EntitySelector = openModal EntityPaletteModal -activateWorldEditorFunction AreaSelector = do - selectorStage <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep - case selectorStage of - SelectionComplete -> uiState . uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep .= UpperLeftPending - _ -> return () +activateWorldEditorFunction :: WorldEditorFocusable -> EventM Name ScenarioState () +activateWorldEditorFunction BrushSelector = openMidScenarioModal TerrainPaletteModal +activateWorldEditorFunction EntitySelector = openMidScenarioModal EntityPaletteModal +activateWorldEditorFunction AreaSelector = + Brick.zoom (uiGameplay . uiWorldEditor . editingBounds) $ do + selectorStage <- use boundsSelectionStep + case selectorStage of + SelectionComplete -> boundsSelectionStep .= UpperLeftPending + _ -> return () activateWorldEditorFunction OutputPathSelector = -- TODO: #1371 liftIO $ putStrLn "File selection" activateWorldEditorFunction MapSaveButton = saveMapFile activateWorldEditorFunction ClearEntityButton = - uiState . uiGameplay . uiWorldEditor . entityPaintList . BL.listSelectedL .= Nothing + uiGameplay . uiWorldEditor . entityPaintList . BL.listSelectedL .= Nothing -handleCtrlLeftClick :: B.Location -> EventM Name AppState () +handleCtrlLeftClick :: B.Location -> EventM Name ScenarioState () handleCtrlLeftClick mouseLoc = do - worldEditor <- use $ uiState . uiGameplay . uiWorldEditor + worldEditor <- use $ uiGameplay . uiWorldEditor _ <- runMaybeT $ do guard $ worldEditor ^. worldOverdraw . isWorldEditorEnabled let getSelected x = snd <$> BL.listSelectedElement x @@ -62,26 +65,24 @@ maybeEntityPaint = getSelected $ worldEditor ^. entityPaintList terrain <- hoistMaybe maybeTerrainType mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - Brick.zoom (uiState . uiGameplay . uiWorldEditor) $ do + Brick.zoom (uiGameplay . uiWorldEditor) $ do worldOverdraw . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeToErasable maybeEntityPaint) lastWorldEditorMessage .= Nothing - immediatelyRedrawWorld - return () + Brick.zoom gameState immediatelyRedrawWorld -handleRightClick :: B.Location -> EventM Name AppState () +handleRightClick :: B.Location -> EventM Name ScenarioState () handleRightClick mouseLoc = do - worldEditor <- use $ uiState . uiGameplay . uiWorldEditor + worldEditor <- use $ uiGameplay . uiWorldEditor _ <- runMaybeT $ do guard $ worldEditor ^. worldOverdraw . isWorldEditorEnabled mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - uiState . uiGameplay . uiWorldEditor . worldOverdraw . paintedTerrain %= M.delete (mouseCoords ^. planar) - immediatelyRedrawWorld - return () + uiGameplay . uiWorldEditor . worldOverdraw . paintedTerrain %= M.delete (mouseCoords ^. planar) + Brick.zoom gameState immediatelyRedrawWorld -- | "Eye Dropper" tool: -handleMiddleClick :: B.Location -> EventM Name AppState () +handleMiddleClick :: B.Location -> EventM Name ScenarioState () handleMiddleClick mouseLoc = do - worldEditor <- use $ uiState . uiGameplay . uiWorldEditor + worldEditor <- use $ uiGameplay . uiWorldEditor when (worldEditor ^. worldOverdraw . isWorldEditorEnabled) $ do w <- use $ gameState . landscape . multiWorld tm <- use $ gameState . landscape . terrainAndEntities . terrainMap @@ -92,45 +93,45 @@ (worldEditor ^. worldOverdraw) w coords - uiState . uiGameplay . uiWorldEditor . terrainList %= BL.listMoveToElement terrain + uiGameplay . uiWorldEditor . terrainList %= BL.listMoveToElement terrain forM_ maybeElementPaint $ \elementPaint -> let p = case elementPaint of Facade efd -> efd Ref r -> mkFacade r - in uiState . uiGameplay . uiWorldEditor . entityPaintList %= BL.listMoveToElement p + in uiGameplay . uiWorldEditor . entityPaintList %= BL.listMoveToElement p mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc whenJust mouseCoordsM setTerrainPaint -- | Handle user input events in the robot panel. -handleWorldEditorPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleWorldEditorPanelEvent :: BrickEvent Name AppEvent -> EventM Name ScenarioState () handleWorldEditorPanelEvent = \case - Key V.KEsc -> uiState . uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete + Key V.KEsc -> uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete Key V.KEnter -> do - fring <- use $ uiState . uiGameplay . uiWorldEditor . editorFocusRing + fring <- use $ uiGameplay . uiWorldEditor . editorFocusRing case focusGetCurrent fring of Just (WorldEditorPanelControl x) -> activateWorldEditorFunction x _ -> return () ControlChar 's' -> saveMapFile - CharKey '\t' -> uiState . uiGameplay . uiWorldEditor . editorFocusRing %= focusNext - Key V.KBackTab -> uiState . uiGameplay . uiWorldEditor . editorFocusRing %= focusPrev + CharKey '\t' -> uiGameplay . uiWorldEditor . editorFocusRing %= focusNext + Key V.KBackTab -> uiGameplay . uiWorldEditor . editorFocusRing %= focusPrev _ -> return () -- | Return value: whether the cursor position should be updated -updateAreaBounds :: Maybe (Cosmic Coords) -> EventM Name AppState Bool +updateAreaBounds :: Maybe (Cosmic Coords) -> EventM Name ScenarioState Bool updateAreaBounds = \case Nothing -> return True Just mouseCoords -> do - selectorStage <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep + selectorStage <- use $ uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep case selectorStage of UpperLeftPending -> do - uiState . uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep .= LowerRightPending mouseCoords + uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep .= LowerRightPending mouseCoords return False -- TODO (#1152): Validate that the lower-right click is below and to the right of -- the top-left coord and that they are within the same subworld LowerRightPending upperLeftMouseCoords -> do t <- liftIO $ getTime Monotonic - Brick.zoom (uiState . uiGameplay . uiWorldEditor) $ do + Brick.zoom (uiGameplay . uiWorldEditor) $ do lastWorldEditorMessage .= Nothing Brick.zoom editingBounds $ do boundsRect .= Just (fmap (,view planar mouseCoords) upperLeftMouseCoords) @@ -140,18 +141,22 @@ return False SelectionComplete -> return True -saveMapFile :: EventM Name AppState () +saveMapFile :: EventM Name ScenarioState () saveMapFile = do - worldEditor <- use $ uiState . uiGameplay . uiWorldEditor - maybeBounds <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsRect - w <- use $ gameState . landscape . multiWorld - tm <- use $ gameState . landscape . terrainAndEntities . terrainMap - let mapCellGrid = + uig <- use uiGameplay + land <- use $ gameState . landscape + let worldEditor = uig ^. uiWorldEditor + maybeBounds = uig ^. uiWorldEditor . editingBounds . boundsRect + + w = land ^. multiWorld + tm = land ^. terrainAndEntities . terrainMap + mapCellGrid = Just <$> EU.getEditedMapRectangle tm (worldEditor ^. worldOverdraw) maybeBounds w - let fp = worldEditor ^. outputFilePath - maybeScenarioPair <- use $ uiState . uiGameplay . scenarioRef - liftIO $ Y.encodeFile fp $ constructScenario (fst <$> maybeScenarioPair) mapCellGrid + fp = worldEditor ^. outputFilePath + maybeScenarioPair = uig ^. scenarioRef - uiState . uiGameplay . uiWorldEditor . lastWorldEditorMessage .= Just "Saved." + liftIO $ Y.encodeFile fp $ constructScenario (view getScenario <$> maybeScenarioPair) mapCellGrid + + uiGameplay . uiWorldEditor . lastWorldEditorMessage .= Just "Saved." diff --git a/src/swarm-tui/Swarm/TUI/Editor/Masking.hs b/src/swarm-tui/Swarm/TUI/Editor/Masking.hs --- a/src/swarm-tui/Swarm/TUI/Editor/Masking.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Masking.hs @@ -8,7 +8,7 @@ import Swarm.Game.World.Coords import Swarm.TUI.Editor.Model import Swarm.TUI.Editor.Util qualified as EU -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay shouldHideWorldCell :: UIGameplay -> Coords -> Bool shouldHideWorldCell ui coords = diff --git a/src/swarm-tui/Swarm/TUI/Editor/Model.hs b/src/swarm-tui/Swarm/TUI/Editor/Model.hs --- a/src/swarm-tui/Swarm/TUI/Editor/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Model.hs @@ -41,9 +41,6 @@ Facade f -> f Ref e -> mkFacade e -getEntityName :: EntityFacade -> E.EntityName -getEntityName (EntityFacade name _) = name - data MapEditingBounds = MapEditingBounds { _boundsRect :: Maybe (Cosmic BoundsRectangle) -- ^ Upper-left and lower-right coordinates diff --git a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs --- a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs @@ -7,7 +7,6 @@ import Control.Lens import Control.Monad (guard) -import Data.Aeson.KeyMap qualified as KM import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Map (Map) @@ -16,7 +15,6 @@ import Data.Ord (Down (..)) import Data.Set (Set) import Data.Set qualified as Set -import Data.Text qualified as T import Data.Tuple (swap) import Swarm.Game.Display (Display, defaultChar) import Swarm.Game.Entity (Entity, EntityName, entitiesByName) @@ -30,6 +28,7 @@ import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.ProtoCell import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName) import Swarm.Game.Universe @@ -40,12 +39,11 @@ makeSuggestedPalette :: TerrainMap -> - KM.KeyMap (AugmentedCell Entity) -> + Map Char (AugmentedCell Entity) -> Grid (Maybe CellPaintDisplay) -> - KM.KeyMap (AugmentedCell EntityFacade) + Map Char (AugmentedCell EntityFacade) makeSuggestedPalette tm originalScenarioPalette cellGrid = - KM.fromMapText - . M.map (SignpostableCell Nothing) + M.map (SignpostableCell Nothing Nothing) . M.fromList . M.elems -- NOTE: the left-most maps take precedence! @@ -86,23 +84,23 @@ invertPaletteMapToDedupe = map (\x@(_, c) -> (toKey $ cellToTerrainPair c, x)) . M.toList - paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + paletteCellsByKey :: Map (TerrainWith EntityName) (Char, CellPaintDisplay) paletteCellsByKey = M.map (NE.head . NE.sortWith toSortVal) . binTuples . invertPaletteMapToDedupe - $ KM.toMapText originalPalette + $ originalPalette where toSortVal (symbol, Cell _terrain _maybeEntity robots) = Down (null robots, symbol) excludedPaletteChars :: Set Char excludedPaletteChars = Set.fromList [' '] - originalPalette :: KM.KeyMap CellPaintDisplay + originalPalette :: Map Char CellPaintDisplay originalPalette = - KM.map (toCellPaintDisplay . standardCell) originalScenarioPalette + M.map (toCellPaintDisplay . standardCell) originalScenarioPalette - pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + pairsWithDisplays :: Map (TerrainWith EntityName) (Char, CellPaintDisplay) pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain where g (terrain, eName) = do @@ -110,14 +108,14 @@ let displayChar = eDisplay ^. defaultChar guard $ Set.notMember displayChar excludedPaletteChars let cell = Cell terrain (EJust $ EntityFacade eName eDisplay) [] - return ((terrain, EJust eName), (T.singleton displayChar, cell)) + return ((terrain, EJust eName), (displayChar, cell)) -- TODO (#1153): Filter out terrain-only palette entries that aren't actually -- used in the map. - terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + terrainOnlyPalette :: Map (TerrainWith EntityName) (Char, CellPaintDisplay) terrainOnlyPalette = M.fromList . map f . M.keys $ terrainByName tm where - f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing [])) + f x = ((x, ENothing), (getTerrainDefaultPaletteChar x, Cell x ENothing [])) -- | Generate a \"skeleton\" scenario with placeholders for certain required fields constructScenario :: Maybe Scenario -> Grid (Maybe CellPaintDisplay) -> SkeletonScenario @@ -136,10 +134,8 @@ customEntities = tem ^. entityMap wd = WorldDescription - { offsetOrigin = False - , scrollable = True + { scrollable = True , palette = StructurePalette suggestedPalette - , ul = upperLeftCoord , area = PositionedGrid upperLeftCoord cellGrid , navigation = Navigation mempty mempty , placedStructures = mempty diff --git a/src/swarm-tui/Swarm/TUI/Editor/Util.hs b/src/swarm-tui/Swarm/TUI/Editor/Util.hs --- a/src/swarm-tui/Swarm/TUI/Editor/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Util.hs @@ -35,7 +35,7 @@ (EA.isEmpty a, newBounds) where newBounds = Cosmic DefaultRootSubworld (locToCoords upperLeftLoc, locToCoords lowerRightLoc) - upperLeftLoc = ul myWorld + upperLeftLoc = gridPosition $ area myWorld a = EA.getGridDimensions $ gridContent $ area myWorld lowerRightLoc = EA.computeBottomRightFromUpperLeft a upperLeftLoc diff --git a/src/swarm-tui/Swarm/TUI/Editor/View.hs b/src/swarm-tui/Swarm/TUI/Editor/View.hs --- a/src/swarm-tui/Swarm/TUI/Editor/View.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/View.hs @@ -10,6 +10,7 @@ import Data.List qualified as L import Swarm.Game.Land import Swarm.Game.Scenario +import Swarm.Game.Scenario.Status import Swarm.Game.Scenario.Topography.Area qualified as EA import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Terrain (TerrainMap, TerrainType) @@ -19,19 +20,20 @@ import Swarm.TUI.Editor.Model import Swarm.TUI.Model import Swarm.TUI.Model.Name -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import Swarm.TUI.Panel import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.CellDisplay (renderDisplay) import Swarm.TUI.View.Util qualified as VU +import Swarm.Util (applyWhen) -extractTerrainMap :: UIState -> TerrainMap -extractTerrainMap uis = - maybe mempty (view (scenarioLandscape . scenarioTerrainAndEntities . terrainMap) . fst) $ - uis ^. uiGameplay . scenarioRef +extractTerrainMap :: UIGameplay -> TerrainMap +extractTerrainMap uig = + maybe mempty (view $ getScenario . scenarioLandscape . scenarioTerrainAndEntities . terrainMap) $ + uig ^. scenarioRef -drawWorldEditor :: FocusRing Name -> UIState -> Widget Name -drawWorldEditor toplevelFocusRing uis = +drawWorldEditor :: FocusRing Name -> UIGameplay -> Widget Name +drawWorldEditor toplevelFocusRing uig = if worldEditor ^. worldOverdraw . isWorldEditorEnabled then panel @@ -62,7 +64,7 @@ hLimit 30 $ controlsBox <=> statusBox - worldEditor = uis ^. uiGameplay . uiWorldEditor + worldEditor = uig ^. uiWorldEditor maybeAreaBounds = worldEditor ^. editingBounds . boundsRect -- TODO (#1150): Use withFocusRing? @@ -70,16 +72,15 @@ clickable n $ transformation w where transformation = - if Just n == maybeCurrentFocus - then withAttr BL.listSelectedFocusedAttr - else id + applyWhen (Just n == maybeCurrentFocus) $ + withAttr BL.listSelectedFocusedAttr swatchContent list drawFunc = maybe emptyWidget drawFunc selectedThing where selectedThing = snd <$> BL.listSelectedElement list - tm = extractTerrainMap uis + tm = extractTerrainMap uig brushWidget = mkFormControl (WorldEditorPanelControl BrushSelector) $ @@ -118,7 +119,7 @@ L.intersperse "@" [ EA.renderRectDimensions rectArea - , VU.locationToString upperLeftLoc + , locationToString upperLeftLoc ] where upperLeftLoc = coordsToLoc upperLeftCoord @@ -145,25 +146,25 @@ where tile = padRight (Pad 1) $ renderDisplay eDisplay -drawTerrainSelector :: AppState -> Widget Name -drawTerrainSelector s = +drawTerrainSelector :: UIGameplay -> Widget Name +drawTerrainSelector uig = padAll 1 . hCenter . vLimit 8 - . BL.renderListWithIndex (listDrawTerrainElement $ extractTerrainMap $ s ^. uiState) True - $ s ^. uiState . uiGameplay . uiWorldEditor . terrainList + . BL.renderListWithIndex (listDrawTerrainElement $ extractTerrainMap uig) True + $ uig ^. uiWorldEditor . terrainList listDrawTerrainElement :: TerrainMap -> Int -> Bool -> TerrainType -> Widget Name listDrawTerrainElement tm pos _isSelected a = clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch tm a -drawEntityPaintSelector :: AppState -> Widget Name -drawEntityPaintSelector s = +drawEntityPaintSelector :: UIGameplay -> Widget Name +drawEntityPaintSelector uig = padAll 1 . hCenter . vLimit 10 . BL.renderListWithIndex listDrawEntityPaintElement True - $ s ^. uiState . uiGameplay . uiWorldEditor . entityPaintList + $ uig ^. uiWorldEditor . entityPaintList listDrawEntityPaintElement :: Int -> Bool -> EntityFacade -> Widget Name listDrawEntityPaintElement pos _isSelected a = diff --git a/src/swarm-tui/Swarm/TUI/Launch/Controller.hs b/src/swarm-tui/Swarm/TUI/Launch/Controller.hs --- a/src/swarm-tui/Swarm/TUI/Launch/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Launch/Controller.hs @@ -117,7 +117,7 @@ cacheValidatedInputs handleLaunchOptionsEvent :: - ScenarioInfoPair -> + ScenarioWith ScenarioInfo -> BrickEvent Name AppEvent -> EventM Name AppState () handleLaunchOptionsEvent siPair = \case diff --git a/src/swarm-tui/Swarm/TUI/Launch/Model.hs b/src/swarm-tui/Swarm/TUI/Launch/Model.hs --- a/src/swarm-tui/Swarm/TUI/Launch/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Launch/Model.hs @@ -15,10 +15,10 @@ import Control.Lens (makeLenses) import Data.Functor.Identity (Identity (Identity)) import Data.Text (Text) -import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (LaunchParams), ScenarioInfoPair, SerializableLaunchParams) +import Swarm.Failure (SystemFailure) +import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (LaunchParams), ScenarioInfo, ScenarioWith, SerializableLaunchParams) import Swarm.Game.State (LaunchParams, ValidatedLaunchParams, getRunCodePath, parseCodeFile) -import Swarm.Language.Pretty (prettyText) +import Swarm.Pretty (prettyText) import Swarm.TUI.Model.Name import Swarm.Util.Effect (withThrow) @@ -50,7 +50,7 @@ { _fileBrowser :: FileBrowserControl , _seedValueEditor :: Editor Text Name , _scenarioConfigFocusRing :: Focus.FocusRing Name - , _isDisplayedFor :: Maybe ScenarioInfoPair + , _isDisplayedFor :: Maybe (ScenarioWith ScenarioInfo) } makeLenses ''LaunchControls diff --git a/src/swarm-tui/Swarm/TUI/Launch/Prep.hs b/src/swarm-tui/Swarm/TUI/Launch/Prep.hs --- a/src/swarm-tui/Swarm/TUI/Launch/Prep.hs +++ b/src/swarm-tui/Swarm/TUI/Launch/Prep.hs @@ -19,11 +19,11 @@ import Data.Functor.Identity (runIdentity) import Data.List.Extra (enumerate) import Data.Text qualified as T -import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (..), ScenarioInfoPair, getLaunchParams, scenarioStatus) +import Swarm.Failure (SystemFailure) +import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (..), ScenarioInfo, ScenarioWith (..), getLaunchParams, scenarioStatus) import Swarm.Game.State (ValidatedLaunchParams, getRunCodePath, parseCodeFile) import Swarm.Game.World.Gen (Seed) -import Swarm.Language.Pretty (prettyText) +import Swarm.Pretty (prettyText) import Swarm.TUI.Launch.Model import Swarm.TUI.Model.Name import Swarm.Util.Effect (withThrow) @@ -116,9 +116,9 @@ -- * The "marked file" is persisted outside of the 'FB.FileBrowser' state, and the -- "initial directory" is set upon instantiation from that external state. prepareLaunchDialog :: - ScenarioInfoPair -> + ScenarioWith ScenarioInfo -> EventM Name LaunchOptions () -prepareLaunchDialog siPair@(_, si) = do +prepareLaunchDialog siPair@(ScenarioWith _ si) = do let serializableLaunchParams = getLaunchParams $ si ^. scenarioStatus launchEditingParams <- liftIO $ fromSerializableParams serializableLaunchParams editingParams .= launchEditingParams diff --git a/src/swarm-tui/Swarm/TUI/Launch/View.hs b/src/swarm-tui/Swarm/TUI/Launch/View.hs --- a/src/swarm-tui/Swarm/TUI/Launch/View.hs +++ b/src/swarm-tui/Swarm/TUI/Launch/View.hs @@ -20,14 +20,14 @@ import Data.Text (Text) import Data.Text qualified as T import Swarm.Game.Scenario (scenarioLandscape, scenarioSeed) -import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (..)) +import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (..), getScenario) import Swarm.Game.State (getRunCodePath) import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.Prep import Swarm.TUI.Model.Name import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.Util (EllipsisSide (Beginning), withEllipsis) -import Swarm.Util (brackets, parens) +import Swarm.Util (applyWhen, brackets, parens) drawFileBrowser :: FB.FileBrowser Name -> Widget Name drawFileBrowser b = @@ -74,9 +74,7 @@ validatedOptions = toValidatedParams launchParams LaunchControls (FileBrowserControl fb _ isFbDisplayed) seedEditor ring displayedFor = lc addFileBrowser = - if isFbDisplayed - then (drawFileBrowser fb :) - else id + applyWhen isFbDisplayed (drawFileBrowser fb :) getFocusedConfigPanel :: Maybe ScenarioConfigPanelFocusable getFocusedConfigPanel = case focusGetCurrent ring of @@ -86,9 +84,8 @@ isFocused = (== getFocusedConfigPanel) . Just highlightIfFocused x = - if isFocused x - then withDefAttr highlightAttr - else id + applyWhen (isFocused x) $ + withDefAttr highlightAttr mkButton name label = clickable (ScenarioConfigControl $ ScenarioConfigPanelControl name) @@ -106,7 +103,7 @@ scenarioSeedText = maybe "random" show $ - view (scenarioLandscape . scenarioSeed) . fst =<< displayedFor + view (getScenario . scenarioLandscape . scenarioSeed) =<< displayedFor mkSeedEntryWidget seedEntryContent = if isFocused SeedSelector diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -12,24 +12,25 @@ -- * Custom UI label types -- $uilabel AppEvent (..), - WebCommand (..), FocusablePanel (..), - Name (..), + Name (..), -- helps to minimize import lines + -- ** Web command + WebCommand (..), + WebInvocationState (..), + RejectionReason (..), + -- * Menus and dialogs ModalType (..), ScenarioOutcome (..), Button (..), ButtonAction (..), - Modal (..), modalType, modalDialog, MainMenuEntry (..), mainMenu, - Menu (..), _NewGameMenu, mkScenarioList, - mkNewGameMenu, -- * UI state @@ -55,10 +56,27 @@ -- * App state AppState (AppState), - gameState, uiState, + playState, keyEventHandling, runtimeState, + animationMgr, + ScenarioState (ScenarioState), + gameState, + uiGameplay, + PlayState (..), + scenarioState, + progression, + ProgressionState (..), + scenarios, + attainedAchievements, + uiPopups, + uiPopupAnimationState, + scenarioSequence, + AnimationState (..), + _AnimActive, + _AnimScheduled, + _AnimInactive, -- ** Initialization AppOpts (..), @@ -70,28 +88,33 @@ -- ** Utility focusedItem, focusedEntity, - nextScenario, + animTraversal, ) where import Brick (EventM, ViewportScroll, viewportScroll) +import Brick.Animation (Animation, AnimationManager) import Brick.Keybindings as BK import Brick.Widgets.List qualified as BL import Control.Lens hiding (from, (<.>)) import Control.Monad ((>=>)) import Control.Monad.State (MonadState) import Data.List (findIndex) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) import Data.Maybe (fromMaybe) +import Data.Set (Set) import Data.Text (Text) import Data.Vector qualified as V import GitHash (GitInfo) import Graphics.Vty (ColorMode (..)) import Network.Wai.Handler.Warp (Port) +import Swarm.Game.Achievement.Attainment +import Swarm.Game.Achievement.Definitions import Swarm.Game.Entity as E import Swarm.Game.Ingredients +import Swarm.Game.Popup import Swarm.Game.Robot import Swarm.Game.Scenario.Status -import Swarm.Game.ScenarioInfo (_SISingle) +import Swarm.Game.ScenarioInfo (ScenarioCollection) import Swarm.Game.State import Swarm.Game.State.Runtime import Swarm.Game.State.Substate @@ -99,12 +122,14 @@ import Swarm.Game.World.Gen (Seed) import Swarm.Log import Swarm.TUI.Inventory.Sorting +import Swarm.TUI.Model.DebugOption (DebugOption) import Swarm.TUI.Model.Event (SwarmEvent) import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay +import Swarm.TUI.Model.WebCommand (RejectionReason (..), WebCommand (..), WebInvocationState (..)) import Swarm.Util.Lens (makeLensesNoSigs) -import Swarm.Version (NewReleaseFailure) import Text.Fuzzy qualified as Fuzzy ------------------------------------------------------------ @@ -114,17 +139,16 @@ -- $uilabel These types are used as parameters to various @brick@ -- types. -newtype WebCommand = RunWebCode Text - deriving (Show) - -- | 'Swarm.TUI.Model.AppEvent' represents a type for custom event types our app can -- receive. The primary custom event 'Frame' is sent by a separate thread as fast as --- it can, telling the TUI to render a new frame. +-- it can, telling the TUI to render a new frame. The custom event 'PopupEvent' is sent +-- by the animation manager and contains an event that starts, stops, or updates a +-- popup notification. data AppEvent = Frame | Web WebCommand - | UpstreamVersion (Either NewReleaseFailure String) - deriving (Show) + | PopupEvent (EventM Name AppState ()) + | UpstreamVersion (Either (Severity, Text) String) infoScroll :: ViewportScroll Name infoScroll = viewportScroll InfoViewport @@ -147,20 +171,43 @@ where l = LogEntry (TickNumber 0) src sev who msg -data KeyEventHandlingState = KeyEventHandlingState - { _keyConfig :: KeyConfig SwarmEvent - , _keyDispatchers :: SwarmKeyDispatchers +-- | This encapsulates both game and UI state for an actively-playing scenario, as well +-- as state that evolves as a result of playing a scenario. +data ScenarioState = ScenarioState + { _gameState :: GameState + , _uiGameplay :: UIGameplay } -type SwarmKeyDispatcher = KeyDispatcher SwarmEvent (EventM Name AppState) +-- | This enapsulates the state of a given animation that changes over time. 'AnimInactive' means that +-- the application is ready to start a new animation. 'AnimScheduled' means that the application +-- has told the animation manager to start the animation, but it hasn't started yet. 'AnimActive' means +-- that the animation is currently in progress. +data AnimationState + = AnimActive (Animation AppState Name) + | AnimScheduled + | AnimInactive -data SwarmKeyDispatchers = SwarmKeyDispatchers - { mainGameDispatcher :: SwarmKeyDispatcher - , replDispatcher :: SwarmKeyDispatcher - , worldDispatcher :: SwarmKeyDispatcher - , robotDispatcher :: SwarmKeyDispatcher +-- | State that can evolve as the user progresses through scenarios. +-- This includes achievements and completion records. +-- +-- Note that scenario completion/achievements are serialized to disk storage, +-- but we also persist in memory since we don't reload data from disk as +-- we progress through scenarios. +data ProgressionState = ProgressionState + { _scenarios :: ScenarioCollection ScenarioInfo + , _attainedAchievements :: Map CategorizedAchievement Attainment + , _uiPopups :: PopupState + , _uiPopupAnimationState :: AnimationState + , _scenarioSequence :: [ScenarioWith ScenarioPath] } +-- | This encapsulates both game and UI state for an actively-playing scenario, as well +-- as state that evolves as a result of playing a scenario. +data PlayState = PlayState + { _scenarioState :: ScenarioState + , _progression :: ProgressionState + } + -- ---------------------------------------------------------------------------- -- APPSTATE -- -- ---------------------------------------------------------------------------- @@ -171,13 +218,30 @@ -- or updating the UI. Also consider that GameState can change when loading -- a new scenario - if the state should persist games, use RuntimeState. data AppState = AppState - { _gameState :: GameState + { _playState :: PlayState , _uiState :: UIState , _keyEventHandling :: KeyEventHandlingState , _runtimeState :: RuntimeState + , _animationMgr :: AnimationManager AppState AppEvent Name } ------------------------------------------------------------ + +type SwarmKeyDispatcher = KeyDispatcher SwarmEvent (EventM Name AppState) + +data SwarmKeyDispatchers = SwarmKeyDispatchers + { mainGameDispatcher :: SwarmKeyDispatcher + , replDispatcher :: SwarmKeyDispatcher + , worldDispatcher :: SwarmKeyDispatcher + , robotDispatcher :: SwarmKeyDispatcher + } + +data KeyEventHandlingState = KeyEventHandlingState + { _keyConfig :: KeyConfig SwarmEvent + , _keyDispatchers :: SwarmKeyDispatchers + } + +------------------------------------------------------------ -- Functions for updating the UI state ------------------------------------------------------------ @@ -249,12 +313,16 @@ -- ^ Scenario the user wants to play. , scriptToRun :: Maybe FilePath -- ^ Code to be run on base. + , pausedAtStart :: Bool + -- ^ Pause the game on start by default. , autoPlay :: Bool -- ^ Automatically run the solution defined in the scenario file + , autoShowObjectives :: Bool + -- ^ Show objectives dialogs when an objective is achieved/failed. , speed :: Int -- ^ Initial game speed (logarithm) - , cheatMode :: Bool - -- ^ Should cheat mode be enabled? + , debugOptions :: Set DebugOption + -- ^ Debugging options, for example show creative switch. , colorMode :: Maybe ColorMode -- ^ What colour mode should be used? , userWebPort :: Maybe Port @@ -270,29 +338,58 @@ { userSeed = Nothing , userScenario = Nothing , scriptToRun = Nothing + , pausedAtStart = False + , autoShowObjectives = True , autoPlay = False , speed = defaultInitLgTicksPerSecond - , cheatMode = False + , debugOptions = mempty , colorMode = Nothing , userWebPort = Nothing , repoGitInfo = Nothing } --- | 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 ScenarioInfoPair -nextScenario = \case - NewGameMenu (curMenu :| _) -> - let nextMenuList = BL.listMoveDown curMenu - isLastScenario = BL.listSelected curMenu == Just (length (BL.listElements curMenu) - 1) - in if isLastScenario - then Nothing - else BL.listSelectedElement nextMenuList >>= preview _SISingle . snd - _ -> Nothing +-------------------------------------------------- +-- Lenses for ScenarioState +makeLensesNoSigs ''ScenarioState + +-- | The 'GameState' record. +gameState :: Lens' ScenarioState GameState + +-- | UI active during live gameplay +uiGameplay :: Lens' ScenarioState UIGameplay + -------------------------------------------------- +-- Lenses for PlayState + +makeLensesNoSigs ''PlayState + +-- | The 'ScenarioState' record. +scenarioState :: Lens' PlayState ScenarioState + +-- | State that can evolve as the user progresses through scenarios. +progression :: Lens' PlayState ProgressionState + +-------------------------------------------------- +-- Lenses for Progression State +makeLensesNoSigs ''ProgressionState + +-- | Map of achievements that were attained +attainedAchievements :: Lens' ProgressionState (Map CategorizedAchievement Attainment) + +-- | The collection of scenarios that comes with the game. +scenarios :: Lens' ProgressionState (ScenarioCollection ScenarioInfo) + +-- | Queue of popups to display +uiPopups :: Lens' ProgressionState PopupState + +-- | Popup Animation State +uiPopupAnimationState :: Lens' ProgressionState AnimationState + +-- | Remaining scenarios in the current sequence +scenarioSequence :: Lens' ProgressionState [ScenarioWith ScenarioPath] + +-------------------------------------------------- -- Lenses for KeyEventHandlingState makeLensesNoSigs ''KeyEventHandlingState @@ -308,8 +405,8 @@ makeLensesNoSigs ''AppState --- | The 'GameState' record. -gameState :: Lens' AppState GameState +-- | The 'ScenarioState' record. +playState :: Lens' AppState PlayState -- | The 'UIState' record. uiState :: Lens' AppState UIState @@ -320,23 +417,49 @@ -- | The 'RuntimeState' record runtimeState :: Lens' AppState RuntimeState +-- | The 'Brick.Animation.AnimationManager' record +animationMgr :: Lens' AppState (AnimationManager AppState AppEvent Name) + +------------------------------------------------- + +-- | Prisms for AnimationState +makePrisms ''AnimationState + -------------------------------------------------- -- Utility functions -- | Get the currently focused 'InventoryListEntry' from the robot -- info panel (if any). -focusedItem :: AppState -> Maybe InventoryListEntry +focusedItem :: ScenarioState -> Maybe InventoryListEntry focusedItem s = do - list <- s ^? uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 + list <- s ^? uiGameplay . uiInventory . uiInventoryList . _Just . _2 (_, entry) <- BL.listSelectedElement list return entry -- | Get the currently focused entity from the robot info panel (if -- any). This is just like 'focusedItem' but forgets the -- distinction between plain inventory items and equipped devices. -focusedEntity :: AppState -> Maybe Entity +focusedEntity :: ScenarioState -> Maybe Entity focusedEntity = focusedItem >=> \case Separator _ -> Nothing InventoryEntry _ e -> Just e EquippedEntry e -> Just e + +-- | A non-lawful traversal for use in animations that allows +-- us to manage the state of an animation and update it properly +-- when we process an event sent by the animation manager. +-- Exploits some assumptions about Brick's implementation of animations. +-- It is defined such that when the animation manager starts the animation +-- by setting the target of the traversal to Just theAnimation, the traversal will actually +-- set the AnimationState of the popup animation to AnimActive theAnimation. +-- When the animation manager signals that the animation has stopped by setting the target of +-- the traversal to Nothing, the traversal will set the AnimationState of the popup to AnimInactive. +animTraversal :: Traversal' AnimationState (Maybe (Animation AppState Name)) +animTraversal = traversal go + where + go :: Applicative f => (Maybe (Animation AppState Name) -> f (Maybe (Animation AppState Name))) -> AnimationState -> f AnimationState + go focus = \case + AnimInactive -> maybe AnimInactive AnimActive <$> focus Nothing + AnimScheduled -> maybe AnimInactive AnimActive <$> focus Nothing + AnimActive x -> maybe AnimInactive AnimActive <$> focus (Just x) diff --git a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs --- a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs @@ -8,6 +8,7 @@ popupAchievement, ) where +import Brick (EventM) import Control.Lens hiding (from, (<.>)) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -18,33 +19,34 @@ import Swarm.Game.Achievement.Attainment import Swarm.Game.Achievement.Definitions import Swarm.Game.Achievement.Persistence +import Swarm.Game.Popup (Popup (AchievementPopup), addPopup) +import Swarm.Game.Scenario.Status (ScenarioPath (..)) import Swarm.TUI.Model -import Swarm.TUI.Model.Popup (Popup (AchievementPopup), addPopup) -import Swarm.TUI.Model.UI -attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m () +attainAchievement :: + CategorizedAchievement -> + EventM n ProgressionState () attainAchievement a = do currentTime <- liftIO getZonedTime attainAchievement' currentTime Nothing a attainAchievement' :: - (MonadIO m, MonadState AppState m) => ZonedTime -> - Maybe FilePath -> + Maybe ScenarioPath -> CategorizedAchievement -> - m () + EventM n ProgressionState () attainAchievement' t p a = do - mAttainment <- use $ uiState . uiAchievements . at a + mAttainment <- use $ attainedAchievements . at a when (isNothing mAttainment) $ popupAchievement a - (uiState . uiAchievements) + attainedAchievements %= M.insertWith (<>) a - (Attainment a p t) - newAchievements <- use $ uiState . uiAchievements + (Attainment a (getScenarioPath <$> p) t) + newAchievements <- use attainedAchievements liftIO $ saveAchievementsInfo $ M.elems newAchievements -- | Generate a popup for an achievement. -popupAchievement :: MonadState AppState m => CategorizedAchievement -> m () -popupAchievement ach = uiState . uiPopups %= addPopup (AchievementPopup ach) +popupAchievement :: MonadState ProgressionState m => CategorizedAchievement -> m () +popupAchievement ach = uiPopups %= addPopup (AchievementPopup ach) diff --git a/src/swarm-tui/Swarm/TUI/Model/DebugOption.hs b/src/swarm-tui/Swarm/TUI/Model/DebugOption.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/DebugOption.hs @@ -0,0 +1,56 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sum type representing the Swarm debug options. +module Swarm.TUI.Model.DebugOption ( + DebugOption (..), + debugOptionName, + debugOptionDescription, + readDebugOption, + readDebugOptionList, +) where + +import Data.Foldable (find, foldl') +import Data.List.Extra (enumerate, splitOn, trim) +import Prelude hiding (Foldable (..)) + +data DebugOption + = ToggleCreative + | ToggleWorldEditor + | DebugCESK + | ListAllRobots + | ListRobotIDs + | ShowHiddenGoals + | LoadTestingScenarios + deriving (Eq, Ord, Show, Enum, Bounded) + +debugOptionName :: DebugOption -> String +debugOptionName = \case + ToggleCreative -> "creative" + ToggleWorldEditor -> "editor" + DebugCESK -> "cesk" + ListAllRobots -> "all_robots" + ListRobotIDs -> "robot_id" + ShowHiddenGoals -> "hidden_goals" + LoadTestingScenarios -> "testing" + +debugOptionDescription :: DebugOption -> String +debugOptionDescription = \case + ToggleCreative -> "allow toggling creative mode on/off" + ToggleWorldEditor -> "allow toggling the world editor mode on/off" + DebugCESK -> "allow toggling the CESK debug view on/off" + ListAllRobots -> "list all robots (including system robots) in the robot panel" + ListRobotIDs -> "list robot IDs in the robot panel" + ShowHiddenGoals -> "show hidden objectives in the goal dialog" + LoadTestingScenarios -> "load Testing folder in scenarios menu" + +readDebugOption :: String -> Maybe DebugOption +readDebugOption name = find ((trim name ==) . debugOptionName) enumerate + +readDebugOptionList :: String -> Either String [DebugOption] +readDebugOptionList = foldl' eitherRead (Right []) . splitOn "," + where + eitherRead s o = case (s, readDebugOption o) of + (Left e, _) -> Left e + (_, Nothing) -> Left $ "unknown option '" <> o <> "'" + (Right oss, Just os) -> Right $ os : oss diff --git a/src/swarm-tui/Swarm/TUI/Model/Dialog.hs b/src/swarm-tui/Swarm/TUI/Model/Dialog.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Dialog.hs @@ -0,0 +1,9 @@ +module Swarm.TUI.Model.Dialog ( + module Swarm.TUI.Model.Dialog.Goal, + module Swarm.Game.Popup, + module Swarm.TUI.Model.Dialog.Structure, +) where + +import Swarm.Game.Popup +import Swarm.TUI.Model.Dialog.Goal +import Swarm.TUI.Model.Dialog.Structure diff --git a/src/swarm-tui/Swarm/TUI/Model/Dialog/Goal.hs b/src/swarm-tui/Swarm/TUI/Model/Dialog/Goal.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Dialog/Goal.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A UI-centric model for Objective presentation. +module Swarm.TUI.Model.Dialog.Goal where + +import Brick.Focus +import Brick.Widgets.List qualified as BL +import Control.Lens (makeLenses, view, (^..)) +import Data.Aeson +import Data.List.Extra (enumerate) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (mapMaybe) +import GHC.Generics (Generic) +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.WinCheck +import Swarm.TUI.Model.Name +import Swarm.Util (applyWhen) + +-- | These are intended to be used as keys in a map +-- of lists of goals. +data GoalStatus + = -- | Goals in this category have other goals as prerequisites. + -- However, they are only displayed if the "previewable" attribute + -- is @true@. + Upcoming + | -- | Goals in this category may be pursued in parallel. + -- However, they are only displayed if the "hidden" attribute + -- is @false@. + Active + | -- | A goal's programmatic condition, as well as all its prerequisites, were completed. + -- This is a "latch" mechanism; at some point the conditions required to meet the goal may + -- no longer hold. Nonetheless, the goal remains "completed". + Completed + | -- | A goal that can no longer be achieved. + -- If this goal is not an "optional" goal, then the player + -- also "loses" the scenario. + -- + -- Note that currently the only way to "fail" a goal is by way + -- of a negative prerequisite that was completed. + Failed + deriving (Show, Eq, Ord, Bounded, Enum, Generic, ToJSON, ToJSONKey) + +type CategorizedGoals = Map GoalStatus (NonEmpty Objective) + +data GoalEntry + = Header GoalStatus + | Goal GoalStatus Objective + | Spacer + +shouldSkipSelection :: GoalEntry -> Bool +shouldSkipSelection = \case + Goal _ _ -> False + _ -> True + +data GoalTracking = GoalTracking + { announcements :: [Announcement] + -- ^ TODO: #1044 the actual contents of these are not used yet, + -- other than as a flag to pop up the Goal dialog. + , goals :: CategorizedGoals + } + deriving (Generic, ToJSON) + +instance ToSample GoalTracking where + toSamples _ = + SD.samples + [ GoalTracking mempty mempty + -- TODO: #1552 add simple objective sample + ] + +data GoalDisplay = GoalDisplay + { _goalsContent :: GoalTracking + , _listWidget :: BL.List Name GoalEntry + -- ^ required for maintaining the selection/navigation + -- state among list items + , _focus :: FocusRing Name + } + +makeLenses ''GoalDisplay + +emptyGoalDisplay :: GoalDisplay +emptyGoalDisplay = + GoalDisplay + (GoalTracking mempty mempty) + (BL.list (GoalWidgets ObjectivesList) mempty 1) + (focusRing $ map GoalWidgets enumerate) + +hasAnythingToShow :: GoalTracking -> Bool +hasAnythingToShow (GoalTracking ann g) = not (null ann && null g) + +hasMultipleGoals :: GoalTracking -> Bool +hasMultipleGoals gt = + goalCount > 1 + where + goalCount = sum . M.elems . M.map NE.length . goals $ gt + +constructGoalMap :: Bool -> ObjectiveCompletion -> CategorizedGoals +constructGoalMap showHidden oc = + M.fromList $ + mapMaybe (traverse nonEmpty) categoryList + where + categoryList = + [ (Upcoming, displayableInactives) + , (Active, suppressHidden activeGoals) + , (Completed, oc ^.. completedObjectives) + , (Failed, oc ^.. unwinnableObjectives) + ] + + displayableInactives = + suppressHidden $ + filter (maybe False previewable . view objectivePrerequisite) inactiveGoals + + suppressHidden = + applyWhen (not showHidden) $ filter $ not . view objectiveHidden + + (activeGoals, inactiveGoals) = partitionActiveObjectives oc diff --git a/src/swarm-tui/Swarm/TUI/Model/Dialog/Structure.hs b/src/swarm-tui/Swarm/TUI/Model/Dialog/Structure.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Dialog/Structure.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A UI-centric model for Structure presentation. +module Swarm.TUI.Model.Dialog.Structure where + +import Brick.Focus +import Brick.Widgets.List qualified as BL +import Control.Lens (makeLenses) +import Data.List.Extra (enumerate) +import Swarm.Game.Entity (Entity) +import Swarm.Game.Scenario (RecognizableStructureContent) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.TUI.Model.Name + +data StructureDisplay = StructureDisplay + { _structurePanelListWidget :: BL.List Name (StructureInfo RecognizableStructureContent Entity) + -- ^ required for maintaining the selection/navigation + -- state among list items + , _structurePanelFocus :: FocusRing Name + } + +makeLenses ''StructureDisplay + +emptyStructureDisplay :: StructureDisplay +emptyStructureDisplay = + StructureDisplay + (BL.list (StructureWidgets StructuresList) mempty 1) + (focusRing $ map StructureWidgets enumerate) diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -20,17 +21,21 @@ import Data.Bifunctor (first) import Data.List.Extra (enumerate) import Data.Text (Text) +import GHC.Generics (Generic) +import Generic.Data (FiniteEnumeration (..)) import Graphics.Vty qualified as V import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..), directionSyntax) +-- | Swarm named TUI event type. +-- -- See Note [how Swarm event handlers work] - data SwarmEvent = Main MainEvent | REPL REPLEvent | World WorldEvent | Robot RobotEvent - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + deriving (Enum, Bounded) via (FiniteEnumeration SwarmEvent) swarmEvents :: KeyEvents SwarmEvent swarmEvents = @@ -84,6 +89,8 @@ | ToggleCreativeModeEvent | ToggleWorldEditorEvent | ToggleREPLVisibilityEvent + | ViewBaseEvent + | ToggleFPSEvent deriving (Eq, Ord, Show, Enum, Bounded) mainEvents :: KeyEvents MainEvent @@ -109,6 +116,8 @@ ToggleCreativeModeEvent -> "creative mode" ToggleWorldEditorEvent -> "world editor" ToggleREPLVisibilityEvent -> "toggle REPL" + ViewBaseEvent -> "view base robot" + ToggleFPSEvent -> "toggle FPS" defaultMainBindings :: [(MainEvent, [Binding])] defaultMainBindings = allBindings $ \case @@ -133,6 +142,8 @@ ToggleCreativeModeEvent -> [ctrl 'v'] ToggleWorldEditorEvent -> [] ToggleREPLVisibilityEvent -> [meta ','] + ViewBaseEvent -> [meta 'c'] + ToggleFPSEvent -> [meta 'f'] -- ---------------------------------------------- -- REPL EVENTS @@ -163,36 +174,17 @@ -- REPL EVENTS -- ---------------------------------------------- -data WorldEvent - = ViewBaseEvent - | ShowFpsEvent - | MoveViewEvent AbsoluteDir - deriving (Eq, Ord, Show) - -instance Enum WorldEvent where - fromEnum = \case - ViewBaseEvent -> 0 - ShowFpsEvent -> 1 - MoveViewEvent d -> 2 + fromEnum d - toEnum = \case - 0 -> ViewBaseEvent - 1 -> ShowFpsEvent - n -> MoveViewEvent . toEnum $ n - 2 - -instance Bounded WorldEvent where - minBound = ViewBaseEvent - maxBound = MoveViewEvent maxBound +newtype WorldEvent + = MoveViewEvent AbsoluteDir + deriving (Eq, Ord, Show, Generic) + deriving (Enum, Bounded) via (FiniteEnumeration WorldEvent) worldPanelEvents :: KeyEvents WorldEvent worldPanelEvents = allKeyEvents $ \case - ViewBaseEvent -> "view base" - ShowFpsEvent -> "show fps" MoveViewEvent d -> "move view " <> directionSyntax (DAbsolute d) defaultWorldPanelBindings :: [(WorldEvent, [Binding])] defaultWorldPanelBindings = allBindings $ \case - ViewBaseEvent -> [bind 'c'] - ShowFpsEvent -> [bind 'f'] MoveViewEvent DWest -> [bind V.KLeft, bind 'h'] MoveViewEvent DSouth -> [bind V.KDown, bind 'j'] MoveViewEvent DNorth -> [bind V.KUp, bind 'k'] diff --git a/src/swarm-tui/Swarm/TUI/Model/Goal.hs b/src/swarm-tui/Swarm/TUI/Model/Goal.hs deleted file mode 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Goal.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A UI-centric model for Objective presentation. -module Swarm.TUI.Model.Goal where - -import Brick.Focus -import Brick.Widgets.List qualified as BL -import Control.Lens (makeLenses, view, (^..)) -import Data.Aeson -import Data.List.Extra (enumerate) -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (mapMaybe) -import GHC.Generics (Generic) -import Servant.Docs (ToSample) -import Servant.Docs qualified as SD -import Swarm.Game.Scenario.Objective -import Swarm.Game.Scenario.Objective.WinCheck -import Swarm.TUI.Model.Name - --- | These are intended to be used as keys in a map --- of lists of goals. -data GoalStatus - = -- | Goals in this category have other goals as prerequisites. - -- However, they are only displayed if the "previewable" attribute - -- is @true@. - Upcoming - | -- | Goals in this category may be pursued in parallel. - -- However, they are only displayed if the "hidden" attribute - -- is @false@. - Active - | -- | A goal's programmatic condition, as well as all its prerequisites, were completed. - -- This is a "latch" mechanism; at some point the conditions required to meet the goal may - -- no longer hold. Nonetheless, the goal remains "completed". - Completed - | -- | A goal that can no longer be achieved. - -- If this goal is not an "optional" goal, then the player - -- also "loses" the scenario. - -- - -- Note that currently the only way to "fail" a goal is by way - -- of a negative prerequisite that was completed. - Failed - deriving (Show, Eq, Ord, Bounded, Enum, Generic, ToJSON, ToJSONKey) - -type CategorizedGoals = Map GoalStatus (NonEmpty Objective) - -data GoalEntry - = Header GoalStatus - | Goal GoalStatus Objective - | Spacer - -shouldSkipSelection :: GoalEntry -> Bool -shouldSkipSelection = \case - Goal _ _ -> False - _ -> True - -data GoalTracking = GoalTracking - { announcements :: [Announcement] - -- ^ TODO: #1044 the actual contents of these are not used yet, - -- other than as a flag to pop up the Goal dialog. - , goals :: CategorizedGoals - } - deriving (Generic, ToJSON) - -instance ToSample GoalTracking where - toSamples _ = - SD.samples - [ GoalTracking mempty mempty - -- TODO: #1552 add simple objective sample - ] - -data GoalDisplay = GoalDisplay - { _goalsContent :: GoalTracking - , _listWidget :: BL.List Name GoalEntry - -- ^ required for maintaining the selection/navigation - -- state among list items - , _focus :: FocusRing Name - } - -makeLenses ''GoalDisplay - -emptyGoalDisplay :: GoalDisplay -emptyGoalDisplay = - GoalDisplay - (GoalTracking mempty mempty) - (BL.list (GoalWidgets ObjectivesList) mempty 1) - (focusRing $ map GoalWidgets enumerate) - -hasAnythingToShow :: GoalTracking -> Bool -hasAnythingToShow (GoalTracking ann g) = not (null ann && null g) - -hasMultipleGoals :: GoalTracking -> Bool -hasMultipleGoals gt = - goalCount > 1 - where - goalCount = sum . M.elems . M.map NE.length . goals $ gt - -constructGoalMap :: Bool -> ObjectiveCompletion -> CategorizedGoals -constructGoalMap isCheating oc = - M.fromList $ - mapMaybe (traverse nonEmpty) categoryList - where - categoryList = - [ (Upcoming, displayableInactives) - , (Active, suppressHidden activeGoals) - , (Completed, oc ^.. completedObjectives) - , (Failed, oc ^.. unwinnableObjectives) - ] - - displayableInactives = - suppressHidden $ - filter (maybe False previewable . view objectivePrerequisite) inactiveGoals - - suppressHidden = - if isCheating - then id - else filter $ not . view objectiveHidden - - (activeGoals, inactiveGoals) = partitionActiveObjectives oc diff --git a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs --- a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -22,9 +22,9 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as T -import Swarm.Game.Failure (Asset (..), LoadingFailure (..), SystemFailure (..)) -import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) -import Swarm.Language.Pretty (prettyText) +import Swarm.Failure (Asset (..), LoadingFailure (..), SystemFailure (..)) +import Swarm.Pretty (prettyText) +import Swarm.ResourceLoading (getSwarmConfigIniFile) import Swarm.TUI.Controller.EventHandlers import Swarm.TUI.Model import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents) @@ -41,7 +41,7 @@ else do loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini case loadedCustomBindings of - Left e -> throwError $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e) + Left e -> throwError $ AssetNotLoaded Keybindings ini (SystemFailure . CustomFailure $ T.pack e) Right bs -> pure $ fromMaybe [] bs initKeyHandlingState :: @@ -110,9 +110,7 @@ else listBindings $ allDefaultBindings kc ev ) listBindings = T.intercalate "," . fmap ppBinding - name = case keyEventName (keyConfigEvents kc) ev of - Just n -> n - Nothing -> error $ "unnamed event: " <> T.unpack description + name = fromMaybe "(unnamed)" $ keyEventName (keyConfigEvents kc) ev handlerNameKeysDescription :: Ord k => KeyConfig k -> KeyEventHandler k m -> (Text, Text, Text) handlerNameKeysDescription kc keh = (name, keys, desc) diff --git a/src/swarm-tui/Swarm/TUI/Model/Menu.hs b/src/swarm-tui/Swarm/TUI/Model/Menu.hs --- a/src/swarm-tui/Swarm/TUI/Model/Menu.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Menu.hs @@ -16,25 +16,20 @@ import Control.Lens hiding (from, (<.>)) import Data.List.Extra (enumerate) import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M import Data.Text (Text) import Data.Vector qualified as V import Swarm.Game.Achievement.Definitions import Swarm.Game.Entity as E import Swarm.Game.Ingredients +import Swarm.Game.Scenario.Status (ScenarioPath (..)) import Swarm.Game.ScenarioInfo ( ScenarioCollection, - ScenarioInfo (..), - ScenarioInfoPair, ScenarioItem (..), - scMap, + ScenarioWith, scenarioCollectionToList, ) import Swarm.Game.World.Gen (Seed) import Swarm.TUI.Model.Name -import System.FilePath (dropTrailingPathSeparator, splitPath, takeFileName) -import Witch (into) ------------------------------------------------------------ -- Menus and dialogs @@ -43,7 +38,7 @@ data ScenarioOutcome = WinModal | LoseModal deriving (Show, Eq) -data ModalType +data MidScenarioModalType = HelpModal | RecipesModal | CommandsModal @@ -52,19 +47,27 @@ | EntityPaletteModal | TerrainPaletteModal | RobotsModal - | ScenarioEndModal ScenarioOutcome - | QuitModal - | KeepPlayingModal | DescriptionModal Entity | GoalModal deriving (Show, Eq) +data EndScenarioModalType + = ScenarioFinishModal ScenarioOutcome + | QuitModal + | KeepPlayingModal + deriving (Show, Eq) + +data ModalType + = MidScenarioModal MidScenarioModalType + | EndScenarioModal EndScenarioModalType + deriving (Show, Eq) + data ButtonAction = Cancel | KeepPlaying - | StartOver Seed ScenarioInfoPair + | StartOver Seed (ScenarioWith ScenarioPath) | QuitAction - | Next ScenarioInfoPair + | Next (NonEmpty (ScenarioWith ScenarioPath)) data Modal = Modal { _modalType :: ModalType @@ -90,7 +93,7 @@ -- menu item is ALWAYS the same as the scenario currently being played. -- See https://github.com/swarm-game/swarm/issues/1064 and -- https://github.com/swarm-game/swarm/pull/1065. - NewGameMenu (NonEmpty (BL.List Name ScenarioItem)) + NewGameMenu (NonEmpty (BL.List Name (ScenarioItem ScenarioPath))) | AchievementsMenu (BL.List Name CategorizedAchievement) | MessagesMenu | AboutMenu @@ -101,35 +104,11 @@ makePrisms ''Menu -- | Create a brick 'BL.List' of scenario items from a 'ScenarioCollection'. -mkScenarioList :: Bool -> ScenarioCollection -> BL.List Name ScenarioItem -mkScenarioList cheat = flip (BL.list ScenarioList) 1 . V.fromList . filterTest . scenarioCollectionToList - where - filterTest = if cheat then id else filter (\case SICollection n _ -> n /= "Testing"; _ -> True) - --- | Given a 'ScenarioCollection' and a 'FilePath' which is the canonical --- path to some folder or scenario, construct a 'NewGameMenu' stack --- focused on the given item, if possible. -mkNewGameMenu :: Bool -> ScenarioCollection -> FilePath -> Maybe Menu -mkNewGameMenu cheat sc path = fmap NewGameMenu $ NE.nonEmpty =<< go (Just sc) (splitPath path) [] - where - go :: - Maybe ScenarioCollection -> - [FilePath] -> - [BL.List Name ScenarioItem] -> - Maybe [BL.List Name ScenarioItem] - go _ [] stk = Just stk - go Nothing _ _ = Nothing - go (Just curSC) (thing : rest) stk = go nextSC rest (lst : stk) - where - hasName :: ScenarioItem -> Bool - hasName (SISingle (_, ScenarioInfo pth _)) = takeFileName pth == thing - hasName (SICollection nm _) = nm == into @Text (dropTrailingPathSeparator thing) - - lst = BL.listFindBy hasName (mkScenarioList cheat curSC) - - nextSC = case M.lookup (dropTrailingPathSeparator thing) (scMap curSC) of - Just (SICollection _ c) -> Just c - _ -> Nothing +mkScenarioList :: ScenarioCollection a -> BL.List Name (ScenarioItem a) +mkScenarioList = + flip (BL.list ScenarioList) 1 + . V.fromList + . scenarioCollectionToList ------------------------------------------------------------ -- Inventory list entries diff --git a/src/swarm-tui/Swarm/TUI/Model/Name.hs b/src/swarm-tui/Swarm/TUI/Model/Name.hs --- a/src/swarm-tui/Swarm/TUI/Model/Name.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Name.hs @@ -63,6 +63,17 @@ | NextButton deriving (Eq, Ord, Show, Read, Bounded, Enum) +-- | Robot details +data RobotDetailSubpane + = RobotLogPane + | RobotCommandHistogramPane + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +data RobotsDisplayMode + = RobotList + | SingleRobotDetails RobotDetailSubpane + deriving (Eq, Ord, Show, Read) + -- | 'Name' represents names to uniquely identify various components -- of the UI, such as forms, panels, caches, extents, lists, and buttons. data Name @@ -92,6 +103,8 @@ InventoryList | -- | The inventory item position in the InventoryList. InventoryListItem Int + | -- | Cacheable scenario preview + ScenarioPreview FilePath | -- | The list of main menu choices. MenuList | -- | The list of achievements. @@ -104,6 +117,8 @@ StructureWidgets StructureWidget | -- | The list of scenario choices. ScenarioList + | -- | The robots list + RobotsListDialog RobotsDisplayMode | -- | The scrollable viewport for the info panel. InfoViewport | -- | The scrollable viewport for any modal dialog. @@ -112,6 +127,8 @@ REPLViewport | -- | A clickable button in a modal dialog. Button Button + | -- | A clickable shortcut in the TUI. + UIShortcut Text | -- | A custom widget name, for use in applications built on top of the Swarm library. CustomName Text deriving (Eq, Ord, Show, Read) diff --git a/src/swarm-tui/Swarm/TUI/Model/Popup.hs b/src/swarm-tui/Swarm/TUI/Model/Popup.hs deleted file mode 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Popup.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} - -module Swarm.TUI.Model.Popup ( - -- * Popup types - Popup (..), - - -- * Popup state - PopupState, - currentPopup, - popupQueue, - initPopupState, - addPopup, - - -- * Popup animation - popupFrames, - progressPopups, -) where - -import Control.Lens (makeLenses, use, (%~), (+=), (.=), _2, _Just) -import Control.Monad.State (MonadState) -import Data.Functor (($>)) -import Data.Maybe (isJust) -import Data.Sequence (Seq, (|>), pattern (:<|)) -import Data.Sequence qualified as Seq -import Swarm.Game.Achievement.Definitions (CategorizedAchievement) -import Swarm.Language.Syntax (Const) - --- | Different types of popups that can be displayed to the --- player. -data Popup - = AchievementPopup CategorizedAchievement - | RecipesPopup - | CommandsPopup [Const] - --- | State to track pending popup queue as well as any --- popup which is currently being displayed. -data PopupState = PopupState - { _currentPopup :: Maybe (Popup, Int) - , _popupQueue :: Seq Popup - } - -makeLenses ''PopupState - --- | Initial, empty popup state. -initPopupState :: PopupState -initPopupState = - PopupState - { _currentPopup = Nothing - , _popupQueue = Seq.empty - } - --- | Add a popup to the end of the queue. -addPopup :: Popup -> PopupState -> PopupState -addPopup notif = popupQueue %~ (|> notif) - --- | The number of frames for which to display a popup. -popupFrames :: Int -popupFrames = 100 - --- | Progress the popup state by one frame: pull the next --- popup from the queue if there is no current popup --- or the current popup has reached the max frame count; --- otherwise just increment the frame count of the current --- popup. --- --- Return True if something was updated that might require redrawing --- the UI. -progressPopups :: MonadState PopupState m => m Bool -progressPopups = do - cur <- use currentPopup - case cur of - Nothing -> nextPopup - Just (_, frameCount) - | frameCount == popupFrames -> nextPopup $> True - | otherwise -> do - currentPopup . _Just . _2 += 1 - pure True - --- | Move the next popup (if any) from the queue to the --- currently displayed popup. Return True if there was any --- popup to move. -nextPopup :: MonadState PopupState m => m Bool -nextPopup = do - q <- use popupQueue - cur <- use currentPopup - case q of - Seq.Empty - | isJust cur -> do - currentPopup .= Nothing - pure True - | otherwise -> pure False - n :<| ns -> do - currentPopup .= Just (n, 0) - popupQueue .= ns - pure True diff --git a/src/swarm-tui/Swarm/TUI/Model/Repl.hs b/src/swarm-tui/Swarm/TUI/Model/Repl.hs --- a/src/swarm-tui/Swarm/TUI/Model/Repl.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Repl.hs @@ -11,10 +11,6 @@ REPLEntryType (..), REPLHistItemType (..), REPLHistItem (..), - mkREPLSubmission, - mkREPLSaved, - mkREPLOutput, - mkREPLError, isREPLEntry, getREPLSubmitted, isREPLSaved, @@ -58,7 +54,6 @@ ) where import Brick.Widgets.Edit (Editor, applyEdit, editorText, getEditContents) -import Control.Applicative (Applicative (liftA2)) import Control.Lens hiding (from, (.=), (<.>)) import Data.Aeson (ToJSON, object, toJSON, (.=)) import Data.Foldable (toList) @@ -70,11 +65,12 @@ import Data.Text.Zipper qualified as TZ import Servant.Docs (ToSample) import Servant.Docs qualified as SD +import Swarm.Game.Tick (TickNumber (..)) import Swarm.Language.Syntax (SrcLoc (..)) import Swarm.Language.Types import Swarm.TUI.Model.Name +import Swarm.Util (applyWhen) import Swarm.Util.Lens (makeLensesNoSigs) -import Prelude hiding (Applicative (..)) ------------------------------------------------------------ -- REPL History @@ -84,11 +80,11 @@ data REPLEntryType = -- | The entry was submitted (with Enter) and should thus be shown -- in the REPL scrollback. - REPLEntrySubmitted + Submitted | -- | The entry was merely saved (e.g. by hitting down -- arrow) and should thus be available in the history but not -- shown in the scrollback. - REPLEntrySaved + Stashed deriving (Eq, Ord, Show, Read) -- | Various types of REPL history items (user input, output, error). @@ -102,37 +98,44 @@ deriving (Eq, Ord, Show, Read) -- | An item in the REPL history. -data REPLHistItem = REPLHistItem {replItemType :: REPLHistItemType, replItemText :: Text} +data REPLHistItem = REPLHistItem + { replItemType :: REPLHistItemType + , replItemTick :: TickNumber + , replItemText :: Text + } deriving (Eq, Ord, Show, Read) -mkREPLSubmission :: Text -> REPLHistItem -mkREPLSubmission = REPLHistItem (REPLEntry REPLEntrySubmitted) - -mkREPLSaved :: Text -> REPLHistItem -mkREPLSaved = REPLHistItem (REPLEntry REPLEntrySaved) - -mkREPLOutput :: Text -> REPLHistItem -mkREPLOutput = REPLHistItem REPLOutput - -mkREPLError :: Text -> REPLHistItem -mkREPLError = REPLHistItem REPLError - instance ToSample REPLHistItem where toSamples _ = SD.samples - [ REPLHistItem (REPLEntry REPLEntrySubmitted) "grab" - , REPLHistItem REPLOutput "it0 : text = \"tree\"" - , REPLHistItem (REPLEntry REPLEntrySaved) "place" - , REPLHistItem (REPLEntry REPLEntrySubmitted) "place tree" - , REPLHistItem REPLError "1:7: Unbound variable tree" + [ REPLHistItem + (REPLEntry Submitted) + (TickNumber 0) + "grab" + , REPLHistItem + REPLOutput + (TickNumber 0) + "it0 : text = \"tree\"" + , REPLHistItem + (REPLEntry Stashed) + (TickNumber 1) + "place" + , REPLHistItem + (REPLEntry Submitted) + (TickNumber 2) + "place tree" + , REPLHistItem + REPLError + (TickNumber 2) + "1:7: Unbound variable tree" ] instance ToJSON REPLHistItem where - toJSON (REPLHistItem itemType x) = object [label .= x] + toJSON (REPLHistItem itemType tick x) = object ["tick" .= tick, label .= x] where label = case itemType of - REPLEntry REPLEntrySubmitted -> "in" - REPLEntry REPLEntrySaved -> "save" + REPLEntry Submitted -> "in" + REPLEntry Stashed -> "save" REPLOutput -> "out" REPLError -> "err" @@ -140,7 +143,7 @@ -- user input, including both submitted and saved history items. getREPLEntry :: REPLHistItem -> Maybe Text getREPLEntry = \case - REPLHistItem (REPLEntry {}) t -> Just t + REPLHistItem (REPLEntry {}) _ t -> Just t _ -> Nothing -- | Useful helper function to filter out REPL output. Returns True @@ -152,13 +155,13 @@ -- | Helper function to get only submitted user input text. getREPLSubmitted :: REPLHistItem -> Maybe Text getREPLSubmitted = \case - REPLHistItem (REPLEntry REPLEntrySubmitted) t -> Just t + REPLHistItem (REPLEntry Submitted) _ t -> Just t _ -> Nothing -- | Useful helper function to filter out saved REPL entries (which -- should not be shown in the scrollback). isREPLSaved :: REPLHistItem -> Bool -isREPLSaved (REPLHistItem (REPLEntry REPLEntrySaved) _) = True +isREPLSaved (REPLHistItem (REPLEntry Stashed) _ _) = True isREPLSaved _ = False -- | History of the REPL with indices (0 is first entry) to the current @@ -262,7 +265,7 @@ (olderP, newer) = Seq.splitAt curIndex entries -- find first different entry in direction notSameEntry = \case - REPLHistItem (REPLEntry {}) t -> t /= curText + REPLHistItem (REPLEntry {}) _tick t -> t /= curText _ -> False newIndex = case d of Newer -> maybe historyLen (curIndex +) $ Seq.findIndexL notSameEntry newer @@ -333,7 +336,7 @@ where ls = T.lines t pos = (length ls - 1, T.length (last ls)) - gotoEnd = if null ls then id else TZ.moveCursor pos + gotoEnd = applyWhen (not $ null ls) $ TZ.moveCursor pos initREPLState :: REPLHistory -> REPLState initREPLState hist = diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -14,21 +14,25 @@ restartGame, attainAchievement, attainAchievement', + getScenarioInfoFromPath, scenarioToAppState, + animMgrTickDuration, + PersistentState (..), ) where +import Brick.Animation (startAnimationManager) import Brick.AttrMap (applyAttrMappings) +import Brick.BChan (BChan, newBChan) import Brick.Focus import Brick.Widgets.List qualified as BL import Control.Applicative ((<|>)) -import Control.Carrier.Accum.FixedStrict (runAccum) -import Control.Carrier.Lift (runM) -import Control.Carrier.Throw.Either (runThrow) +import Control.Arrow ((&&&)) +import Control.Carrier.Accum.Strict (runAccum) import Control.Effect.Accum import Control.Effect.Lift import Control.Effect.Throw import Control.Lens hiding (from, (<.>)) -import Control.Monad (guard, void) +import Control.Monad (guard, unless, void) import Control.Monad.Except (ExceptT (..)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execStateT) @@ -36,13 +40,18 @@ import Data.Foldable qualified as F import Data.List qualified as List import Data.List.Extra (enumerate) +import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq) +import Data.Set qualified as Set import Data.Text (Text) +import Data.Text qualified as T import Data.Time (getZonedTime) -import Swarm.Game.Failure (SystemFailure (..)) +import Swarm.Failure (SystemFailure (..)) +import Swarm.Game.Achievement.Attainment +import Swarm.Game.Achievement.Persistence import Swarm.Game.Land import Swarm.Game.Scenario ( ScenarioInputs (..), @@ -58,11 +67,12 @@ import Swarm.Game.Scenario.Scoring.ConcreteMetrics import Swarm.Game.Scenario.Scoring.GenericMetrics import Swarm.Game.Scenario.Status -import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.ScenarioInfo ( - loadScenarioInfo, + ScenarioCollection, + loadScenarios, normalizeScenarioPath, + pathifyCollection, scenarioItemByPath, _SISingle, ) @@ -71,35 +81,46 @@ import Swarm.Game.State.Landscape import Swarm.Game.State.Runtime import Swarm.Game.State.Substate +import Swarm.Game.Tick (TickNumber (TickNumber)) import Swarm.Game.World.Gen (Seed) -import Swarm.Language.Pretty (prettyText) import Swarm.Log (LogSource (SystemLog), Severity (..)) +import Swarm.Pretty (prettyText) +import Swarm.ResourceLoading (getSwarmHistoryPath) +import Swarm.TUI.Editor.Model import Swarm.TUI.Editor.Model qualified as EM import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Launch.Model (toSerializableParams) import Swarm.TUI.Model import Swarm.TUI.Model.Achievements -import Swarm.TUI.Model.Goal (emptyGoalDisplay) +import Swarm.TUI.Model.DebugOption (DebugOption (LoadTestingScenarios)) +import Swarm.TUI.Model.Dialog import Swarm.TUI.Model.KeyBindings import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl -import Swarm.TUI.Model.Structure import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import Swarm.TUI.View.Attribute.Attr (getWorldAttrName, swarmAttrMap) import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair) +import Swarm.TUI.View.Robot import Swarm.TUI.View.Structure qualified as SR +import Swarm.Util import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock +-- | The resolution at which the animation manager checks animations for updates, in miliseconds +animMgrTickDuration :: Int +animMgrTickDuration = 33 + -- | Initialize the 'AppState' from scratch. initAppState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => AppOpts -> + Maybe (BChan AppEvent) -> m AppState -initAppState opts = do - (rs, ui, keyHandling) <- initPersistentState opts - constructAppState rs ui keyHandling opts +initAppState opts mChan = do + persistentState <- initPersistentState opts + constructAppState persistentState opts mChan -- | Add some system failures to the list of messages in the -- 'RuntimeState'. @@ -115,6 +136,21 @@ where isRunningInitialProgram = isJust scriptToRun || autoPlay +mkRuntimeOptions :: AppOpts -> RuntimeOptions +mkRuntimeOptions AppOpts {..} = + RuntimeOptions + { startPaused = pausedAtStart + , pauseOnObjectiveCompletion = autoShowObjectives + , loadTestScenarios = Set.member LoadTestingScenarios debugOptions + } + +data PersistentState + = PersistentState + RuntimeState + UIState + KeyEventHandlingState + ProgressionState + -- | Initialize the more persistent parts of the app state, /i.e./ the -- 'RuntimeState' and 'UIState'. This is split out into a separate -- function so that in the integration test suite we can call this @@ -122,29 +158,70 @@ initPersistentState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => AppOpts -> - m (RuntimeState, UIState, KeyEventHandlingState) + m PersistentState initPersistentState opts@(AppOpts {..}) = do - (warnings :: Seq SystemFailure, (initRS, initUI, initKs)) <- runAccum mempty $ do - rs <- initRuntimeState - ui <- initUIState speed (not (skipMenu opts)) cheatMode + (warnings :: Seq SystemFailure, PersistentState initRS initUI initKs initProg) <- runAccum mempty $ do + rs <- initRuntimeState $ mkRuntimeOptions opts + let showMainMenu = not (skipMenu opts) + ui <- initUIState UIInitOptions {..} ks <- initKeyHandlingState - return (rs, ui, ks) + + s <- + loadScenarios + (gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs) + (loadTestScenarios $ mkRuntimeOptions opts) + achievements <- loadAchievementsInfo + + let animState = AnimInactive + let progState = + ProgressionState + { _scenarios = s + , _attainedAchievements = M.fromList $ map (view achievement &&& id) achievements + , _uiPopups = initPopupState + , _scenarioSequence = mempty + , _uiPopupAnimationState = animState + } + return $ PersistentState rs ui ks progState let initRS' = addWarnings initRS (F.toList warnings) - return (initRS', initUI, initKs) + return $ PersistentState initRS' initUI initKs initProg +getScenarioInfoFromPath :: + ScenarioCollection ScenarioInfo -> + FilePath -> + ScenarioInfo +getScenarioInfoFromPath ss path = + fromMaybe (ScenarioInfo path NotStarted) currentScenarioInfo + where + currentScenarioInfo = ss ^? scenarioItemByPath path . _SISingle . getScenarioInfo + -- | Construct an 'AppState' from an already-loaded 'RuntimeState' and -- 'UIState', given the 'AppOpts' the app was started with. constructAppState :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - RuntimeState -> - UIState -> - KeyEventHandlingState -> + ( Has (Throw SystemFailure) sig m + , Has (Lift IO) sig m + ) => + PersistentState -> AppOpts -> + Maybe (BChan AppEvent) -> m AppState -constructAppState rs ui key opts@(AppOpts {..}) = do - let gs = initGameState $ rs ^. stdGameConfigInputs +constructAppState (PersistentState rs ui key progState) opts@(AppOpts {..}) mChan = do + historyT <- sendIO $ readFileMayT =<< getSwarmHistoryPath False + let mkREPLSubmission = REPLHistItem (REPLEntry Submitted) (TickNumber $ -1) + let history = maybe [] (map mkREPLSubmission . T.lines) historyT + startTime <- sendIO $ getTime Monotonic + chan <- sendIO $ maybe initTestChan pure mChan + animMgr <- sendIO $ startAnimationManager animMgrTickDuration chan PopupEvent + + let gsc = rs ^. stdGameConfigInputs + gs = initGameState gsc + ps = + PlayState + { _scenarioState = ScenarioState gs $ initialUiGameplay startTime history + , _progression = progState + } + case skipMenu opts of - False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) key rs + False -> return $ AppState (ps & scenarioState . uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) ui key rs animMgr True -> do let tem = gs ^. landscape . terrainAndEntities (scenario, path) <- @@ -159,18 +236,67 @@ return $ CodeToRun ScenarioSuggested soln codeToRun = maybeAutoplay <|> maybeRunScript - eitherSi <- sendIO . runM . runThrow $ loadScenarioInfo path - let (si, newRs) = case eitherSi of - Right x -> (x, rs) - Left e -> (ScenarioInfo path NotStarted, addWarnings rs [e]) + let si = getScenarioInfoFromPath (progState ^. scenarios) path + sendIO $ execStateT - (startGameWithSeed (scenario, si) $ LaunchParams (pure userSeed) (pure codeToRun)) - (AppState gs ui key newRs) + (startGameWithSeed (ScenarioWith scenario si) $ LaunchParams (pure userSeed) (pure codeToRun)) + (AppState ps ui key rs animMgr) + where + initialUiGameplay startTime history = + UIGameplay + { _uiFocusRing = initFocusRing + , _uiWorldCursor = Nothing + , _uiWorldEditor = initialWorldEditor startTime + , _uiREPL = initREPLState $ newREPLHistory history + , _uiInventory = + UIInventory + { _uiInventoryList = Nothing + , _uiInventorySort = defaultSortOptions + , _uiInventorySearch = Nothing + , _uiShowZero = True + , _uiInventoryShouldUpdate = False + } + , _uiScrollToEnd = False + , _uiDialogs = + UIDialogs + { _uiModal = Nothing + , _uiGoal = emptyGoalDisplay + , _uiStructure = emptyStructureDisplay + , _uiRobot = emptyRobotDisplay debugOptions + } + , _uiIsAutoPlay = False + , _uiAutoShowObjectives = autoShowObjectives + , _uiTiming = + UITiming + { _uiShowFPS = False + , _uiTPF = 0 + , _uiFPS = 0 + , _lgTicksPerSecond = speed + , _lastFrameTime = startTime + , _accumulatedTime = 0 + , _lastInfoTime = 0 + , _tickCount = 0 + , _frameCount = 0 + , _frameTickCount = 0 + } + , _uiShowREPL = True + , _uiShowDebug = False + , _uiHideRobotsUntil = startTime - 1 + , _scenarioRef = Nothing + } -- | Load a 'Scenario' and start playing the game. -startGame :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe CodeToRun -> m () -startGame siPair = startGameWithSeed siPair . LaunchParams (pure Nothing) . pure +startGame :: + (MonadIO m, MonadState AppState m) => + NonEmpty (ScenarioWith ScenarioPath) -> + Maybe CodeToRun -> + m () +startGame (ScenarioWith s (ScenarioPath p) :| remaining) c = do + playState . progression . scenarioSequence .= remaining + ss <- use $ playState . progression . scenarios + let si = getScenarioInfoFromPath ss p + startGameWithSeed (ScenarioWith s si) . LaunchParams (pure Nothing) $ pure c -- | Re-initialize the game from the stored reference to the current scenario. -- @@ -181,34 +307,47 @@ -- -- 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 siPair $ LaunchParams (pure (Just currentSeed)) (pure Nothing) +restartGame :: + (MonadIO m, MonadState AppState m) => + Seed -> + ScenarioWith ScenarioPath -> + m () +restartGame currentSeed (ScenarioWith s (ScenarioPath p)) = do + ss <- use $ playState . progression . scenarios + let si = getScenarioInfoFromPath ss p + startGameWithSeed (ScenarioWith s si) $ LaunchParams (pure (Just currentSeed)) (pure 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) => - ScenarioInfoPair -> + ScenarioWith ScenarioInfo -> ValidatedLaunchParams -> m () -startGameWithSeed siPair@(_scene, si) lp = do +startGameWithSeed siPair@(ScenarioWith _scene si) lp = do t <- liftIO getZonedTime - ss <- use $ runtimeState . scenarios - p <- liftIO $ normalizeScenarioPath ss (si ^. scenarioPath) - runtimeState + ss <- use $ playState . progression . scenarios + p <- liftIO $ normalizeScenarioPath ss $ si ^. scenarioPath + + playState + . progression . scenarios . scenarioItemByPath p . _SISingle - . _2 + . getScenarioInfo . scenarioStatus .= Played (toSerializableParams lp) (Metric Attempted $ ProgressStats t emptyAttemptMetric) (prevBest t) - scenarioToAppState siPair lp - -- Beware: currentScenarioPath must be set so that progress/achievements can be saved. - -- It has just been cleared in scenarioToAppState. - gameState . currentScenarioPath .= Just p + + scenarioToAppState (pathifyCollection siPair) lp + + -- Warn the user that the use of debugging options means progress + -- will not be saved. + debugging <- use $ uiState . uiDebugOptions + unless (null debugging) $ + playState . progression . uiPopups %= addPopup DebugWarningPopup where prevBest t = case si ^. scenarioStatus of NotStarted -> emptyBest t @@ -217,17 +356,21 @@ -- | Modify the 'AppState' appropriately when starting a new scenario. scenarioToAppState :: (MonadIO m, MonadState AppState m) => - ScenarioInfoPair -> + ScenarioWith ScenarioPath -> ValidatedLaunchParams -> m () -scenarioToAppState siPair@(scene, _) lp = do +scenarioToAppState siPair@(ScenarioWith scene p) lp = do rs <- use runtimeState - gs <- liftIO $ scenarioToGameState scene lp $ rs ^. stdGameConfigInputs - gameState .= gs - void $ withLensIO uiState $ scenarioToUIState isAutoplaying siPair gs + gs <- liftIO $ scenarioToGameState (ScenarioWith scene $ Just p) lp $ rs ^. stdGameConfigInputs + playState . scenarioState . gameState .= gs + + curTime <- liftIO $ getTime Monotonic + playState . scenarioState . uiGameplay %= setUIGameplay gs curTime isAutoplaying siPair + + void $ withLensIO uiState $ scenarioToUIState siPair where - isAutoplaying = case runIdentity (initialCode lp) of - Just (CodeToRun ScenarioSuggested _) -> True + isAutoplaying = case fmap (view toRunSource) . runIdentity $ initialCode lp of + Just ScenarioSuggested -> True _ -> False withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m x @@ -237,43 +380,33 @@ l .= x' return x' --- | Modify the UI state appropriately when starting a new scenario. -scenarioToUIState :: - Bool -> - ScenarioInfoPair -> +setUIGameplay :: GameState -> - UIState -> - IO UIState -scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do - curTime <- getTime Monotonic - return $ - u - & uiPlaying .~ True - & uiCheatMode ||~ isAutoplaying - & uiAttrMap - .~ applyAttrMappings - ( map (first getWorldAttrName . toAttrPair) $ - fst siPair ^. scenarioLandscape . scenarioAttrs - ) - swarmAttrMap - & uiGameplay . uiGoal .~ emptyGoalDisplay - & uiGameplay . uiHideGoals .~ (isAutoplaying && not (u ^. uiCheatMode)) - & uiGameplay . uiFocusRing .~ initFocusRing - & uiGameplay . uiInventory . uiInventorySearch .~ Nothing - & uiGameplay . uiInventory . uiInventoryList .~ Nothing - & uiGameplay . uiInventory . uiInventorySort .~ defaultSortOptions - & uiGameplay . uiInventory . uiShowZero .~ True - & uiGameplay . uiTiming . uiShowFPS .~ False - & uiGameplay . uiREPL .~ initREPLState (u ^. uiGameplay . uiREPL . replHistory) - & uiGameplay . uiREPL . replHistory %~ restartREPLHistory - & uiGameplay . scenarioRef ?~ siPair - & uiGameplay . uiTiming . lastFrameTime .~ curTime - & uiGameplay . uiWorldEditor . EM.entityPaintList %~ BL.listReplace entityList Nothing - & uiGameplay . uiWorldEditor . EM.editingBounds . EM.boundsRect %~ setNewBounds - & uiGameplay . uiStructure - .~ StructureDisplay - (SR.makeListWidget . M.elems $ gs ^. discovery . structureRecognition . automatons . originalStructureDefinitions) - (focusSetCurrent (StructureWidgets StructuresList) $ focusRing $ map StructureWidgets enumerate) + TimeSpec -> + Bool -> + ScenarioWith ScenarioPath -> + UIGameplay -> + UIGameplay +setUIGameplay gs curTime isAutoplaying siPair@(ScenarioWith scenario _) uig = + uig + & uiDialogs . uiGoal .~ emptyGoalDisplay + & uiIsAutoPlay .~ isAutoplaying + & uiFocusRing .~ initFocusRing + & uiInventory . uiInventorySearch .~ Nothing + & uiInventory . uiInventoryList .~ Nothing + & uiInventory . uiInventorySort .~ defaultSortOptions + & uiInventory . uiShowZero .~ True + & uiTiming . uiShowFPS .~ False + & uiREPL .~ initREPLState (uig ^. uiREPL . replHistory) + & uiREPL . replHistory %~ restartREPLHistory + & scenarioRef ?~ siPair + & uiTiming . lastFrameTime .~ curTime + & uiWorldEditor . EM.entityPaintList %~ BL.listReplace entityList Nothing + & uiWorldEditor . EM.editingBounds . EM.boundsRect %~ setNewBounds + & uiDialogs . uiStructure + .~ StructureDisplay + (SR.makeListWidget . M.elems $ gs ^. landscape . recognizerAutomatons . originalStructureDefinitions) + (focusSetCurrent (StructureWidgets StructuresList) $ focusRing $ map StructureWidgets enumerate) where entityList = EU.getEntitiesForList $ gs ^. landscape . terrainAndEntities . entityMap @@ -287,6 +420,27 @@ then maybeOldBounds else Just newBounds +-- | Modify the UI state appropriately when starting a new scenario. +scenarioToUIState :: + ScenarioWith a -> + UIState -> + IO UIState +scenarioToUIState siPair u = do + return $ + u + & uiPlaying .~ True + & uiAttrMap + .~ applyAttrMappings + ( map (first getWorldAttrName . toAttrPair) $ + siPair ^. getScenario . scenarioLandscape . scenarioAttrs + ) + swarmAttrMap + +-- | Create a BChan that holds only one event. +-- This should only be used in unit tests, integration tests, and benchmarks +initTestChan :: IO (BChan AppEvent) +initTestChan = newBChan 1 + -- | Create an initial app state for a specific scenario. Note that -- this function is used only for unit tests, integration tests, and -- benchmarks. @@ -295,7 +449,7 @@ -- to update it using 'scenarioToAppState'. initAppStateForScenario :: String -> Maybe Seed -> Maybe FilePath -> ExceptT Text IO AppState initAppStateForScenario sceneName userSeed toRun = - asExceptT . withThrow (prettyText @SystemFailure) . initAppState $ + asExceptT . withThrow (prettyText @SystemFailure) . flip initAppState Nothing $ defaultAppOpts { userScenario = Just sceneName , userSeed = userSeed diff --git a/src/swarm-tui/Swarm/TUI/Model/Structure.hs b/src/swarm-tui/Swarm/TUI/Model/Structure.hs deleted file mode 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Structure.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A UI-centric model for Structure presentation. -module Swarm.TUI.Model.Structure where - -import Brick.Focus -import Brick.Widgets.List qualified as BL -import Control.Lens (makeLenses) -import Data.List.Extra (enumerate) -import Swarm.Game.Entity (Entity) -import Swarm.Game.Scenario (StructureCells) -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -import Swarm.TUI.Model.Name - -data StructureDisplay = StructureDisplay - { _structurePanelListWidget :: BL.List Name (StructureInfo StructureCells Entity) - -- ^ required for maintaining the selection/navigation - -- state among list items - , _structurePanelFocus :: FocusRing Name - } - -makeLenses ''StructureDisplay - -emptyStructureDisplay :: StructureDisplay -emptyStructureDisplay = - StructureDisplay - (BL.list (StructureWidgets StructuresList) mempty 1) - (focusRing $ map StructureWidgets enumerate) diff --git a/src/swarm-tui/Swarm/TUI/Model/UI.hs b/src/swarm-tui/Swarm/TUI/Model/UI.hs --- a/src/swarm-tui/Swarm/TUI/Model/UI.hs +++ b/src/swarm-tui/Swarm/TUI/Model/UI.hs @@ -8,282 +8,47 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.Model.UI ( UIState (..), - UIGameplay (..), - UITiming (..), - UIInventory (..), - GoalDisplay (..), - uiGameplay, - uiPopups, - uiTiming, - uiInventory, uiMenu, uiPlaying, - uiCheatMode, - uiFocusRing, + uiDebugOptions, uiLaunchConfig, - uiWorldCursor, - uiWorldEditor, - uiREPL, - uiInventoryList, - uiInventorySort, - uiInventorySearch, - uiScrollToEnd, - uiModal, - uiGoal, - uiStructure, - uiHideGoals, - uiAchievements, - lgTicksPerSecond, - lastFrameTime, - accumulatedTime, - tickCount, - frameCount, - frameTickCount, - lastInfoTime, - uiShowFPS, - uiShowREPL, - uiShowZero, - uiShowDebug, - uiShowRobots, - uiHideRobotsUntil, - uiInventoryShouldUpdate, - uiTPF, - uiFPS, uiAttrMap, - scenarioRef, -- ** Initialization initFocusRing, defaultInitLgTicksPerSecond, initUIState, + UIInitOptions (..), ) where import Brick (AttrMap) import Brick.Focus -import Brick.Widgets.List qualified as BL -import Control.Arrow ((&&&)) import Control.Effect.Accum import Control.Effect.Lift import Control.Lens hiding (from, (<.>)) -import Data.Bits (FiniteBits (finiteBitSize)) import Data.List.Extra (enumerate) -import Data.Map (Map) -import Data.Map qualified as M import Data.Sequence (Seq) -import Data.Text (Text) -import Data.Text qualified as T -import Swarm.Game.Achievement.Attainment -import Swarm.Game.Achievement.Definitions -import Swarm.Game.Achievement.Persistence -import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.ResourceLoading (getSwarmHistoryPath) -import Swarm.Game.ScenarioInfo ( - ScenarioInfoPair, - ) -import Swarm.Game.Universe -import Swarm.Game.World.Coords -import Swarm.TUI.Editor.Model -import Swarm.TUI.Inventory.Sorting +import Data.Set (Set) +import Swarm.Failure (SystemFailure) import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.Prep -import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.DebugOption (DebugOption) import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name -import Swarm.TUI.Model.Popup -import Swarm.TUI.Model.Repl -import Swarm.TUI.Model.Structure import Swarm.TUI.View.Attribute.Attr (swarmAttrMap) -import Swarm.Util -import Swarm.Util.Lens (makeLensesExcluding, makeLensesNoSigs) -import System.Clock - -data UITiming = UITiming - { _uiShowFPS :: Bool - , _uiTPF :: Double - , _uiFPS :: Double - , _lgTicksPerSecond :: Int - , _tickCount :: Int - , _frameCount :: Int - , _frameTickCount :: Int - , _lastFrameTime :: TimeSpec - , _accumulatedTime :: TimeSpec - , _lastInfoTime :: TimeSpec - } - --- * Lenses for UITiming - -makeLensesExcluding ['_lgTicksPerSecond] ''UITiming - --- | A toggle to show the FPS by pressing @f@ -uiShowFPS :: Lens' UITiming Bool - --- | Computed ticks per milliseconds -uiTPF :: Lens' UITiming Double - --- | Computed frames per milliseconds -uiFPS :: Lens' UITiming Double - --- | 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' UITiming Int -lgTicksPerSecond = lens _lgTicksPerSecond safeSetLgTicks - where - maxLog = finiteBitSize (maxBound :: Int) - maxTicks = maxLog - 2 - minTicks = 2 - maxLog - safeSetLgTicks ui lTicks - | lTicks < minTicks = setLgTicks ui minTicks - | lTicks > maxTicks = setLgTicks ui maxTicks - | otherwise = setLgTicks ui lTicks - setLgTicks ui lTicks = ui {_lgTicksPerSecond = lTicks} - --- | A counter used to track how many ticks have happened since the --- last time we updated the ticks/frame statistics. -tickCount :: Lens' UITiming Int - --- | A counter used to track how many frames have been rendered since the --- last time we updated the ticks/frame statistics. -frameCount :: Lens' UITiming Int - --- | A counter used to track how many ticks have happened in the --- current frame, so we can stop when we get to the tick cap. -frameTickCount :: Lens' UITiming Int - --- | The time of the last info widget update -lastInfoTime :: Lens' UITiming TimeSpec - --- | The time of the last 'Swarm.TUI.Model.Frame' event. -lastFrameTime :: Lens' UITiming TimeSpec - --- | The amount of accumulated real time. Every time we get a 'Swarm.TUI.Model.Frame' --- event, we accumulate the amount of real time that happened since --- the last frame, then attempt to take an appropriate number of --- ticks to "catch up", based on the target tick rate. --- --- See https://gafferongames.com/post/fix_your_timestep/ . -accumulatedTime :: Lens' UITiming TimeSpec - -data UIInventory = UIInventory - { _uiInventoryList :: Maybe (Int, BL.List Name InventoryListEntry) - , _uiInventorySort :: InventorySortOptions - , _uiInventorySearch :: Maybe Text - , _uiShowZero :: Bool - , _uiInventoryShouldUpdate :: Bool - } - --- * Lenses for UIInventory - -makeLensesNoSigs ''UIInventory - --- | The order and direction of sorting inventory list. -uiInventorySort :: Lens' UIInventory InventorySortOptions - --- | The current search string used to narrow the inventory view. -uiInventorySearch :: Lens' UIInventory (Maybe Text) - --- | 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 --- focused robot's inventory. -uiInventoryList :: Lens' UIInventory (Maybe (Int, BL.List Name InventoryListEntry)) - --- | A toggle to show or hide inventory items with count 0 by pressing @0@ -uiShowZero :: Lens' UIInventory Bool - --- | Whether the Inventory ui panel should update -uiInventoryShouldUpdate :: Lens' UIInventory Bool - --- | The main record holding the gameplay UI state. For access to the fields, --- see the lenses below. -data UIGameplay = UIGameplay - { _uiFocusRing :: FocusRing Name - , _uiWorldCursor :: Maybe (Cosmic Coords) - , _uiWorldEditor :: WorldEditor Name - , _uiREPL :: REPLState - , _uiInventory :: UIInventory - , _uiScrollToEnd :: Bool - , _uiModal :: Maybe Modal - , _uiGoal :: GoalDisplay - , _uiStructure :: StructureDisplay - , _uiHideGoals :: Bool - , _uiShowREPL :: Bool - , _uiShowDebug :: Bool - , _uiHideRobotsUntil :: TimeSpec - , _uiTiming :: UITiming - , _scenarioRef :: Maybe ScenarioInfoPair - } - --- * Lenses for UIGameplay - -makeLensesNoSigs ''UIGameplay - --- | Temporal information for gameplay UI -uiTiming :: Lens' UIGameplay UITiming - --- | Inventory information for gameplay UI -uiInventory :: Lens' UIGameplay UIInventory - --- | The focus ring is the set of UI panels we can cycle among using --- the @Tab@ key. -uiFocusRing :: Lens' UIGameplay (FocusRing Name) - --- | The last clicked position on the world view. -uiWorldCursor :: Lens' UIGameplay (Maybe (Cosmic Coords)) - --- | State of all World Editor widgets -uiWorldEditor :: Lens' UIGameplay (WorldEditor Name) - --- | The state of REPL panel. -uiREPL :: Lens' UIGameplay REPLState - --- | A flag telling the UI to scroll the info panel to the very end --- (used when a new log message is appended). -uiScrollToEnd :: Lens' UIGameplay Bool - --- | When this is 'Just', it represents a modal to be displayed on --- top of the UI, e.g. for the Help screen. -uiModal :: Lens' UIGameplay (Maybe Modal) - --- | Status of the scenario goal: whether there is one, and whether it --- has been displayed to the user initially. -uiGoal :: Lens' UIGameplay GoalDisplay - --- | Definition and status of a recognizable structure -uiStructure :: Lens' UIGameplay StructureDisplay - --- | When running with @--autoplay@, suppress the goal dialogs. --- --- For development, the @--cheat@ flag shows goals again. -uiHideGoals :: Lens' UIGameplay Bool - --- | A toggle to expand or collapse the REPL by pressing @Ctrl-k@ -uiShowREPL :: Lens' UIGameplay Bool - --- | A toggle to show debug. --- --- TODO: #1112 use record for selection of debug features? -uiShowDebug :: Lens' UIGameplay Bool - --- | Hide robots on the world map. -uiHideRobotsUntil :: Lens' UIGameplay TimeSpec - --- | Whether to show or hide robots on the world map. -uiShowRobots :: Getter UIGameplay Bool -uiShowRobots = to (\ui -> ui ^. uiTiming . lastFrameTime > ui ^. uiHideRobotsUntil) - --- | The currently active Scenario description, useful for starting over. -scenarioRef :: Lens' UIGameplay (Maybe ScenarioInfoPair) +import Swarm.Util.Lens (makeLensesNoSigs) -- * Toplevel UIState definition +-- | UI state independent of an actively-playing scenario. +-- Compare to 'UIGameplay', which contains UI state for an +-- active scenario. data UIState = UIState { _uiMenu :: Menu , _uiPlaying :: Bool - , _uiCheatMode :: Bool + , _uiDebugOptions :: Set DebugOption , _uiLaunchConfig :: LaunchOptions - , _uiAchievements :: Map CategorizedAchievement Attainment , _uiAttrMap :: AttrMap - , _uiGameplay :: UIGameplay - , _uiPopups :: PopupState } -- * Lenses for UIState @@ -301,24 +66,15 @@ -- display the current menu. uiPlaying :: Lens' UIState Bool --- | Cheat mode, i.e. are we allowed to turn creative mode on and off? -uiCheatMode :: Lens' UIState Bool +-- | Debugging features, for example are we allowed to turn creative mode on and off? +uiDebugOptions :: Lens' UIState (Set DebugOption) -- | Configuration modal when launching a scenario uiLaunchConfig :: Lens' UIState LaunchOptions --- | Map of achievements that were attained -uiAchievements :: Lens' UIState (Map CategorizedAchievement Attainment) - -- | Attribute map uiAttrMap :: Lens' UIState AttrMap --- | UI active during live gameplay -uiGameplay :: Lens' UIState UIGameplay - --- | Queue of popups to display -uiPopups :: Lens' UIState PopupState - -- * UIState initialization -- | The initial state of the focus ring. @@ -332,70 +88,30 @@ defaultInitLgTicksPerSecond :: Int defaultInitLgTicksPerSecond = 4 -- 2^4 = 16 ticks / second +data UIInitOptions = UIInitOptions + { speed :: Int + , showMainMenu :: Bool + , autoShowObjectives :: Bool + , debugOptions :: Set DebugOption + } + deriving (Eq, Show) + -- | Initialize the UI state. This needs to be in the IO monad since -- it involves reading a REPL history file, getting the current --- time, and loading text files from the data directory. The @Bool@ --- parameter indicates whether we should start off by showing the --- main menu. +-- time, and loading text files from the data directory. initUIState :: ( Has (Accum (Seq SystemFailure)) sig m , Has (Lift IO) sig m ) => - Int -> - Bool -> - Bool -> + UIInitOptions -> m UIState -initUIState speedFactor showMainMenu cheatMode = do - historyT <- sendIO $ readFileMayT =<< getSwarmHistoryPath False - let history = maybe [] (map mkREPLSubmission . T.lines) historyT - startTime <- sendIO $ getTime Monotonic - achievements <- loadAchievementsInfo +initUIState UIInitOptions {..} = do launchConfigPanel <- sendIO initConfigPanel - let out = - UIState - { _uiMenu = if showMainMenu then MainMenu (mainMenu NewGame) else NoMenu - , _uiPlaying = not showMainMenu - , _uiCheatMode = cheatMode - , _uiLaunchConfig = launchConfigPanel - , _uiAchievements = M.fromList $ map (view achievement &&& id) achievements - , _uiAttrMap = swarmAttrMap - , _uiPopups = initPopupState - , _uiGameplay = - UIGameplay - { _uiFocusRing = initFocusRing - , _uiWorldCursor = Nothing - , _uiWorldEditor = initialWorldEditor startTime - , _uiREPL = initREPLState $ newREPLHistory history - , _uiInventory = - UIInventory - { _uiInventoryList = Nothing - , _uiInventorySort = defaultSortOptions - , _uiInventorySearch = Nothing - , _uiShowZero = True - , _uiInventoryShouldUpdate = False - } - , _uiScrollToEnd = False - , _uiModal = Nothing - , _uiGoal = emptyGoalDisplay - , _uiStructure = emptyStructureDisplay - , _uiHideGoals = False - , _uiTiming = - UITiming - { _uiShowFPS = False - , _uiTPF = 0 - , _uiFPS = 0 - , _lgTicksPerSecond = speedFactor - , _lastFrameTime = startTime - , _accumulatedTime = 0 - , _lastInfoTime = 0 - , _tickCount = 0 - , _frameCount = 0 - , _frameTickCount = 0 - } - , _uiShowREPL = True - , _uiShowDebug = False - , _uiHideRobotsUntil = startTime - 1 - , _scenarioRef = Nothing - } - } - return out + return + UIState + { _uiMenu = if showMainMenu then MainMenu (mainMenu NewGame) else NoMenu + , _uiPlaying = not showMainMenu + , _uiDebugOptions = debugOptions + , _uiLaunchConfig = launchConfigPanel + , _uiAttrMap = swarmAttrMap + } diff --git a/src/swarm-tui/Swarm/TUI/Model/UI/Gameplay.hs b/src/swarm-tui/Swarm/TUI/Model/UI/Gameplay.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/UI/Gameplay.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sub-records utilized by 'Swarm.TUI.Model.UI' +-- This exists as a separate module to avoid import cycles. +module Swarm.TUI.Model.UI.Gameplay ( + UIGameplay (..), + UITiming (..), + UIInventory (..), + GoalDisplay (..), + UIDialogs (..), + uiTiming, + uiInventory, + uiFocusRing, + uiWorldCursor, + uiWorldEditor, + uiREPL, + uiInventoryList, + uiInventorySort, + uiInventorySearch, + uiScrollToEnd, + uiModal, + uiGoal, + uiStructure, + uiRobot, + uiDialogs, + uiIsAutoPlay, + uiAutoShowObjectives, + lgTicksPerSecond, + lastFrameTime, + accumulatedTime, + tickCount, + frameCount, + frameTickCount, + lastInfoTime, + uiShowFPS, + uiShowREPL, + uiShowZero, + uiShowDebug, + uiShowRobots, + uiHideRobotsUntil, + uiInventoryShouldUpdate, + uiTPF, + uiFPS, + scenarioRef, +) where + +import Brick.Focus +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (from, (<.>)) +import Data.Bits (FiniteBits (finiteBitSize)) +import Data.Text (Text) +import Swarm.Game.Scenario.Status (ScenarioPath) +import Swarm.Game.ScenarioInfo ( + ScenarioWith, + ) +import Swarm.Game.Universe +import Swarm.Game.World.Coords +import Swarm.TUI.Editor.Model +import Swarm.TUI.Inventory.Sorting +import Swarm.TUI.Model.Dialog.Goal +import Swarm.TUI.Model.Dialog.Structure +import Swarm.TUI.Model.Menu +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.Repl +import Swarm.TUI.View.Robot.Type +import Swarm.Util.Lens (makeLensesExcluding, makeLensesNoSigs) +import System.Clock + +data UITiming = UITiming + { _uiShowFPS :: Bool + , _uiTPF :: Double + , _uiFPS :: Double + , _lgTicksPerSecond :: Int + , _tickCount :: Int + , _frameCount :: Int + , _frameTickCount :: Int + , _lastFrameTime :: TimeSpec + , _accumulatedTime :: TimeSpec + , _lastInfoTime :: TimeSpec + } + +-- * Lenses for UITiming + +makeLensesExcluding ['_lgTicksPerSecond] ''UITiming + +-- | A toggle to show the FPS by pressing @f@ +uiShowFPS :: Lens' UITiming Bool + +-- | Computed ticks per milliseconds +uiTPF :: Lens' UITiming Double + +-- | Computed frames per milliseconds +uiFPS :: Lens' UITiming Double + +-- | 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' UITiming Int +lgTicksPerSecond = lens _lgTicksPerSecond safeSetLgTicks + where + maxLog = finiteBitSize (maxBound :: Int) + maxTicks = maxLog - 2 + minTicks = 2 - maxLog + safeSetLgTicks ui lTicks + | lTicks < minTicks = setLgTicks ui minTicks + | lTicks > maxTicks = setLgTicks ui maxTicks + | otherwise = setLgTicks ui lTicks + setLgTicks ui lTicks = ui {_lgTicksPerSecond = lTicks} + +-- | A counter used to track how many ticks have happened since the +-- last time we updated the ticks/frame statistics. +tickCount :: Lens' UITiming Int + +-- | A counter used to track how many frames have been rendered since the +-- last time we updated the ticks/frame statistics. +frameCount :: Lens' UITiming Int + +-- | A counter used to track how many ticks have happened in the +-- current frame, so we can stop when we get to the tick cap. +frameTickCount :: Lens' UITiming Int + +-- | The time of the last info widget update +lastInfoTime :: Lens' UITiming TimeSpec + +-- | The time of the last 'Swarm.TUI.Model.Frame' event. +lastFrameTime :: Lens' UITiming TimeSpec + +-- | The amount of accumulated real time. Every time we get a 'Swarm.TUI.Model.Frame' +-- event, we accumulate the amount of real time that happened since +-- the last frame, then attempt to take an appropriate number of +-- ticks to "catch up", based on the target tick rate. +-- +-- See https://gafferongames.com/post/fix_your_timestep/ . +accumulatedTime :: Lens' UITiming TimeSpec + +data UIInventory = UIInventory + { _uiInventoryList :: Maybe (Int, BL.List Name InventoryListEntry) + , _uiInventorySort :: InventorySortOptions + , _uiInventorySearch :: Maybe Text + , _uiShowZero :: Bool + , _uiInventoryShouldUpdate :: Bool + } + +-- * Lenses for UIInventory + +makeLensesNoSigs ''UIInventory + +-- | The order and direction of sorting inventory list. +uiInventorySort :: Lens' UIInventory InventorySortOptions + +-- | The current search string used to narrow the inventory view. +uiInventorySearch :: Lens' UIInventory (Maybe Text) + +-- | 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 +-- focused robot's inventory. +uiInventoryList :: Lens' UIInventory (Maybe (Int, BL.List Name InventoryListEntry)) + +-- | A toggle to show or hide inventory items with count 0 by pressing @0@ +uiShowZero :: Lens' UIInventory Bool + +-- | Whether the Inventory ui panel should update +uiInventoryShouldUpdate :: Lens' UIInventory Bool + +-- | State that backs various modal dialogs +data UIDialogs = UIDialogs + { _uiModal :: Maybe Modal + , _uiGoal :: GoalDisplay + , _uiStructure :: StructureDisplay + , _uiRobot :: RobotDisplay + } + +-- * Lenses for UIDialogs + +makeLensesNoSigs ''UIDialogs + +-- | When this is 'Just', it represents a modal to be displayed on +-- top of the UI, e.g. for the Help screen. +uiModal :: Lens' UIDialogs (Maybe Modal) + +-- | Status of the scenario goal: whether there is one, and whether it +-- has been displayed to the user initially. +uiGoal :: Lens' UIDialogs GoalDisplay + +-- | Definition and status of a recognizable structure +uiStructure :: Lens' UIDialogs StructureDisplay + +-- | Definition and status of a recognizable structure +uiRobot :: Lens' UIDialogs RobotDisplay + +-- | UI state specific to an actively-playing scenario. +-- Compare to 'UIState', which contains UI state independent of an +-- active scenario. +-- +-- For access to the fields, see the lenses below. +data UIGameplay = UIGameplay + { _uiFocusRing :: FocusRing Name + , _uiWorldCursor :: Maybe (Cosmic Coords) + , _uiWorldEditor :: WorldEditor Name + , _uiREPL :: REPLState + , _uiInventory :: UIInventory + , _uiScrollToEnd :: Bool + , _uiDialogs :: UIDialogs + , _uiIsAutoPlay :: Bool + , _uiAutoShowObjectives :: Bool + , _uiShowREPL :: Bool + , _uiShowDebug :: Bool + , _uiHideRobotsUntil :: TimeSpec + , _uiTiming :: UITiming + , _scenarioRef :: Maybe (ScenarioWith ScenarioPath) + } + +-- * Lenses for UIGameplay + +makeLensesNoSigs ''UIGameplay + +-- | Temporal information for gameplay UI +uiTiming :: Lens' UIGameplay UITiming + +-- | Inventory information for gameplay UI +uiInventory :: Lens' UIGameplay UIInventory + +-- | The focus ring is the set of UI panels we can cycle among using +-- the @Tab@ key. +uiFocusRing :: Lens' UIGameplay (FocusRing Name) + +-- | The last clicked position on the world view. +uiWorldCursor :: Lens' UIGameplay (Maybe (Cosmic Coords)) + +-- | State of all World Editor widgets +uiWorldEditor :: Lens' UIGameplay (WorldEditor Name) + +-- | The state of REPL panel. +uiREPL :: Lens' UIGameplay REPLState + +-- | A flag telling the UI to scroll the info panel to the very end +-- (used when a new log message is appended). +uiScrollToEnd :: Lens' UIGameplay Bool + +-- | State that backs various modal dialogs +uiDialogs :: Lens' UIGameplay UIDialogs + +-- | When running with @--autoplay@ the progress will not be saved. +uiIsAutoPlay :: Lens' UIGameplay Bool + +-- | Do not open objectives modals on objective completion. +uiAutoShowObjectives :: Lens' UIGameplay Bool + +-- | A toggle to expand or collapse the REPL by pressing @Ctrl-k@ +uiShowREPL :: Lens' UIGameplay Bool + +-- | A toggle to show CESK machine debug view and step through it. +-- +-- Note that the ability to use it can be enabled by player robot +-- gaining the capability, or being in creative mode or with +-- the debug option 'Swarm.TUI.Model.DebugOption.DebugCESK'. +uiShowDebug :: Lens' UIGameplay Bool + +-- | Hide robots on the world map. +uiHideRobotsUntil :: Lens' UIGameplay TimeSpec + +-- | Whether to show or hide robots on the world map. +uiShowRobots :: Getter UIGameplay Bool +uiShowRobots = to (\ui -> ui ^. uiTiming . lastFrameTime > ui ^. uiHideRobotsUntil) + +-- | The currently active Scenario description, useful for starting over. +scenarioRef :: Lens' UIGameplay (Maybe (ScenarioWith ScenarioPath)) diff --git a/src/swarm-tui/Swarm/TUI/Model/WebCommand.hs b/src/swarm-tui/Swarm/TUI/Model/WebCommand.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/WebCommand.hs @@ -0,0 +1,39 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- The type of commands sent from Web API handlers to the Controller, +-- and the type of replies. +module Swarm.TUI.Model.WebCommand ( + WebCommand (..), + WebInvocationState (..), + RejectionReason (..), +) where + +import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) +import Swarm.Util.JSON (optionsMinimize) + +data WebCommand = RunWebCode {webEntry :: Text, webReply :: WebInvocationState -> IO ()} + +data RejectionReason = NoActiveGame | AlreadyRunning | ParseError String + deriving (Eq, Ord, Show, Generic) + +data WebInvocationState = Rejected RejectionReason | InProgress | Complete String + deriving (Eq, Ord, Show, Generic) + +-- -------------------------- +-- ToJSON/FromJSON Instances +-- -------------------------- + +instance ToJSON RejectionReason where + toJSON = genericToJSON optionsMinimize + +instance FromJSON RejectionReason where + parseJSON = genericParseJSON optionsMinimize + +instance ToJSON WebInvocationState where + toJSON = genericToJSON optionsMinimize + +instance FromJSON WebInvocationState where + parseJSON = genericParseJSON optionsMinimize diff --git a/src/swarm-tui/Swarm/TUI/Panel.hs b/src/swarm-tui/Swarm/TUI/Panel.hs --- a/src/swarm-tui/Swarm/TUI/Panel.hs +++ b/src/swarm-tui/Swarm/TUI/Panel.hs @@ -18,6 +18,7 @@ import Brick.Widgets.Border import Control.Lens import Swarm.TUI.Border +import Swarm.Util (applyWhen) data Panel n = Panel {_panelName :: n, _panelLabels :: BorderLabels n, _panelContent :: Widget n} @@ -32,7 +33,7 @@ where drawPanel' :: Bool -> Panel n -> Widget n drawPanel' focused p = - (if focused then overrideAttr borderAttr attr else id) $ + applyWhen focused (overrideAttr borderAttr attr) $ borderWithLabels (p ^. panelLabels) (p ^. panelContent) -- | Create a panel. diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -17,13 +17,9 @@ drawModalMenu, drawKeyCmd, - -- * World - drawWorldPane, - -- * Robot panel drawRobotPanel, drawItem, - renderDutyCycle, -- * Info panel drawInfoPanel, @@ -36,6 +32,7 @@ import Brick hiding (Direction, Location) import Brick.Focus import Brick.Forms +import Brick.Keybindings (KeyConfig) import Brick.Widgets.Border ( hBorder, hBorderWithLabel, @@ -50,11 +47,9 @@ import Control.Lens as Lens hiding (Const, from) import Control.Monad (guard) import Data.Array (range) -import Data.Bits (shiftL, shiftR, (.&.)) import Data.Foldable (toList) import Data.Foldable qualified as F import Data.Functor (($>)) -import Data.IntMap qualified as IM import Data.List (intersperse) import Data.List qualified as L import Data.List.Extra (enumerate) @@ -65,16 +60,14 @@ import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, maybeToList) import Data.Semigroup (sconcat) import Data.Sequence qualified as Seq -import Data.Set qualified as Set (toList) +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Time (NominalDiffTime, defaultTimeLocale, formatTime) -import Linear import Network.Wai.Handler.Warp (Port) -import Numeric (showFFloat) import Swarm.Constant -import Swarm.Game.CESK (CESK (..)) -import Swarm.Game.Device (commandCost, commandsForDeviceCaps, enabledCommands, getMap, ingredients) +import Swarm.Game.Device (commandCost, commandsForDeviceCaps, enabledCommands, getCapabilitySet, getMap, ingredients) import Swarm.Game.Display import Swarm.Game.Entity as E import Swarm.Game.Ingredients @@ -82,7 +75,6 @@ import Swarm.Game.Location import Swarm.Game.Recipe import Swarm.Game.Robot -import Swarm.Game.Robot.Activity import Swarm.Game.Robot.Concrete import Swarm.Game.Scenario ( scenarioAuthor, @@ -103,26 +95,27 @@ import Swarm.Game.Scenario.Scoring.GenericMetrics import Swarm.Game.Scenario.Status import Swarm.Game.Scenario.Topography.Center -import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.ScenarioInfo ( ScenarioItem (..), + scenarioItemByPath, scenarioItemName, + _SISingle, ) import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Runtime import Swarm.Game.State.Substate -import Swarm.Game.Tick (TickNumber (..), addTicks) +import Swarm.Game.Tick (TickNumber (..), formatTicks) import Swarm.Game.Universe import Swarm.Game.World.Coords import Swarm.Game.World.Gen (Seed) import Swarm.Language.Capability (Capability (..), constCaps) -import Swarm.Language.Pretty (prettyText, prettyTextLine, prettyTextWidth) import Swarm.Language.Syntax import Swarm.Language.Typecheck (inferConst) import Swarm.Log +import Swarm.Pretty (prettyText, prettyTextLine, prettyTextWidth) import Swarm.TUI.Border import Swarm.TUI.Controller (ticksPerFrameCap) import Swarm.TUI.Controller.EventHandlers (allEventHandlers, mainEventHandlers, replEventHandlers, robotEventHandlers, worldEventHandlers) @@ -133,11 +126,14 @@ import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.View import Swarm.TUI.Model +import Swarm.TUI.Model.DebugOption (DebugOption (..)) +import Swarm.TUI.Model.Dialog.Goal (goalsContent, hasAnythingToShow) import Swarm.TUI.Model.Event qualified as SE -import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow) import Swarm.TUI.Model.KeyBindings (handlerNameKeysDescription) +import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import Swarm.TUI.Panel import Swarm.TUI.View.Achievement import Swarm.TUI.View.Attribute.Attr @@ -145,17 +141,18 @@ import Swarm.TUI.View.Logo import Swarm.TUI.View.Objective qualified as GR import Swarm.TUI.View.Popup +import Swarm.TUI.View.Robot import Swarm.TUI.View.Structure qualified as SR import Swarm.TUI.View.Util as VU import Swarm.Util -import Swarm.Util.UnitInterval -import Swarm.Util.WindowedCounter qualified as WC -import Swarm.Version (NewReleaseFailure (..)) -import System.Clock (TimeSpec (..)) import Text.Printf import Text.Wrap import Witch (into) +data KeyCmd + = SingleButton KeyHighlight Text Text + | MultiButton KeyHighlight [(Text, Text)] Text + -- | The main entry point for drawing the entire UI. drawUI :: AppState -> [Widget Name] drawUI s = drawPopups s : mainLayers @@ -170,7 +167,7 @@ -- quit the app instead. But just in case, we display the main menu anyway. NoMenu -> [drawMainMenuUI s (mainMenu NewGame)] MainMenu l -> [drawMainMenuUI s l] - NewGameMenu stk -> drawNewGameMenuUI stk $ s ^. uiState . uiLaunchConfig + NewGameMenu stk -> drawNewGameMenuUI s stk $ s ^. uiState . uiLaunchConfig AchievementsMenu l -> [drawAchievementsMenuUI s l] MessagesMenu -> [drawMainMessages s] AboutMenu -> [drawAboutMenuUI (s ^. runtimeState . appData . at "about")] @@ -195,21 +192,19 @@ logo = s ^. runtimeState . appData . at "logo" version = s ^. runtimeState . upstreamRelease -newVersionWidget :: Either NewReleaseFailure String -> Maybe (Widget n) +newVersionWidget :: Either (Severity, Text) String -> Maybe (Widget n) newVersionWidget = \case Right ver -> Just . txt $ "New version " <> T.pack ver <> " is available!" - Left (OnDevelopmentBranch _b) -> Just . txt $ "Good luck developing!" - Left (FailedReleaseQuery _f) -> Nothing - Left (NoMainUpstreamRelease _fails) -> Nothing - Left (OldUpstreamRelease _up _my) -> Nothing + Left _ -> Nothing -- | When launching a game, a modal prompt may appear on another layer -- to input seed and/or a script to run. drawNewGameMenuUI :: - NonEmpty (BL.List Name ScenarioItem) -> + AppState -> + NonEmpty (BL.List Name (ScenarioItem ScenarioPath)) -> LaunchOptions -> [Widget Name] -drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of +drawNewGameMenuUI appState (l :| ls) launchOptions = case displayedFor of Nothing -> pure mainWidget Just _ -> drawLaunchConfigPanel launchOptions <> pure mainWidget where @@ -239,38 +234,50 @@ (Nothing, Just (SISingle _)) -> hCenter $ txt "Press 'o' for launch options, or 'Enter' to launch with defaults" _ -> txt " " - drawScenarioItem (SISingle (s, si)) = padRight (Pad 1) (drawStatusInfo s si) <+> txt (s ^. scenarioMetadata . scenarioName) + drawScenarioItem (SISingle (ScenarioWith s (ScenarioPath sPath))) = padRight (Pad 1) (drawStatusInfo s sPath) <+> txt (s ^. scenarioMetadata . scenarioName) drawScenarioItem (SICollection nm _) = padRight (Pad 1) (withAttr boldAttr $ txt " > ") <+> txt nm - drawStatusInfo s si = case si ^. scenarioStatus of - NotStarted -> txt " ○ " - Played _initialScript (Metric Attempted _) _ -> case s ^. scenarioOperation . scenarioObjectives of - [] -> withAttr cyanAttr $ txt " ◉ " - _ -> withAttr yellowAttr $ txt " ◎ " - Played _initialScript (Metric Completed _) _ -> withAttr greenAttr $ txt " ● " + drawStatusInfo s sPath = case currentScenarioInfo of + Nothing -> emptyWidget + Just si -> case si ^. scenarioStatus of + NotStarted -> txt " ○ " + Played _script _latestMetric best | isCompleted best -> withAttr greenAttr $ txt " ● " + Played {} -> case s ^. scenarioOperation . scenarioObjectives of + [] -> withAttr cyanAttr $ txt " ◉ " + _ -> withAttr yellowAttr $ txt " ◎ " + where + currentScenarioInfo = appState ^? playState . progression . scenarios . scenarioItemByPath sPath . _SISingle . getScenarioInfo + + isCompleted :: BestRecords -> Bool + isCompleted best = best ^. scenarioBestByTime . metricProgress == Completed + describeStatus :: ScenarioStatus -> Widget n describeStatus = \case NotStarted -> withAttr cyanAttr $ txt "not started" Played _initialScript pm _best -> describeProgress pm - breadcrumbs :: [BL.List Name ScenarioItem] -> Text + breadcrumbs :: [BL.List Name (ScenarioItem ScenarioPath)] -> Text breadcrumbs = T.intercalate " > " . ("Scenarios" :) . reverse . mapMaybe (fmap (scenarioItemName . snd) . BL.listSelectedElement) - drawDescription :: ScenarioItem -> Widget Name + drawDescription :: ScenarioItem ScenarioPath -> Widget Name drawDescription (SICollection _ _) = txtWrap " " - drawDescription (SISingle (s, si)) = + drawDescription (SISingle (ScenarioWith s (ScenarioPath sPath))) = vBox [ drawMarkdown (nonBlank (s ^. scenarioOperation . scenarioDescription)) - , hCenter . padTop (Pad 1) . vLimit 6 $ hLimitPercent 60 worldPeek + , cached (ScenarioPreview sPath) $ + hCenter . padTop (Pad 1) . vLimit 6 $ + hLimitPercent 60 worldPeek , padTop (Pad 1) table ] where vc = determineStaticViewCenter (s ^. scenarioLandscape) worldTuples + currentScenarioInfo = appState ^? playState . progression . scenarios . scenarioItemByPath sPath . _SISingle . getScenarioInfo + worldTuples = buildWorldTuples $ s ^. scenarioLandscape theWorlds = genMultiWorld worldTuples $ @@ -297,15 +304,17 @@ ) secondRow = ( txt "last:" - , Just $ describeStatus $ si ^. scenarioStatus + , stat ) + where + stat = describeStatus . view scenarioStatus <$> currentScenarioInfo padTopLeft = padTop (Pad 1) . padLeft (Pad 1) tableRows = map (map padTopLeft . pairToList) $ mapMaybe sequenceA $ - firstRow : secondRow : makeBestScoreRows (si ^. scenarioStatus) + firstRow : secondRow : maybe [] (makeBestScoreRows . view scenarioStatus) currentScenarioInfo table = BT.renderTable . BT.surroundingBorder False @@ -332,7 +341,7 @@ Completed -> withAttr greenAttr . vBox $ [ txt $ T.unwords ["completed in", formatTimeDiff e] - , txt . (" " <>) . parens $ T.unwords [T.pack $ drawTime t True, "ticks"] + , txt . (" " <>) . parens $ T.unwords [T.pack $ formatTicks True t, "ticks"] ] <> maybeToList (sizeDisplay <$> maybeCodeMetrics) where @@ -388,7 +397,7 @@ , Just $ describeProgress b ) where - maxLeftColumnWidth = maximum (map (T.length . describeCriteria) enumerate) + maxLeftColumnWidth = maximum0 (map (T.length . describeCriteria) enumerate) mkCriteriaRow = withAttr dimAttr . padLeft Max @@ -417,9 +426,8 @@ Quit -> txt "Quit" where highlightMessages = - if s ^. runtimeState . eventLog . notificationsCount > 0 - then withAttr notifAttr - else id + applyWhen (s ^. runtimeState . eventLog . notificationsCount > 0) $ + withAttr notifAttr drawAboutMenuUI :: Maybe Text -> Widget Name drawAboutMenuUI Nothing = centerLayer $ txt "About swarm!" @@ -434,7 +442,7 @@ -- main layer and a layer for a floating dialog that can be on top. drawGameUI :: AppState -> [Widget Name] drawGameUI s = - [ joinBorders $ drawDialog s + [ joinBorders $ drawDialog h isNoMenu ps , joinBorders $ hBox [ hLimitPercent 25 $ @@ -448,35 +456,51 @@ & bottomLabels . centerLabel .~ fmap (txt . (" Search: " <>) . (<> " ")) - (s ^. uiState . uiGameplay . uiInventory . uiInventorySearch) + (uig ^. uiInventory . uiInventorySearch) ) - $ drawRobotPanel s + $ drawRobotPanel ps , panel highlightAttr fr (FocusablePanel InfoPanel) plainBorder - $ drawInfoPanel s + $ drawInfoPanel ps , hCenter . clickable (FocusablePanel WorldEditorPanel) . EV.drawWorldEditor fr - $ s ^. uiState + $ uig ] , vBox rightPanel ] ] where + debugOpts = s ^. uiState . uiDebugOptions + keyConf = s ^. keyEventHandling . keyConfig + ps = s ^. playState . scenarioState + gs = ps ^. gameState + uig = ps ^. uiGameplay + + h = + ToplevelConfigurationHelp + (s ^. runtimeState . webPort) + keyConf + + isNoMenu = case s ^. uiState . uiMenu of + NoMenu -> True + _ -> False + addCursorPos = bottomLabels . leftLabel ?~ padLeftRight 1 widg where - widg = case s ^. uiState . uiGameplay . uiWorldCursor of - Nothing -> str $ renderCoordsString $ s ^. gameState . robotInfo . viewCenter - Just coord -> clickable WorldPositionIndicator $ drawWorldCursorInfo (s ^. uiState . uiGameplay . uiWorldEditor . worldOverdraw) (s ^. gameState) coord + widg = case uig ^. uiWorldCursor of + Nothing -> str $ renderCoordsString $ gs ^. robotInfo . viewCenter + Just coord -> clickable WorldPositionIndicator $ drawWorldCursorInfo (uig ^. uiWorldEditor . worldOverdraw) gs coord -- Add clock display in top right of the world view if focused robot -- has a clock equipped - addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay (s ^. uiState . uiGameplay . uiTiming . lgTicksPerSecond) $ s ^. gameState) - fr = s ^. uiState . uiGameplay . uiFocusRing - showREPL = s ^. uiState . uiGameplay . uiShowREPL - rightPanel = if showREPL then worldPanel ++ replPanel else worldPanel ++ minimizedREPL + addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay (uig ^. uiTiming . lgTicksPerSecond) gs) + fr = uig ^. uiFocusRing + showREPL = uig ^. uiShowREPL + rightPanelBottom = if showREPL then replPanel else minimizedREPL + rightPanel = worldPanel ++ rightPanelBottom minimizedREPL = case focusGetCurrent fr of (Just (FocusablePanel REPLPanel)) -> [separateBorders $ clickable (FocusablePanel REPLPanel) (forceAttr highlightAttr hBorder)] _ -> [separateBorders $ clickable (FocusablePanel REPLPanel) hBorder] @@ -486,13 +510,13 @@ fr (FocusablePanel WorldPanel) ( plainBorder - & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s) - & topLabels . leftLabel ?~ drawModalMenu s + & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS $ uig ^. uiTiming) + & topLabels . leftLabel ?~ drawModalMenu gs keyConf & addCursorPos & addClock ) - (drawWorldPane (s ^. uiState . uiGameplay) (s ^. gameState)) - , drawKeyMenu s + (drawWorldPane uig gs) + , drawKeyMenu ps keyConf debugOpts ] replPanel = [ clickable (FocusablePanel REPLPanel) $ @@ -501,23 +525,15 @@ fr (FocusablePanel REPLPanel) ( plainBorder - & topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiGameplay . uiREPL . replType)) + & topLabels . rightLabel .~ (drawType <$> (uig ^. uiREPL . replType)) ) ( vLimit replHeight . padBottom Max . padLeft (Pad 1) - $ drawREPL s + $ drawREPL ps ) ] -renderCoordsString :: Cosmic Location -> String -renderCoordsString (Cosmic sw coords) = - unwords $ VU.locationToString coords : suffix - where - suffix = case sw of - DefaultRootSubworld -> [] - SubworldName swName -> ["in", T.unpack swName] - drawWorldCursorInfo :: WorldOverdraw -> GameState -> Cosmic Coords -> Widget Name drawWorldCursorInfo worldEditor g cCoords = case getStatic g coords of @@ -527,7 +543,7 @@ Cosmic _ coords = cCoords coordsWidget = str $ renderCoordsString $ fmap coordsToLoc cCoords - tileMembers = terrain : mapMaybe merge [entity, robot] + tileMembers = terrain : mapMaybe merge [entity, r] tileMemberWidgets = map (padRight $ Pad 1) . concat @@ -545,7 +561,7 @@ terrain = displayTerrainCell worldEditor ri cCoords entity = displayEntityCell worldEditor ri cCoords - robot = displayRobotCell g cCoords + r = displayRobotCell g cCoords merge = fmap sconcat . NE.nonEmpty . filter (not . (^. invisible)) @@ -557,26 +573,12 @@ clockWidget = maybeDrawTime (gs ^. temporal . ticks) (gs ^. temporal . paused || lgTPS < 3) gs pauseWidget = guard (gs ^. temporal . paused) $> txt "(PAUSED)" --- | Check whether the currently focused robot (if any) has a clock --- device equipped. +-- | Check whether the currently focused robot (if any) has some kind +-- of a clock device equipped. clockEquipped :: GameState -> Bool clockEquipped gs = case focusedRobot gs of Nothing -> False - Just r - | countByName "clock" (r ^. equippedDevices) > 0 -> True - | otherwise -> False - --- | Format a ticks count as a hexadecimal clock. -drawTime :: TickNumber -> Bool -> String -drawTime (TickNumber t) showTicks = - mconcat $ - intersperse - ":" - [ printf "%x" (t `shiftR` 20) - , printf "%02x" ((t `shiftR` 12) .&. ((1 `shiftL` 8) - 1)) - , printf "%02x" ((t `shiftR` 4) .&. ((1 `shiftL` 8) - 1)) - ] - ++ if showTicks then [".", printf "%x" (t .&. ((1 `shiftL` 4) - 1))] else [] + Just r -> CExecute Time `Set.member` getCapabilitySet (r ^. robotCapabilities) -- | Return a possible time display, if the currently focused robot -- has a clock device equipped. The first argument is the number @@ -584,29 +586,29 @@ -- whether the time should be shown down to single-tick resolution -- (e.g. 0:00:3a.f) or not (e.g. 0:00:3a). maybeDrawTime :: TickNumber -> Bool -> GameState -> Maybe (Widget n) -maybeDrawTime t showTicks gs = guard (clockEquipped gs) $> str (drawTime t showTicks) +maybeDrawTime t showTicks gs = guard (clockEquipped gs) $> str (formatTicks showTicks t) -- | Draw info about the current number of ticks per second. -drawTPS :: AppState -> Widget Name -drawTPS s = hBox (tpsInfo : rateInfo) +drawTPS :: UITiming -> Widget Name +drawTPS timing = hBox (tpsInfo : rateInfo) where tpsInfo | l >= 0 = hBox [str (show n), txt " ", txt (number n "tick"), txt " / s"] | otherwise = hBox [txt "1 tick / ", str (show n), txt " s"] rateInfo - | s ^. uiState . uiGameplay . uiTiming . uiShowFPS = + | timing ^. uiShowFPS = [ txt " (" - , let tpf = s ^. uiState . uiGameplay . uiTiming . uiTPF - in (if tpf >= fromIntegral ticksPerFrameCap then withAttr redAttr else id) - (str (printf "%0.1f" tpf)) + , let tpf = timing ^. uiTPF + in applyWhen (tpf >= fromIntegral ticksPerFrameCap) (withAttr redAttr) $ + str (printf "%0.1f" tpf) , txt " tpf, " - , str (printf "%0.1f" (s ^. uiState . uiGameplay . uiTiming . uiFPS)) + , str (printf "%0.1f" (timing ^. uiFPS)) , txt " fps)" ] | otherwise = [] - l = s ^. uiState . uiGameplay . uiTiming . lgTicksPerSecond + l = timing ^. lgTicksPerSecond n = 2 ^ abs l -- | The height of the REPL box. Perhaps in the future this should be @@ -616,183 +618,88 @@ -- | Hide the cursor when a modal is set chooseCursor :: AppState -> [CursorLocation n] -> Maybe (CursorLocation n) -chooseCursor s locs = case s ^. uiState . uiGameplay . uiModal of - Nothing -> showFirstCursor s locs - Just _ -> Nothing - --- | Draw a dialog window, if one should be displayed right now. -drawDialog :: AppState -> Widget Name -drawDialog s = case s ^. uiState . uiGameplay . uiModal of - Just (Modal mt d) -> renderDialog d $ case mt of - GoalModal -> drawModal s mt - _ -> maybeScroll ModalViewport $ drawModal s mt - Nothing -> emptyWidget - --- | Draw one of the various types of modal dialog. -drawModal :: AppState -> ModalType -> Widget Name -drawModal s = \case - HelpModal -> helpWidget (s ^. gameState . randomness . seed) (s ^. runtimeState . webPort) (s ^. keyEventHandling) - RobotsModal -> robotsListWidget s - RecipesModal -> availableListWidget (s ^. gameState) RecipeList - CommandsModal -> commandsListWidget (s ^. gameState) - MessagesModal -> availableListWidget (s ^. gameState) MessageList - StructuresModal -> SR.renderStructuresDisplay (s ^. gameState) (s ^. uiState . uiGameplay . uiStructure) - ScenarioEndModal outcome -> - padBottom (Pad 1) $ - vBox $ - map - (hCenter . txt) - content - where - content = case outcome of - WinModal -> ["Congratulations!"] - LoseModal -> - [ "Condolences!" - , "This scenario is no longer winnable." - ] - DescriptionModal e -> descriptionWidget s e - QuitModal -> padBottom (Pad 1) $ hCenter $ txt (quitMsg (s ^. uiState . uiMenu)) - GoalModal -> - GR.renderGoalsDisplay (s ^. uiState . uiGameplay . uiGoal) $ - view (scenarioOperation . scenarioDescription) . fst <$> s ^. uiState . uiGameplay . scenarioRef - KeepPlayingModal -> - padLeftRight 1 $ - displayParagraphs $ - pure - "Have fun! Hit Ctrl-Q whenever you're ready to proceed to the next challenge or return to the menu." - TerrainPaletteModal -> EV.drawTerrainSelector s - EntityPaletteModal -> EV.drawEntityPaintSelector s - --- | Render the percentage of ticks that this robot was active. --- This indicator can take some time to "warm up" and stabilize --- due to the sliding window. --- --- == Use of previous tick --- The 'Swarm.Game.Step.gameTick' function runs all robots, then increments the current tick. --- So at the time we are rendering a frame, the current tick will always be --- strictly greater than any ticks stored in the 'WC.WindowedCounter' for any robot; --- hence 'WC.getOccupancy' will never be @1@ if we use the current tick directly as --- obtained from the 'ticks' function. --- So we "rewind" it to the previous tick for the purpose of this display. -renderDutyCycle :: GameState -> Robot -> Widget Name -renderDutyCycle gs robot = - withAttr dutyCycleAttr . str . flip (showFFloat (Just 1)) "%" $ dutyCyclePercentage +chooseCursor s locs = do + guard $ null m + showFirstCursor s locs where - curTicks = gs ^. temporal . ticks - window = robot ^. activityCounts . activityWindow - - -- Rewind to previous tick - latestRobotTick = addTicks (-1) curTicks - dutyCycleRatio = WC.getOccupancy latestRobotTick window - - dutyCycleAttr = safeIndex dutyCycleRatio meterAttributeNames - - dutyCyclePercentage :: Double - dutyCyclePercentage = 100 * getValue dutyCycleRatio + m = s ^. playState . scenarioState . uiGameplay . uiDialogs . uiModal -robotsListWidget :: AppState -> Widget Name -robotsListWidget s = hCenter table +-- | Draw a dialog window, if one should be displayed right now. +drawDialog :: + ToplevelConfigurationHelp -> + Bool -> + ScenarioState -> + Widget Name +drawDialog h isNoMenu ps = + maybe emptyWidget go m where - table = - BT.renderTable - . BT.columnBorders False - . BT.setDefaultColAlignment BT.AlignCenter - -- Inventory count is right aligned - . BT.alignRight 4 - . BT.table - $ map (padLeftRight 1) <$> (headers : robotsTable) - headings = - [ "Name" - , "Age" - , "Pos" - , "Items" - , "Status" - , "Actns" - , "Cmds" - , "Cycles" - , "Activity" - , "Log" - ] - headers = withAttr robotAttr . txt <$> applyWhen cheat ("ID" :) headings - robotsTable = mkRobotRow <$> robots - mkRobotRow robot = - applyWhen cheat (idWidget :) cells + m = ps ^. uiGameplay . uiDialogs . uiModal + go (Modal mt d) = renderDialog d $ case mt of + MidScenarioModal GoalModal -> draw + MidScenarioModal RobotsModal -> draw + _ -> maybeScroll ModalViewport draw where - cells = - [ nameWidget - , str ageStr - , locWidget - , padRight (Pad 1) (str $ show rInvCount) - , statusWidget - , str $ show $ robot ^. activityCounts . tangibleCommandCount - , -- TODO(#1341): May want to expose the details of this histogram in - -- a per-robot pop-up - str . show . sum . M.elems $ robot ^. activityCounts . commandsHistogram - , str $ show $ robot ^. activityCounts . lifetimeStepCount - , renderDutyCycle (s ^. gameState) robot - , txt rLog - ] - - idWidget = str $ show $ robot ^. robotID - nameWidget = - hBox - [ renderDisplay (robot ^. robotDisplay) - , highlightSystem . txt $ " " <> robot ^. robotName - ] - - highlightSystem = if robot ^. systemRobot then withAttr highlightAttr else id - - ageStr - | age < 60 = show age <> "sec" - | age < 3600 = show (age `div` 60) <> "min" - | age < 3600 * 24 = show (age `div` 3600) <> "hour" - | otherwise = show (age `div` 3600 * 24) <> "day" - where - TimeSpec createdAtSec _ = robot ^. robotCreatedAt - TimeSpec nowSec _ = s ^. uiState . uiGameplay . uiTiming . lastFrameTime - age = nowSec - createdAtSec - - rInvCount = sum $ map fst . E.elems $ robot ^. robotEntity . entityInventory - rLog - | robot ^. robotLogUpdated = "x" - | otherwise = " " + draw = drawModal h ps isNoMenu mt - locWidget = hBox [worldCell, str $ " " <> locStr] +-- | Draw one of the various types of modal dialog. +drawModal :: + ToplevelConfigurationHelp -> + ScenarioState -> + Bool -> + ModalType -> + Widget Name +drawModal h ps isNoMenu = \case + MidScenarioModal x -> case x of + HelpModal -> helpWidget h $ gs ^. randomness . seed + RobotsModal -> drawRobotsDisplayModal uig gs $ uig ^. uiDialogs . uiRobot + RecipesModal -> availableListWidget gs RecipeList + CommandsModal -> commandsListWidget gs + MessagesModal -> availableListWidget gs MessageList + StructuresModal -> SR.renderStructuresDisplay gs $ uig ^. uiDialogs . uiStructure + DescriptionModal e -> descriptionWidget ps e + GoalModal -> + GR.renderGoalsDisplay (uig ^. uiDialogs . uiGoal) $ + view (getScenario . scenarioOperation . scenarioDescription) <$> uig ^. scenarioRef + TerrainPaletteModal -> EV.drawTerrainSelector uig + EntityPaletteModal -> EV.drawEntityPaintSelector uig + EndScenarioModal x -> case x of + ScenarioFinishModal outcome -> + padBottom (Pad 1) $ + vBox $ + map + (hCenter . txt) + content where - rCoords = fmap locToCoords rLoc - rLoc = robot ^. robotLocation - worldCell = - drawLoc - (s ^. uiState . uiGameplay) - g - rCoords - locStr = renderCoordsString rLoc - - statusWidget = case robot ^. machine of - Waiting {} -> txt "waiting" - _ - | isActive robot -> withAttr notifAttr $ txt "busy" - | otherwise -> withAttr greenAttr $ txt "idle" + content = case outcome of + WinModal -> ["Congratulations!"] + LoseModal -> + [ "Condolences!" + , "This scenario is no longer winnable." + ] + QuitModal -> padBottom (Pad 1) $ hCenter $ txt (quitMsg isNoMenu) + KeepPlayingModal -> + padLeftRight 1 $ + displayParagraphs $ + pure + "Have fun! Hit Ctrl-Q whenever you're ready to proceed to the next challenge or return to the menu." + where + gs = ps ^. gameState + uig = ps ^. uiGameplay - basePos :: Point V2 Double - basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation . planar) - -- Keep the base and non system 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 - isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation . planar) basePos < 32 - robots :: [Robot] - robots = - filter (\robot -> debugging || (isRelevant robot && isNear robot)) - . IM.elems - $ g ^. robotInfo . robotMap - creative = g ^. creativeMode - cheat = s ^. uiState . uiCheatMode - debugging = creative && cheat - g = s ^. gameState +data ToplevelConfigurationHelp = ToplevelConfigurationHelp + { _helpPort :: Maybe Port + , _helpKeyConf :: KeyConfig SE.SwarmEvent + } -helpWidget :: Seed -> Maybe Port -> KeyEventHandlingState -> Widget Name -helpWidget theSeed mport keyState = - padLeftRight 2 . vBox $ padTop (Pad 1) <$> [info, helpKeys, tips] +helpWidget :: ToplevelConfigurationHelp -> Seed -> Widget Name +helpWidget (ToplevelConfigurationHelp mport keyConf) theSeed = + padLeftRight 2 . vBox $ + padTop (Pad 1) + <$> [ info + , colorizationLegend + , helpKeys + , tips + ] where tips = vBox @@ -806,6 +713,12 @@ , txt ("Seed: " <> into @Text (show theSeed)) , txt ("Web server port: " <> maybe "none" (into @Text . show) mport) ] + colorizationLegend = + vBox + [ heading boldAttr "Colorization legend" + , drawMarkdown + "In text, snippets of code like `3 + 4` or `scan down` will be colorized. Types like `Cmd Text`{=type} have a dedicated color. The names of an `entity`{=entity}, a `structure`{=structure}, and a `tag`{=tag} also each have their own color." + ] helpKeys = vBox [ heading boldAttr "Keybindings" @@ -832,10 +745,10 @@ , padLeftRight 1 $ txtFilled maxK k , padLeft (Pad 1) $ txtFilled maxD d ] - keyHandlerToText = handlerNameKeysDescription (keyState ^. keyConfig) + keyHandlerToText = handlerNameKeysDescription keyConf -- Get maximum width of the table columns so it all neatly aligns txtFilled n t = padRight (Pad $ max 0 (n - textWidth t)) $ txt t - (maxN, maxK, maxD) = map3 (maximum . map textWidth) . unzip3 $ keyHandlerToText <$> allEventHandlers + (maxN, maxK, maxD) = map3 (maximum0 . map textWidth) . unzip3 $ keyHandlerToText <$> allEventHandlers map3 f (n, k, d) = (f n, f k, f d) data NotificationList = RecipeList | MessageList @@ -912,15 +825,18 @@ constCaps cmd -- | Generate a pop-up widget to display the description of an entity. -descriptionWidget :: AppState -> Entity -> Widget Name -descriptionWidget s e = padLeftRight 1 (explainEntry s e) +descriptionWidget :: ScenarioState -> Entity -> Widget Name +descriptionWidget s e = padLeftRight 1 (explainEntry uig gs e) + where + gs = s ^. gameState + uig = s ^. uiGameplay -- | Draw a widget with messages to the current robot. messagesWidget :: GameState -> [Widget Name] messagesWidget gs = widgetList where widgetList = focusNewest . map drawLogEntry' $ gs ^. messageNotifications . notificationsContent - focusNewest = if gs ^. temporal . paused then id else over _last visible + focusNewest = applyWhen (not $ gs ^. temporal . paused) $ over _last visible drawLogEntry' e = withAttr (colorLogs e) $ hBox @@ -951,42 +867,46 @@ Critical -> redAttr -- | Draw the F-key modal menu. This is displayed in the top left world corner. -drawModalMenu :: AppState -> Widget Name -drawModalMenu s = vLimit 1 . hBox $ map (padLeftRight 1 . drawKeyCmd) globalKeyCmds +drawModalMenu :: GameState -> KeyConfig SE.SwarmEvent -> Widget Name +drawModalMenu gs keyConf = vLimit 1 . hBox $ map (padLeftRight 1 . drawKeyCmd) globalKeyCmds where - notificationKey :: Getter GameState (Notifications a) -> SE.MainEvent -> Text -> Maybe (KeyHighlight, Text, Text) + notificationKey :: Getter GameState (Notifications a) -> SE.MainEvent -> Text -> Maybe KeyCmd notificationKey notifLens key name - | null (s ^. gameState . notifLens . notificationsContent) = Nothing + | null (gs ^. notifLens . notificationsContent) = Nothing | otherwise = let highlight - | s ^. gameState . notifLens . notificationsCount > 0 = Alert + | gs ^. notifLens . notificationsCount > 0 = Alert | otherwise = NoHighlight - in Just (highlight, keyM key, name) + in Just (SingleButton highlight (keyM key) name) -- Hides this key if the recognizable structure list is empty structuresKey = - if null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions + if null $ gs ^. landscape . recognizerAutomatons . originalStructureDefinitions then Nothing - else Just (NoHighlight, keyM SE.ViewStructuresEvent, "Structures") + else Just (SingleButton NoHighlight (keyM SE.ViewStructuresEvent) "Structures") globalKeyCmds = catMaybes - [ Just (NoHighlight, keyM SE.ViewHelpEvent, "Help") - , Just (NoHighlight, keyM SE.ViewRobotsEvent, "Robots") + [ Just (SingleButton NoHighlight (keyM SE.ViewHelpEvent) "Help") + , Just (SingleButton NoHighlight (keyM SE.ViewRobotsEvent) "Robots") , notificationKey (discovery . availableRecipes) SE.ViewRecipesEvent "Recipes" , notificationKey (discovery . availableCommands) SE.ViewCommandsEvent "Commands" , notificationKey messageNotifications SE.ViewMessagesEvent "Messages" , structuresKey ] - keyM = VU.bindingText s . SE.Main + keyM = VU.bindingText keyConf . SE.Main -- | Draw a menu explaining what key commands are available for the -- current panel. This menu is displayed as one or two lines in -- between the world panel and the REPL. -- -- This excludes the F-key modals that are shown elsewhere. -drawKeyMenu :: AppState -> Widget Name -drawKeyMenu s = +drawKeyMenu :: + ScenarioState -> + KeyConfig SE.SwarmEvent -> + Set DebugOption -> + Widget Name +drawKeyMenu ps keyConf debugOpts = vLimit 2 $ hBox [ padBottom Max $ @@ -1000,29 +920,32 @@ mkCmdRow = hBox . map drawPaddedCmd drawPaddedCmd = padLeftRight 1 . drawKeyCmd contextCmds - | ctrlMode == Handling = txt $ fromMaybe "" (s ^? gameState . gameControls . inputHandler . _Just . _1) + | ctrlMode == Handling = txt $ fromMaybe "" (gs ^? gameControls . inputHandler . _Just . _1) | otherwise = mkCmdRow focusedPanelCmds focusedPanelCmds = map highlightKeyCmds . keyCmdsFor . focusGetCurrent - . view (uiState . uiGameplay . uiFocusRing) - $ s + . view uiFocusRing + $ uig - isReplWorking = s ^. gameState . gameControls . replWorking - isPaused = s ^. gameState . temporal . paused - hasDebug = hasDebugCapability creative s - viewingBase = (s ^. gameState . robotInfo . viewCenterRule) == VCRobot 0 - creative = s ^. gameState . creativeMode - cheat = s ^. uiState . uiCheatMode - goal = hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent - showZero = s ^. uiState . uiGameplay . uiInventory . uiShowZero - inventorySort = s ^. uiState . uiGameplay . uiInventory . uiInventorySort - inventorySearch = s ^. uiState . uiGameplay . uiInventory . uiInventorySearch - ctrlMode = s ^. uiState . uiGameplay . uiREPL . replControlMode - canScroll = creative || (s ^. gameState . landscape . worldScrollable) - handlerInstalled = isJust (s ^. gameState . gameControls . inputHandler) + uig = ps ^. uiGameplay + gs = ps ^. gameState + isReplWorking = gs ^. gameControls . replWorking + isPaused = gs ^. temporal . paused + hasDebug = hasDebugCapability creative gs + creative = gs ^. creativeMode + showCreative = debugOpts ^. Lens.contains ToggleCreative + showEditor = debugOpts ^. Lens.contains ToggleWorldEditor + goal = hasAnythingToShow $ uig ^. uiDialogs . uiGoal . goalsContent + showZero = uig ^. uiInventory . uiShowZero + inventorySort = uig ^. uiInventory . uiInventorySort + inventorySearch = uig ^. uiInventory . uiInventorySearch + ctrlMode = uig ^. uiREPL . replControlMode + canScroll = creative || (gs ^. landscape . worldScrollable) + handlerInstalled = isJust (gs ^. gameControls . inputHandler) + renderPilotModeSwitch :: ReplControlMode -> T.Text renderPilotModeSwitch = \case Piloting -> "REPL" @@ -1041,34 +964,39 @@ $ case creative of False -> "Classic" True -> "Creative" + + globalKeyCmds :: [KeyCmd] globalKeyCmds = catMaybes - [ may goal (NoHighlight, keyM SE.ViewGoalEvent, "goal") - , may cheat (NoHighlight, keyM SE.ToggleCreativeModeEvent, "creative") - , may cheat (NoHighlight, keyM SE.ToggleWorldEditorEvent, "editor") - , Just (NoHighlight, keyM SE.PauseEvent, if isPaused then "unpause" else "pause") - , may isPaused (NoHighlight, keyM SE.RunSingleTickEvent, "step") + [ may goal (SingleButton NoHighlight (keyM SE.ViewGoalEvent) "goal") + , may showCreative (SingleButton NoHighlight (keyM SE.ToggleCreativeModeEvent) "creative") + , may showEditor (SingleButton NoHighlight (keyM SE.ToggleWorldEditorEvent) "editor") + , Just (SingleButton NoHighlight (keyM SE.PauseEvent) (if isPaused then "unpause" else "pause")) + , may isPaused (SingleButton NoHighlight (keyM SE.RunSingleTickEvent) "step") , may (isPaused && hasDebug) - ( if s ^. uiState . uiGameplay . uiShowDebug then Alert else NoHighlight - , keyM SE.ShowCESKDebugEvent - , "debug" + ( SingleButton + (if uig ^. uiShowDebug then Alert else NoHighlight) + (keyM SE.ShowCESKDebugEvent) + "debug" ) - , Just (NoHighlight, keyM SE.IncreaseTpsEvent <> "/" <> keyM SE.DecreaseTpsEvent, "speed") + , Just (MultiButton NoHighlight [(keyM SE.IncreaseTpsEvent, "speed-up"), (keyM SE.DecreaseTpsEvent, "speed-down")] "speed") , Just - ( NoHighlight - , keyM SE.ToggleREPLVisibilityEvent - , if s ^. uiState . uiGameplay . uiShowREPL then "hide REPL" else "show REPL" + ( SingleButton + NoHighlight + (keyM SE.ToggleREPLVisibilityEvent) + (if uig ^. uiShowREPL then "hide REPL" else "show REPL") ) , Just - ( if s ^. uiState . uiGameplay . uiShowRobots then NoHighlight else Alert - , keyM SE.HideRobotsEvent - , "hide robots" + ( SingleButton + (if uig ^. uiShowRobots then NoHighlight else Alert) + (keyM SE.HideRobotsEvent) + "hide robots" ) ] may b = if b then Just else const Nothing - highlightKeyCmds (k, n) = (PanelSpecific, k, n) + highlightKeyCmds (k, n) = SingleButton PanelSpecific k n keyCmdsFor (Just (FocusablePanel WorldEditorPanel)) = [("^s", "save map")] @@ -1082,8 +1010,6 @@ ++ [("PgUp/Dn", "scroll")] keyCmdsFor (Just (FocusablePanel WorldPanel)) = [(T.intercalate "/" $ map keyW enumerate, "scroll") | canScroll] - ++ [(keyW SE.ViewBaseEvent, "recenter") | not viewingBase] - ++ [(keyW SE.ShowFpsEvent, "FPS")] keyCmdsFor (Just (FocusablePanel RobotPanel)) = ("Enter", "pop out") : if isJust inventorySearch @@ -1099,22 +1025,28 @@ ] keyCmdsFor (Just (FocusablePanel InfoPanel)) = [] keyCmdsFor _ = [] - keyM = VU.bindingText s . SE.Main - keyR = VU.bindingText s . SE.REPL - keyE = VU.bindingText s . SE.Robot - keyW = VU.bindingText s . SE.World + keyM = VU.bindingText keyConf . SE.Main + keyR = VU.bindingText keyConf . SE.REPL + keyE = VU.bindingText keyConf . SE.Robot + keyW = VU.bindingText keyConf . SE.World data KeyHighlight = NoHighlight | Alert | PanelSpecific -- | Draw a single key command in the menu. -drawKeyCmd :: (KeyHighlight, Text, Text) -> Widget Name -drawKeyCmd (h, key, cmd) = - hBox - [ withAttr attr (txt $ brackets key) - , txt cmd - ] +drawKeyCmd :: KeyCmd -> Widget Name +drawKeyCmd keycmd = + case keycmd of + (SingleButton h key cmd) -> + clickable (UIShortcut cmd) $ + hBox + [ withAttr (attr h) (txt $ brackets key) + , txt cmd + ] + (MultiButton h keyArr cmd) -> + hBox $ intersperse (txt "/") (map (createCmd h) keyArr) ++ [txt cmd] where - attr = case h of + createCmd h (key, cmd) = clickable (UIShortcut cmd) $ withAttr (attr h) (txt $ brackets key) + attr h = case h of NoHighlight -> defAttr Alert -> notifAttr PanelSpecific -> highlightAttr @@ -1157,22 +1089,22 @@ -- | Draw info about the currently focused robot, such as its name, -- position, orientation, and inventory, as long as it is not too -- far away. -drawRobotPanel :: AppState -> Widget Name +drawRobotPanel :: ScenarioState -> Widget Name drawRobotPanel s -- If the focused robot is too far away to communicate, just leave the panel blank. -- There should be no way to tell the difference between a robot that is too far -- away and a robot that does not exist. | Just r <- s ^. gameState . to focusedRobot - , Just (_, lst) <- s ^. uiState . uiGameplay . uiInventory . uiInventoryList = + , Just (_, lst) <- s ^. uiGameplay . uiInventory . uiInventoryList = let drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb - row = + details = [ txt (r ^. robotName) , padLeft (Pad 2) . str . renderCoordsString $ r ^. robotLocation , padLeft (Pad 2) $ renderDisplay (r ^. robotDisplay) ] in padBottom Max $ vBox - [ hCenter $ hBox row + [ hCenter $ hBox details , withLeftPaddedVScrollBars . padLeft (Pad 1) . padTop (Pad 1) $ BL.renderListWithIndex drawClickableItem True lst ] @@ -1200,7 +1132,7 @@ -- element of the list, once it scrolls off the top of the viewport -- it will never become visible again. -- See https://github.com/jtdaugherty/brick/issues/336#issuecomment-921220025 - (if sel == Just (i + 1) then visible else id) $ hBorderWithLabel (txt l) + applyWhen (sel == Just (i + 1)) visible $ hBorderWithLabel (txt l) drawItem _ _ _ (InventoryEntry n e) = drawLabelledEntityName e <+> showCount n where showCount = padLeft Max . str . show @@ -1212,7 +1144,7 @@ -- | Draw the info panel in the bottom-left corner, which shows info -- about the currently focused inventory item. -drawInfoPanel :: AppState -> Widget Name +drawInfoPanel :: ScenarioState -> Widget Name drawInfoPanel s | Just Far <- s ^. gameState . to focusedRange = blank | otherwise = @@ -1223,22 +1155,25 @@ -- | Display info about the currently focused inventory entity, -- such as its description and relevant recipes. -explainFocusedItem :: AppState -> Widget Name +explainFocusedItem :: ScenarioState -> Widget Name explainFocusedItem s = case focusedItem s of - Just (InventoryEntry _ e) -> explainEntry s e - Just (EquippedEntry e) -> explainEntry s e + Just (InventoryEntry _ e) -> explainEntry uig gs e + Just (EquippedEntry e) -> explainEntry uig gs e _ -> txt " " + where + gs = s ^. gameState + uig = s ^. uiGameplay -explainEntry :: AppState -> Entity -> Widget Name -explainEntry s e = +explainEntry :: UIGameplay -> GameState -> Entity -> Widget Name +explainEntry uig gs e = vBox $ [ displayProperties $ Set.toList (e ^. entityProperties) , drawMarkdown (e ^. entityDescription) - , explainCapabilities (s ^. gameState) e - , explainRecipes s e + , explainCapabilities gs e + , explainRecipes gs e ] - <> [drawRobotMachine s False | CDebug `M.member` getMap (e ^. entityCapabilities)] - <> [drawRobotLog s | CLog `M.member` getMap (e ^. entityCapabilities)] + <> [drawRobotMachine gs False | CDebug `M.member` getMap (e ^. entityCapabilities)] + <> [drawRobotLog uig gs | CExecute Log `M.member` getMap (e ^. entityCapabilities)] displayProperties :: [EntityProperty] -> Widget Name displayProperties = displayList . mapMaybe showProperty @@ -1250,12 +1185,15 @@ showProperty Liquid = Just "liquid" showProperty Unwalkable = Just "blocking" showProperty Opaque = Just "opaque" + showProperty Boundary = Just "boundary" + showProperty Evanescent = Just "evanescent" -- Most things are pickable so we don't show that. showProperty Pickable = Nothing -- 'Known' is just a technical detail of how we handle some entities -- in challenge scenarios and not really something the player needs -- to know. showProperty Known = Nothing + showProperty Printable = Just "printable" displayList [] = emptyWidget displayList ps = @@ -1285,12 +1223,11 @@ eitherCosts = (traverse . traverse) eLookup $ e ^. entityCapabilities capabilitiesAndCommands = case eitherCosts of Right eCaps -> M.elems . getMap . commandsForDeviceCaps $ eCaps - Left x -> - error $ - unwords - [ "Error: somehow an invalid entity reference escaped the parse-time check" - , T.unpack x - ] + -- The Left case should never happen - we check when parsing a + -- scenario that all entity references are defined. However, if + -- it does happen, there's no sense crashing the game; just + -- return an empty list of capabilities + commands. + Left _ -> [] drawSingleCapabilityWidget cmdsAndCost = vBox @@ -1340,8 +1277,8 @@ robotInv = fromMaybe E.empty $ gs ^? to focusedRobot . _Just . robotInventory -explainRecipes :: AppState -> Entity -> Widget Name -explainRecipes s e +explainRecipes :: GameState -> Entity -> Widget Name +explainRecipes gs e | null recipes = emptyWidget | otherwise = vBox @@ -1352,9 +1289,9 @@ $ map (hLimit widthLimit . padBottom (Pad 1) . drawRecipe (Just e) inv) recipes ] where - recipes = recipesWith s e + recipes = recipesWith gs e - inv = fromMaybe E.empty $ s ^? gameState . to focusedRobot . _Just . robotInventory + inv = fromMaybe E.empty $ gs ^? to focusedRobot . _Just . robotInventory width (n, ingr) = length (show n) + 1 + maximum0 (map T.length . T.words $ ingr ^. entityName) @@ -1368,9 +1305,9 @@ widthLimit = 2 * max maxInputWidth maxOutputWidth + 11 -- | Return all recipes that involve a given entity. -recipesWith :: AppState -> Entity -> [Recipe Entity] -recipesWith s e = - let getRecipes select = recipesFor (s ^. gameState . recipesInfo . select) e +recipesWith :: GameState -> Entity -> [Recipe Entity] +recipesWith gs e = + let getRecipes select = recipesFor (gs ^. recipesInfo . select) e in -- The order here is chosen intentionally. See https://github.com/swarm-game/swarm/issues/418. -- -- 1. Recipes where the entity is an input --- these should go @@ -1484,10 +1421,10 @@ -- or command status reports) are thus ephemeral, i.e. they are only -- shown when they are the most recent log entry, but hidden once -- something else is logged. -getLogEntriesToShow :: AppState -> [LogEntry] -getLogEntriesToShow s = logEntries ^.. traversed . ifiltered shouldShow +getLogEntriesToShow :: GameState -> [LogEntry] +getLogEntriesToShow gs = logEntries ^.. traversed . ifiltered shouldShow where - logEntries = s ^. gameState . to focusedRobot . _Just . robotLog + logEntries = gs ^. to focusedRobot . _Just . robotLog n = Seq.length logEntries shouldShow i le = @@ -1495,20 +1432,20 @@ RobotLog src _ _ -> src `elem` [Said, Logged] SystemLog -> False -drawRobotLog :: AppState -> Widget Name -drawRobotLog s = +drawRobotLog :: UIGameplay -> GameState -> Widget Name +drawRobotLog uig gs = vBox [ padBottom (Pad 1) (hBorderWithLabel (txt "Log")) , vBox . F.toList . imap drawEntry $ logEntriesToShow ] where - logEntriesToShow = getLogEntriesToShow s + logEntriesToShow = getLogEntriesToShow gs n = length logEntriesToShow drawEntry i e = - (if i == n - 1 && s ^. uiState . uiGameplay . uiScrollToEnd then visible else id) $ + applyWhen (i == n - 1 && uig ^. uiScrollToEnd) visible $ drawLogEntry (not allMe) e - rid = s ^? gameState . to focusedRobot . _Just . robotID + rid = gs ^? to focusedRobot . _Just . robotID allMe = all me logEntriesToShow me le = case le ^. leSource of @@ -1516,8 +1453,8 @@ _ -> False -- | Show the 'CESK' machine of focused robot. Puts a separator above. -drawRobotMachine :: AppState -> Bool -> Widget Name -drawRobotMachine s showName = case s ^. gameState . to focusedRobot of +drawRobotMachine :: GameState -> Bool -> Widget Name +drawRobotMachine gs showName = case gs ^. to focusedRobot of Nothing -> machineLine "no selected robot" Just r -> vBox @@ -1579,8 +1516,8 @@ replEditor -- | Draw the REPL. -drawREPL :: AppState -> Widget Name -drawREPL s = +drawREPL :: ScenarioState -> Widget Name +drawREPL ps = vBox [ withLeftPaddedVScrollBars . viewport REPLViewport Vertical @@ -1589,25 +1526,28 @@ , vBox mayDebug ] where + uig = ps ^. uiGameplay + gs = ps ^. gameState + -- rendered history lines fitting above REPL prompt history :: [Widget n] history = map fmt . filter (not . isREPLSaved) . toList . getSessionREPLHistoryItems $ theRepl ^. replHistory currentPrompt :: Widget Name currentPrompt = case (isActive <$> base, theRepl ^. replControlMode) of (_, Handling) -> padRight Max $ txt "[key handler running, M-k to toggle]" - (Just False, _) -> renderREPLPrompt (s ^. uiState . uiGameplay . uiFocusRing) theRepl + (Just False, _) -> renderREPLPrompt (uig ^. uiFocusRing) theRepl _running -> padRight Max $ txt "..." - theRepl = s ^. uiState . uiGameplay . uiREPL + theRepl = uig ^. uiREPL -- NOTE: there exists a lens named 'baseRobot' that uses "unsafe" -- indexing that may be an alternative to this: - base = s ^. gameState . robotInfo . robotMap . at 0 + base = gs ^. robotInfo . robotMap . at 0 - fmt (REPLHistItem itemType t) = case itemType of + fmt (REPLHistItem itemType _tick t) = case itemType of REPLEntry {} -> txt $ "> " <> t REPLOutput -> txt t REPLError -> txtWrapWith indent2 {preserveIndentation = True} t - mayDebug = [drawRobotMachine s True | s ^. uiState . uiGameplay . uiShowDebug] + mayDebug = [drawRobotMachine gs True | uig ^. uiShowDebug] ------------------------------------------------------------ -- Utility diff --git a/src/swarm-tui/Swarm/TUI/View/Achievement.hs b/src/swarm-tui/Swarm/TUI/View/Achievement.hs --- a/src/swarm-tui/Swarm/TUI/View/Achievement.hs +++ b/src/swarm-tui/Swarm/TUI/View/Achievement.hs @@ -16,7 +16,6 @@ import Swarm.Game.Achievement.Definitions import Swarm.Game.Achievement.Description import Swarm.TUI.Model -import Swarm.TUI.Model.UI import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.Util (drawMarkdown) import Text.Wrap @@ -44,7 +43,7 @@ ] ] where - attainedMap = s ^. uiState . uiAchievements + attainedMap = s ^. playState . progression . attainedAchievements drawAchievementListItem :: Map CategorizedAchievement Attainment -> diff --git a/src/swarm-tui/Swarm/TUI/View/Attribute/Attr.hs b/src/swarm-tui/Swarm/TUI/View/Attribute/Attr.hs --- a/src/swarm-tui/Swarm/TUI/View/Attribute/Attr.hs +++ b/src/swarm-tui/Swarm/TUI/View/Attribute/Attr.hs @@ -36,6 +36,7 @@ cyanAttr, lightCyanAttr, yellowAttr, + beigeAttr, blueAttr, greenAttr, redAttr, @@ -115,6 +116,7 @@ , (greenAttr, fg V.green) , (blueAttr, fg V.blue) , (yellowAttr, fg V.yellow) + , (beigeAttr, fg (V.rgbColor @Int 238 217 196)) , (cyanAttr, fg V.cyan) , (lightCyanAttr, fg (V.rgbColor @Int 200 255 255)) , (magentaAttr, fg V.magenta) @@ -183,11 +185,12 @@ customEditFocusedAttr = attrName "custom" <> E.editFocusedAttr -- | Some basic colors used in TUI. -redAttr, greenAttr, blueAttr, yellowAttr, cyanAttr, lightCyanAttr, magentaAttr, grayAttr :: AttrName +redAttr, greenAttr, blueAttr, yellowAttr, beigeAttr, cyanAttr, lightCyanAttr, magentaAttr, grayAttr :: AttrName redAttr = attrName "red" greenAttr = attrName "green" blueAttr = attrName "blue" yellowAttr = attrName "yellow" +beigeAttr = attrName "beige" cyanAttr = attrName "cyan" lightCyanAttr = attrName "lightCyan" magentaAttr = attrName "magenta" diff --git a/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs b/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs --- a/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs +++ b/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs @@ -2,9 +2,7 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.View.Attribute.CustomStyling where -import Data.Colour.SRGB (sRGB24read) import Data.Set (toList) -import Data.Text qualified as T import Graphics.Vty.Attributes import Swarm.Game.Entity.Cosmetic (WorldAttr (..)) import Swarm.Game.Scenario.Style @@ -22,10 +20,7 @@ Bold -> bold hexToAttrColor :: HexColor -> Color -hexToAttrColor (HexColor colorText) = - kolorToAttrColor c - where - c = sRGB24read $ T.unpack colorText +hexToAttrColor (HexColor kolor) = kolorToAttrColor kolor toAttrPair :: CustomAttr -> (WorldAttr, Attr) toAttrPair ca = diff --git a/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs b/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs --- a/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs +++ b/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs @@ -23,14 +23,17 @@ import Swarm.Game.Display ( Attribute (AEntity), Display, + boundaryOverride, defaultEntityDisplay, displayAttr, displayChar, displayPriority, + getBoundaryDisplay, hidden, ) import Swarm.Game.Entity import Swarm.Game.Land +import Swarm.Game.Location (Point (..), toHeading) import Swarm.Game.Robot import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) @@ -44,13 +47,15 @@ import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.Game.World.Coords +import Swarm.Language.Syntax.Direction (AbsoluteDir (..)) import Swarm.TUI.Editor.Masking import Swarm.TUI.Editor.Model import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Model.Name -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.UI.Gameplay import Swarm.TUI.View.Attribute.Attr import Swarm.Util (applyWhen) +import Swarm.Util.Content (getContentAt) import Witch (from) import Witch.Encoding qualified as Encoding @@ -140,12 +145,23 @@ Cosmic Coords -> [Display] displayEntityCell worldEditor ri coords = - maybeToList $ displayForEntity <$> maybeEntity + maybeToList $ assignBoundaryOverride . displayForEntity <$> maybeEntityPaint where - (_, maybeEntity) = EU.getEditorContentAt (terrMap ri) worldEditor (multiworldInfo ri) coords + maybeEntityPaint = getEntPaintAtCoord coords + getEntPaintAtCoord = snd . EU.getEditorContentAt (terrMap ri) worldEditor (multiworldInfo ri) + coordHasBoundary = maybe False (`hasProperty` Boundary) . snd . getContentAt (terrMap ri) (multiworldInfo ri) + + assignBoundaryOverride = applyWhen (coordHasBoundary coords) (boundaryOverride .~ getBoundaryDisplay checkPresence) + where + checkPresence :: AbsoluteDir -> Bool + checkPresence d = coordHasBoundary offsettedCoord + where + offsettedCoord = (`addTuple` xy) <$> coords + Coords xy = locToCoords $ P $ toHeading d + displayForEntity :: EntityPaint -> Display - displayForEntity e = (if isKnownFunc ri e then id else hidden) $ getDisplay e + displayForEntity e = applyWhen (not $ isKnownFunc ri e) hidden $ getDisplay e -- | Get the 'Display' for a specific location, by combining the -- 'Display's for the terrain, entity, and robots at the location, and diff --git a/src/swarm-tui/Swarm/TUI/View/Objective.hs b/src/swarm-tui/Swarm/TUI/View/Objective.hs --- a/src/swarm-tui/Swarm/TUI/View/Objective.hs +++ b/src/swarm-tui/Swarm/TUI/View/Objective.hs @@ -20,7 +20,7 @@ import Swarm.Language.Syntax (Syntax) import Swarm.Language.Text.Markdown (Document) import Swarm.Language.Text.Markdown qualified as Markdown -import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.Dialog.Goal import Swarm.TUI.Model.Name import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.Util diff --git a/src/swarm-tui/Swarm/TUI/View/Popup.hs b/src/swarm-tui/Swarm/TUI/View/Popup.hs --- a/src/swarm-tui/Swarm/TUI/View/Popup.hs +++ b/src/swarm-tui/Swarm/TUI/View/Popup.hs @@ -4,37 +4,57 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Rendering (& animating) notification popups. -module Swarm.TUI.View.Popup where +module Swarm.TUI.View.Popup ( + drawPopups, + startPopupAnimation, + popupFrameDuration, + popupFrames, +) where import Brick (Widget (..), cropTopTo, padLeftRight, txt, vBox) +import Brick.Animation (Animation, AnimationManager, Clip, RunMode (..), newClip, renderAnimation, startAnimation) import Brick.Widgets.Border (border) import Brick.Widgets.Center (hCenterLayer) import Brick.Widgets.Core (emptyWidget, hBox, withAttr) -import Control.Lens ((^.)) +import Control.Lens (Traversal', (^.), (^?)) +import Control.Monad.IO.Class (MonadIO) import Swarm.Game.Achievement.Definitions (title) import Swarm.Game.Achievement.Description (describe) +import Swarm.Game.Popup (Popup (..)) import Swarm.Language.Syntax (constInfo, syntax) -import Swarm.TUI.Model (AppState, Name, uiState) +import Swarm.TUI.Model (AppEvent, AppState, animTraversal, keyConfig, keyEventHandling, playState, progression, uiPopupAnimationState, _AnimActive) import Swarm.TUI.Model.Event qualified as SE -import Swarm.TUI.Model.Popup (Popup (..), currentPopup, popupFrames) -import Swarm.TUI.Model.UI (uiPopups) +import Swarm.TUI.Model.Name import Swarm.TUI.View.Attribute.Attr (notifAttr) import Swarm.TUI.View.Util (bindingText) import Swarm.Util (commaList, squote) --- | The number of frames taken by each step of the notification popup --- animation. -animFrames :: Int -animFrames = 3 +-- | The number of milliseconds taken by each animation frame of the notification popup +popupFrameDuration :: Integer +popupFrameDuration = 50 +-- | The number of animation frames for which to display a popup. +popupFrames :: Int +popupFrames = 125 + -- | Draw the current notification popup (if any). drawPopups :: AppState -> Widget Name -drawPopups s = hCenterLayer $ - case s ^. uiState . uiPopups . currentPopup of - Just (notif, f) -> - cropTopTo (popupRows f) . border . padLeftRight 2 $ drawPopup s notif - _ -> emptyWidget +drawPopups s = renderAnimation (const emptyWidget) s mAnim + where + mAnim = s ^? playState . progression . uiPopupAnimationState . _AnimActive +-- | Signal the animation manager to start the popup animation. +startPopupAnimation :: MonadIO m => AnimationManager AppState AppEvent Name -> Popup -> m () +startPopupAnimation mgr p = startAnimation mgr (makePopupClip p) popupFrameDuration Once trav + where + trav :: Traversal' AppState (Maybe (Animation AppState Name)) + trav = playState . progression . uiPopupAnimationState . animTraversal + +makePopupClip :: Popup -> Clip AppState Name +makePopupClip p = newClip $ map drawPopupFrame [0 .. popupFrames] + where + drawPopupFrame f s = hCenterLayer $ cropTopTo (popupRows f) . border . padLeftRight 2 $ drawPopup s p + drawPopup :: AppState -> Popup -> Widget Name drawPopup s = \case AchievementPopup ach -> @@ -45,7 +65,7 @@ RecipesPopup -> hBox [ withAttr notifAttr (txt "New recipes unlocked! ") - , txt $ bindingText s (SE.Main SE.ViewRecipesEvent) <> " to view." + , txt $ bindingText keyConf (SE.Main SE.ViewRecipesEvent) <> " to view." ] CommandsPopup cmds -> vBox @@ -53,22 +73,27 @@ [ withAttr notifAttr (txt "New commands unlocked: ") , txt . commaList $ map (squote . syntax . constInfo) cmds ] - , txt $ "Hit " <> bindingText s (SE.Main SE.ViewCommandsEvent) <> " to view all available commands." + , txt $ "Hit " <> bindingText keyConf (SE.Main SE.ViewCommandsEvent) <> " to view all available commands." ] + DebugWarningPopup -> + hBox + [ withAttr notifAttr (txt "Warning: ") + , txt "No progress will be saved, since debugging flags are in use." + ] + where + keyConf = s ^. keyEventHandling . keyConfig -- | Compute the number of rows of the notification popup we should be --- showing, based on the number of frames the popup has existed. +-- showing, based on the number of animation frames the popup has existed. -- This is what causes the popup to animate in and out of existence. popupRows :: Int -> Int popupRows f - -- If we're less than halfway through the lifetime of the popup, - -- divide the number of frames by the number of frames for each step - -- of the animation (rounded up). This will become much larger than - -- the actual number of rows in the popup, but the 'cropTopTo' function - -- simply has no effect when given any value equal to or larger than the - -- number of rows of a widget. This way the animation will continue to - -- work for popups with any (reasonable) number of rows. - | f <= popupFrames `div` 2 = (f + animFrames - 1) `div` animFrames - -- Otherwise, divide the number of frames remaining by the number of - -- frames for each step of the animation (rounded up). - | otherwise = (popupFrames - f + animFrames - 1) `div` animFrames + -- If we're less than halfway through the lifetime of the popup, use + -- the number of animation frames elapsed since the beginning of the popup animation. + -- This will become much larger than the actual number of rows in the + -- popup, but the 'cropTopTo' function simply has no effect when given any value + -- equal to or larger than the number of rows of a widget. This way the animation + -- will continue to work for popups with any (reasonable) number of rows. + | f <= popupFrames `div` 2 = f + -- Otherwise, use the number of frames remaining. + | otherwise = popupFrames - f diff --git a/src/swarm-tui/Swarm/TUI/View/Robot.hs b/src/swarm-tui/Swarm/TUI/View/Robot.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Robot.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A UI-centric model for presentation of Robot details. +-- +-- It stores robot IDs to identify rows, which makes +-- it relatively light-weight. +module Swarm.TUI.View.Robot ( + emptyRobotDisplay, + updateRobotList, + robotGridRenderers, + drawRobotsDisplayModal, + getSelectedRobot, +) where + +import Brick +import Brick.Focus +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.List qualified as BL +import Brick.Widgets.TabularList.Grid qualified as BL +import Brick.Widgets.TabularList.Mixed +import Control.Lens as Lens hiding (Const, from) +import Data.IntMap qualified as IM +import Data.List.Extra (dropPrefix, enumerate) +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import Data.Sequence qualified as S +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Linear (V2, distance) +import Numeric (showFFloat) +import Swarm.Game.CESK (CESK (..)) +import Swarm.Game.Entity as E +import Swarm.Game.Location (Point, origin) +import Swarm.Game.Robot +import Swarm.Game.Robot.Activity +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Tick (addTicks) +import Swarm.Game.Universe +import Swarm.Game.World.Coords +import Swarm.TUI.Model.DebugOption (DebugOption (..)) +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.UI.Gameplay +import Swarm.TUI.View.Attribute.Attr +import Swarm.TUI.View.CellDisplay +import Swarm.TUI.View.Robot.Details +import Swarm.TUI.View.Robot.Type +import Swarm.TUI.View.Shared (tabControlFooter) +import Swarm.Util (applyWhen, maximum0) +import Swarm.Util.UnitInterval +import Swarm.Util.WindowedCounter qualified as WC +import System.Clock (TimeSpec (..)) + +{-------------------------------------------------------------------- +NEW GRID LIST +--------------------------------------------------------------------} + +-- | The columns in the Robot modal grid. +data RobotColumn + = ColName + | ColAge + | ColPos + | ColItems + | ColStatus + | ColActns + | ColCmds + | ColCycles + | ColActivity + | ColLog + | -- | The ID is the only optional field. + -- It is shown last to make indexing code easier. + ColID + deriving (Eq, Ord, Enum, Bounded, Show) + +colName :: RobotColumn -> Text +colName = T.pack . dropPrefix "Col" . show + +colWidth :: RobotColumn -> Int +colWidth = textWidth . colName + +colWidths :: Set DebugOption -> Seq ColWidth +colWidths opt = ColW . getWidth <$> S.fromList robotColumns + where + showIDs = Set.member ListRobotIDs opt + robotColumns :: [RobotColumn] + robotColumns = (if showIDs then id else filter (/= ColID)) enumerate + getWidth = \case + ColName -> 26 + (if showIDs then 0 else getWidth ColID) + ColAge -> 8 + ColPos -> 9 + ColStatus -> 10 + ColID -> 5 + c -> 1 + colWidth c + +{-------------------------------------------------------------------- +EMPTY +--------------------------------------------------------------------} + +-- | Initial empty robot modal. +emptyRobotDisplay :: Set DebugOption -> RobotDisplay +emptyRobotDisplay opt = + RobotDisplay + { _isDetailsOpened = False + , -- we have to select the fixed width columns at start - if they change, the whole list has to be replaced + _robotsGridList = BL.gridTabularList (RobotsListDialog RobotList) mempty (LstItmH 1) (colWidths opt) + , _robotDetailsPaneState = + RobotDetailsPaneState + { _detailFocus = focusRing $ map (RobotsListDialog . SingleRobotDetails) enumerate + , _logsList = BL.list (RobotsListDialog $ SingleRobotDetails RobotLogPane) mempty 1 + , _cmdHistogramList = BL.list (RobotsListDialog $ SingleRobotDetails RobotCommandHistogramPane) mempty 1 + } + } + +{-------------------------------------------------------------------- +GET SELECTED +--------------------------------------------------------------------} + +getSelectedRID :: BL.GridTabularList Name RID -> Maybe RID +getSelectedRID gl = snd <$> BL.listSelectedElement gl.list + +-- | Get the robot selected in the robot list. +getSelectedRobot :: GameState -> BL.GridTabularList Name RID -> Maybe Robot +getSelectedRobot g gl = do + rid <- getSelectedRID gl + g ^. robotInfo . robotMap . at rid + +{-------------------------------------------------------------------- +UPDATE +--------------------------------------------------------------------} + +-- | Update robot modal grid list contents. +-- +-- To prevent memory leaks, this only stores robot IDs. +updateRobotList :: Set DebugOption -> GameState -> BL.GridTabularList Name RID -> BL.GridTabularList Name RID +updateRobotList dOpts g l = l {BL.list = updatedList} + where + updatedList :: BL.GenericList Name Seq RID + updatedList = BL.listReplace rids sel l.list + rids :: Seq RID + rids = S.fromList . fmap (view robotID) $ robots + sel :: Maybe Int + sel = flip S.elemIndexL rids =<< getSelectedRID l + + robots :: [Robot] + robots = g ^. robotInfo . robotMap . to IM.elems . to filterRobots + filterRobots :: [Robot] -> [Robot] + filterRobots = if Set.member ListAllRobots dOpts then id else filter (\r -> isRelevant r && isNear r) + basePos :: Point V2 Double + basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation . planar) + -- Keep the base and non system robot (e.g. no seed) + isRelevant r = r ^. robotID == 0 || not (r ^. systemRobot) + -- Keep the robot that are less than 32 unit away from the base + isNear r = creative || distance (realToFrac <$> r ^. robotLocation . planar) basePos < 32 + creative = g ^. creativeMode + +{-------------------------------------------------------------------- +DRAW +--------------------------------------------------------------------} + +columnHdrAttr :: AttrName +columnHdrAttr = attrName "columnHeader" + +rowHdrAttr :: AttrName +rowHdrAttr = attrName "rowHeader" + +-- | Draw robot modal. +-- +-- It either shows a list of robots information or details of selected robot. +drawRobotsDisplayModal :: UIGameplay -> GameState -> RobotDisplay -> Widget Name +drawRobotsDisplayModal t g robDisplay = + if robDisplay ^. isDetailsOpened + then robDetail + else robList + where + robDetail :: Widget Name + robDetail = + let detailsContent = case getSelectedRobot g (robDisplay ^. robotsGridList) of + Nothing -> str "No selection" + Just r -> renderRobotDetails r $ robDisplay ^. robotDetailsPaneState + in vBox + [ detailsContent + , tabControlFooter + ] + robList :: Widget Name + robList = drawRobotsList t g $ robDisplay ^. robotsGridList + +drawRobotsList :: UIGameplay -> GameState -> BL.GridTabularList Name RID -> Widget Name +drawRobotsList t g = vLimit 30 . BL.renderGridTabularList (robotGridRenderers t g) (LstFcs True) + +-- | Render robot modal grid - column and row headers as well as cells based on robot ID. +robotGridRenderers :: UIGameplay -> GameState -> BL.GridRenderers Name RID +robotGridRenderers t g = + BL.GridRenderers + { BL.cell = drawRobotGridCell t g + , BL.rowHdr = Just rowHdr + , BL.colHdr = Just colHdr + , BL.colHdrRowHdr = Just colRowHdr + } + +-- | Enumerates the rows by position (just row index, not 'RID'). +rowHdr :: RowHdr Name a +rowHdr = + RowHdr + { draw = \_ (WdthD wd) (RowHdrCtxt (Sel s)) rh -> + let attrFn = applyWhen (not s) $ withAttr rowHdrAttr + in attrFn $ padRight (Pad $ if wd > 0 then 0 else 1) $ padLeft Max (str $ show rh) + , width = \_ rh -> RowHdrW . (+ 2) . maximum0 $ map (length . show) rh + , toRH = \_ (Ix i) -> i + 1 + } + +colHdr :: BL.GridColHdr Name +colHdr = + BL.GridColHdr + { draw = + \_ (WdthD widthDef) (BL.GColC (BL.Ix i) (BL.Sel _sel)) -> + let colGap = padLeft (Pad $ if widthDef > 0 then 0 else 1) + in withAttr columnHdrAttr (colGap . txt . colName $ toEnum i) <=> hBorder + , height = ColHdrH 2 + } + +colRowHdr :: BL.ColHdrRowHdr Name +colRowHdr = BL.ColHdrRowHdr $ \_ (WdthD _wd) -> fill ' ' <=> hBorder + +drawRobotGridCell :: UIGameplay -> GameState -> ListFocused -> WidthDeficit -> BL.GridCtxt -> RID -> Widget Name +drawRobotGridCell t g _foc (WdthD widthDef) ctx rid = + colGap . withSelectedAttr $ + case g ^. robotInfo . robotMap . at rid of + -- this would be a synchronisation error, but crashing the game is not worth it + Nothing -> case col of + ColID -> padRight Max $ showW rid + _ -> fill '?' + Just r -> case col of + ColName -> padRight Max $ nameWidget r + ColAge -> hCenter $ ageWidget r + ColPos -> hCenter $ locWidget r + ColItems -> padLeft Max $ rInvCount r + ColStatus -> hCenter $ statusWidget r + ColActns -> padLeft Max . showW $ r ^. activityCounts . tangibleCommandCount + ColCmds -> padLeft Max . showW . sum . M.elems $ r ^. activityCounts . commandsHistogram + ColCycles -> padLeft Max . showW $ r ^. activityCounts . lifetimeStepCount + ColActivity -> padLeft Max $ renderDutyCycle (g ^. temporal) r + ColLog -> hCenter $ rLog r + ColID -> padRight Max $ showW rid + where + (BL.GColC (BL.Ix cIx) (BL.Sel cSel)) = ctx.col + (BL.GRowC (BL.Ix _ix) (BL.Sel rSel)) = ctx.row + withSelectedAttr = if cSel && rSel then withAttr BL.listSelectedAttr else id + col :: RobotColumn + col = if cIx <= fromEnum (maxBound :: RobotColumn) then toEnum cIx else ColLog + + showW :: Show a => a -> Widget Name + showW = str . show + highlightSystem :: Robot -> Widget Name -> Widget Name + highlightSystem r = applyWhen (r ^. systemRobot) $ withAttr highlightAttr + colGap = padLeft (Pad $ if widthDef > 0 then 0 else 1) + + nameWidget :: Robot -> Widget Name + nameWidget r = + hBox + [ renderDisplay (r ^. robotDisplay) + , highlightSystem r . txt $ " " <> r ^. robotName + ] + + ageWidget :: Robot -> Widget Name + ageWidget r = str ageStr + where + TimeSpec createdAtSec _ = r ^. robotCreatedAt + TimeSpec nowSec _ = t ^. uiTiming . lastFrameTime + age = nowSec - createdAtSec + ageStr + | age < 60 = show age <> "sec" + | age < 3600 = show (age `div` 60) <> "min" + | age < 3600 * 24 = show (age `div` 3600) <> "hour" + | otherwise = show (age `div` 3600 * 24) <> "day" + + rInvCount :: Robot -> Widget Name + rInvCount r = showW . sum . map fst . E.elems $ r ^. robotEntity . entityInventory + + rLog :: Robot -> Widget Name + rLog r = str $ if r ^. robotLogUpdated then "x" else " " + + locWidget :: Robot -> Widget Name + locWidget r = hBox [worldCell, str $ " " <> locStr] + where + rCoords = fmap locToCoords rLoc + rLoc = r ^. robotLocation + worldCell = drawLoc t g rCoords + locStr = renderCoordsString rLoc + + statusWidget :: Robot -> Widget Name + statusWidget r = case r ^. machine of + Waiting {} -> str "waiting" + _ | isActive r -> withAttr notifAttr $ str "busy" + _ | otherwise -> withAttr greenAttr $ str "idle" + +-- | Render the percentage of ticks that this robot was active. +-- This indicator can take some time to "warm up" and stabilize +-- due to the sliding window. +-- +-- == Use of previous tick +-- The 'Swarm.Game.Step.gameTick' function runs all robots, then increments the current tick. +-- So at the time we are rendering a frame, the current tick will always be +-- strictly greater than any ticks stored in the 'WC.WindowedCounter' for any robot; +-- hence 'WC.getOccupancy' will never be @1@ if we use the current tick directly as +-- obtained from the 'ticks' function. +-- So we "rewind" it to the previous tick for the purpose of this display. +renderDutyCycle :: TemporalState -> Robot -> Widget Name +renderDutyCycle temporalState r = withAttr dutyCycleAttr $ str tx + where + tx = showFFloat (Just 1) dutyCyclePercentage "%" + + curTicks = temporalState ^. ticks + window = r ^. activityCounts . activityWindow + + -- Rewind to previous tick + latestRobotTick = addTicks (-1) curTicks + dutyCycleRatio = WC.getOccupancy latestRobotTick window + + dutyCycleAttr = safeIndex dutyCycleRatio meterAttributeNames + + dutyCyclePercentage :: Double + dutyCyclePercentage = 100 * getValue dutyCycleRatio diff --git a/src/swarm-tui/Swarm/TUI/View/Robot/Details.hs b/src/swarm-tui/Swarm/TUI/View/Robot/Details.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Robot/Details.hs @@ -0,0 +1,74 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Rendering of the "details" pane of the F2 robots dialog +module Swarm.TUI.View.Robot.Details (renderRobotDetails) where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.List qualified as BL +import Brick.Widgets.Table qualified as BT + +import Brick.Focus +import Control.Lens hiding (from, (<.>)) +import Data.Map.Strict qualified as M +import Prettyprinter (pretty) +import Swarm.Game.Robot +import Swarm.Game.Robot.Activity (commandsHistogram) +import Swarm.Game.Robot.Concrete +import Swarm.Log +import Swarm.Pretty (prettyText) +import Swarm.TUI.Model.Name +import Swarm.TUI.View.Attribute.Attr (boldAttr, cyanAttr) +import Swarm.TUI.View.Robot.Type +import Swarm.Util (applyWhen) + +renderRobotDetails :: Robot -> RobotDetailsPaneState -> Widget Name +renderRobotDetails r paneState = + vBox + [ str $ + unwords + [ "Selected robot" + , show $ view robotName r + ] + , hBorder + , hBox + [ highlightBorderFor RobotLogPane $ borderWithLabel (str "Logs") logsTable + , highlightBorderFor RobotCommandHistogramPane $ borderWithLabel (str "Commands") commandsTable + ] + ] + where + ring = paneState ^. detailFocus + highlightBorderFor n = + applyWhen isFocused $ overrideAttr borderAttr cyanAttr + where + isFocused = focusGetCurrent ring == Just (RobotsListDialog $ SingleRobotDetails n) + + logsTable = withFocusRing ring (BL.renderList mkLogTableEntry) $ paneState ^. logsList + + mkLogTableEntry _isSelected x = + hBox + [ withAttr cyanAttr . str . show . pretty . view leTime $ x + , str ": " + , txtWrap . view leText $ x + ] + + commandsTable = + BT.renderTable + . BT.columnBorders True + . BT.rowBorders False + . BT.surroundingBorder False + . BT.setDefaultColAlignment BT.AlignLeft + . BT.setColAlignment BT.AlignRight 0 + . BT.table + $ map (withAttr boldAttr . str) ["Command", "Count"] : commandHistogramEntries + + mkHistogramEntry (k, v) = + [ txt $ prettyText k + , str $ show v + ] + + commandHistogramEntries = + map mkHistogramEntry $ + M.toList $ + r ^. activityCounts . commandsHistogram diff --git a/src/swarm-tui/Swarm/TUI/View/Robot/Type.hs b/src/swarm-tui/Swarm/TUI/View/Robot/Type.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Robot/Type.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.View.Robot.Type where + +import Brick.Focus (FocusRing) +import Brick.Widgets.List qualified as BL +import Brick.Widgets.TabularList.Grid +import Control.Lens hiding (Const, from, (<.>)) +import Data.Sequence (Seq) +import Swarm.Game.Robot +import Swarm.Language.Syntax (Const) +import Swarm.Log +import Swarm.TUI.Model.Name + +data RobotDetailsPaneState = RobotDetailsPaneState + { _detailFocus :: FocusRing Name + , _logsList :: BL.GenericList Name Seq LogEntry + , _cmdHistogramList :: BL.List Name (Const, Int) + } + +makeLenses ''RobotDetailsPaneState + +data RobotDisplay = RobotDisplay + { _isDetailsOpened :: Bool + , _robotsGridList :: GridTabularList Name RID + , _robotDetailsPaneState :: RobotDetailsPaneState + } + +makeLenses ''RobotDisplay diff --git a/src/swarm-tui/Swarm/TUI/View/Shared.hs b/src/swarm-tui/Swarm/TUI/View/Shared.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Shared.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- UI view components shared across dialogs +module Swarm.TUI.View.Shared where + +import Brick +import Brick.Widgets.Center (hCenter) +import Swarm.TUI.View.Attribute.Attr (italicAttr) + +tabControlFooter :: Widget n +tabControlFooter = hCenter $ withAttr italicAttr $ txt "NOTE: [Tab] toggles focus between panes" diff --git a/src/swarm-tui/Swarm/TUI/View/Structure.hs b/src/swarm-tui/Swarm/TUI/View/Structure.hs --- a/src/swarm-tui/Swarm/TUI/View/Structure.hs +++ b/src/swarm-tui/Swarm/TUI/View/Structure.hs @@ -20,36 +20,36 @@ import Data.Text qualified as T import Data.Vector qualified as V import Swarm.Game.Entity (Entity, entityDisplay) -import Swarm.Game.Scenario (StructureCells) import Swarm.Game.Scenario.Topography.Area -import Swarm.Game.Scenario.Topography.Placement (getStructureName) -import Swarm.Game.Scenario.Topography.Structure qualified as Structure +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Structure.Named qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) -import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (getEntityGrid) import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Static import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.State import Swarm.Game.State.Substate (structureRecognition) import Swarm.Language.Syntax.Direction (directionJsonModifier) +import Swarm.TUI.Model.Dialog.Structure import Swarm.TUI.Model.Name -import Swarm.TUI.Model.Structure import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.CellDisplay +import Swarm.TUI.View.Shared (tabControlFooter) import Swarm.TUI.View.Util import Swarm.Util (commaList) -- | Render a two-pane widget with structure selection on the left -- and single-structure details on the right. -structureWidget :: GameState -> StructureInfo StructureCells Entity -> Widget n +structureWidget :: GameState -> StructureInfo b Entity -> Widget n structureWidget gs s = vBox [ hBox - [ headerItem "Name" theName + [ headerItem "Name" $ Structure.getStructureName theName , padLeft (Pad 2) . headerItem "Size" . T.pack . renderRectDimensions - . getAreaDimensions + . getNEGridDimensions $ entityProcessedGrid s , occurrenceCountSuffix ] @@ -69,8 +69,8 @@ ] annotatedStructureGrid = annotatedGrid s - - supportedOrientations = Set.toList . Structure.recognize . namedGrid $ annotatedStructureGrid + theNamedGrid = originalItem $ grid annotatedStructureGrid + supportedOrientations = Set.toList . Structure.recognize $ theNamedGrid renderSymmetry = \case NoSymmetry -> "no" @@ -89,8 +89,7 @@ maybeDescriptionWidget = maybe emptyWidget (padTop (Pad 1) . withAttr italicAttr . txtWrap) $ - Structure.description . namedGrid . annotatedGrid $ - s + Structure.description theNamedGrid registry = gs ^. discovery . structureRecognition . foundStructures occurrenceCountSuffix = case M.lookup theName $ foundByName registry of @@ -98,7 +97,6 @@ Just inner -> padLeft (Pad 2) . headerItem "Count" . T.pack . show $ NEM.size inner structureIllustration = vBox $ map (hBox . map renderOneCell) cells - d = namedGrid $ annotatedGrid s ingredientsBox = vBox @@ -117,25 +115,28 @@ ] ] - theName = getStructureName $ Structure.name d - cells = getEntityGrid d + theName = Structure.name theNamedGrid + cells = getRows $ Grid $ entityProcessedGrid s + renderOneCell = maybe (txt " ") (renderDisplay . view entityDisplay) -makeListWidget :: [StructureInfo StructureCells Entity] -> BL.List Name (StructureInfo StructureCells Entity) +makeListWidget :: [StructureInfo b a] -> BL.List Name (StructureInfo b a) makeListWidget structureDefinitions = BL.listMoveTo 0 $ BL.list (StructureWidgets StructuresList) (V.fromList structureDefinitions) 1 -renderStructuresDisplay :: GameState -> StructureDisplay -> Widget Name +renderStructuresDisplay :: + GameState -> + StructureDisplay -> + Widget Name renderStructuresDisplay gs structureDisplay = vBox [ hBox [ leftSide , padLeft (Pad 2) structureElaboration ] - , footer + , tabControlFooter ] where - footer = hCenter $ withAttr italicAttr $ txt "NOTE: [Tab] toggles focus between panes" lw = _structurePanelListWidget structureDisplay fr = _structurePanelFocus structureDisplay leftSide = @@ -163,7 +164,7 @@ drawSidebarListItem :: Bool -> - StructureInfo StructureCells Entity -> + StructureInfo b a -> Widget Name drawSidebarListItem _isSelected (StructureInfo annotated _ _) = - txt . getStructureName . Structure.name $ namedGrid annotated + txt . Structure.getStructureName . Structure.name $ originalItem $ grid annotated diff --git a/src/swarm-tui/Swarm/TUI/View/Util.hs b/src/swarm-tui/Swarm/TUI/View/Util.hs --- a/src/swarm-tui/Swarm/TUI/View/Util.hs +++ b/src/swarm-tui/Swarm/TUI/View/Util.hs @@ -5,46 +5,126 @@ module Swarm.TUI.View.Util where import Brick hiding (Direction, Location) -import Brick.Keybindings (Binding (..), firstActiveBinding, ppBinding) +import Brick.Keybindings (Binding (..), KeyConfig, firstActiveBinding, ppBinding) import Brick.Widgets.Dialog import Brick.Widgets.List qualified as BL import Control.Lens hiding (Const, from) import Control.Monad.Reader (withReaderT) import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as M -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Text (Text) import Data.Text qualified as T import Graphics.Vty qualified as V import Swarm.Game.Entity as E import Swarm.Game.Land -import Swarm.Game.Location import Swarm.Game.Scenario (scenarioMetadata, scenarioName) +import Swarm.Game.Scenario.Status import Swarm.Game.ScenarioInfo (scenarioItemName) import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Substate import Swarm.Game.Terrain -import Swarm.Language.Pretty (prettyTextLine) import Swarm.Language.Syntax (Syntax) import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Language.Types (Polytype) +import Swarm.Pretty (prettyTextLine) import Swarm.TUI.Model import Swarm.TUI.Model.Event (SwarmEvent) -import Swarm.TUI.Model.UI +import Swarm.TUI.Model.Menu +import Swarm.TUI.Model.UI.Gameplay import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.CellDisplay +import Swarm.Util (maximum0) import Witch (from, into) --- | Generate a fresh modal window of the requested type. -generateModal :: AppState -> ModalType -> Modal -generateModal s mt = Modal mt (dialog (Just $ str title) buttons (maxModalWindowWidth `min` requiredWidth)) +data ScenarioSeriesContext = ScenarioSeriesContext + { scenarioSeries :: [ScenarioWith ScenarioPath] + , currentMenuName :: Maybe Text + , hasMenu :: Bool + } + +generateScenarioEndModal :: + ScenarioSeriesContext -> + EndScenarioModalType -> + ScenarioState -> + Modal +generateScenarioEndModal (ScenarioSeriesContext scenarioList scenarioMenuName isNoMenu) mt s = + Modal (EndScenarioModal mt) $ + dialog (Just $ str title) buttons (maxModalWindowWidth `min` requiredWidth) where - currentScenario = s ^. uiState . uiGameplay . scenarioRef + currentScenario = s ^. uiGameplay . scenarioRef currentSeed = s ^. gameState . randomness . seed - haltingMessage = case s ^. uiState . uiMenu of - NoMenu -> Just "Quit" - _ -> Nothing + + (title, buttons, requiredWidth) = case mt of + ScenarioFinishModal WinModal -> mkWinModal + ScenarioFinishModal LoseModal -> mkLoseModal + QuitModal -> mkQuitModal + KeepPlayingModal -> ("", Just (Button CancelButton, [("OK", Button CancelButton, Cancel)]), 80) + + mkWinModal = + ( "" + , Just + ( Button NextButton + , [ (nextMsg, Button NextButton, Next remainingScenarios) + | Just remainingScenarios <- [NE.nonEmpty scenarioList] + ] + ++ [ (stopMsg, Button QuitButton, QuitAction) -- TODO(#2376) QuitAction is not used + , (continueMsg, Button KeepPlayingButton, KeepPlaying) + ] + ) + , sum (map length [nextMsg, stopMsg, continueMsg]) + 32 + ) + where + nextMsg = "Next challenge!" + + maybeStartOver = do + cs <- currentScenario + return ("Start over", Button StartOverButton, StartOver currentSeed cs) + + mkLoseModal = + ( "" + , Just + ( Button $ if isJust currentScenario then StartOverButton else QuitButton + , catMaybes + [ Just (stopMsg, Button QuitButton, QuitAction) + , maybeStartOver + , Just (continueMsg, Button KeepPlayingButton, KeepPlaying) + ] + ) + , sum (map length [stopMsg, continueMsg]) + 32 + ) + + stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> scenarioMenuName) ++ " menu") haltingMessage + continueMsg = "Keep playing" + + haltingMessage = + if isNoMenu + then Just "Quit" + else Nothing + + mkQuitModal = + ( "" + , Just + ( Button CancelButton + , catMaybes + [ Just ("Keep playing", Button CancelButton, Cancel) + , maybeStartOver + , Just (stopMsg, Button QuitButton, QuitAction) + ] + ) + , T.length (quitMsg isNoMenu) + 4 + ) + +-- | Generate a fresh modal window of the requested type. +generateModal :: ScenarioState -> MidScenarioModalType -> Modal +generateModal s mt = + Modal (MidScenarioModal mt) $ + dialog (Just $ str title) buttons (maxModalWindowWidth `min` requiredWidth) + where + currentScenario = s ^. uiGameplay . scenarioRef + descriptionWidth = 100 (title, buttons, requiredWidth) = case mt of @@ -54,66 +134,16 @@ CommandsModal -> ("Available Commands", Nothing, descriptionWidth) MessagesModal -> ("Messages", Nothing, descriptionWidth) StructuresModal -> ("Buildable Structures", Nothing, descriptionWidth) - ScenarioEndModal WinModal -> - let nextMsg = "Next challenge!" - stopMsg = fromMaybe "Return to the menu" haltingMessage - continueMsg = "Keep playing" - in ( "" - , Just - ( Button NextButton - , [ (nextMsg, Button NextButton, Next scene) - | Just scene <- [nextScenario (s ^. uiState . uiMenu)] - ] - ++ [ (stopMsg, Button QuitButton, QuitAction) - , (continueMsg, Button KeepPlayingButton, KeepPlaying) - ] - ) - , sum (map length [nextMsg, stopMsg, continueMsg]) + 32 - ) - ScenarioEndModal LoseModal -> - let stopMsg = fromMaybe "Return to the menu" haltingMessage - continueMsg = "Keep playing" - maybeStartOver = do - cs <- currentScenario - return ("Start over", Button StartOverButton, StartOver currentSeed cs) - in ( "" - , Just - ( Button QuitButton - , catMaybes - [ Just (stopMsg, Button QuitButton, QuitAction) - , maybeStartOver - , Just (continueMsg, Button KeepPlayingButton, KeepPlaying) - ] - ) - , sum (map length [stopMsg, continueMsg]) + 32 - ) DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth) - QuitModal -> - let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage - maybeStartOver = do - cs <- currentScenario - return ("Start over", Button StartOverButton, StartOver currentSeed cs) - in ( "" - , Just - ( Button CancelButton - , catMaybes - [ Just ("Keep playing", Button CancelButton, Cancel) - , maybeStartOver - , Just (stopMsg, Button QuitButton, QuitAction) - ] - ) - , T.length (quitMsg (s ^. uiState . uiMenu)) + 4 - ) GoalModal -> let goalModalTitle = case currentScenario of Nothing -> "Goal" - Just (scenario, _) -> scenario ^. scenarioMetadata . scenarioName + Just (ScenarioWith scenario _) -> scenario ^. scenarioMetadata . scenarioName in (" " <> T.unpack goalModalTitle <> " ", Nothing, descriptionWidth) - KeepPlayingModal -> ("", Just (Button CancelButton, [("OK", Button CancelButton, Cancel)]), 80) TerrainPaletteModal -> ("Terrain", Nothing, w) where tm = s ^. gameState . landscape . terrainAndEntities . terrainMap - wordLength = maximum $ map (T.length . getTerrainWord) (M.keys $ terrainByName tm) + wordLength = maximum0 $ map (T.length . getTerrainWord) (M.keys $ terrainByName tm) w = wordLength + 6 EntityPaletteModal -> ("Entity", Nothing, 30) @@ -150,6 +180,7 @@ "entity" -> greenAttr "structure" -> redAttr "tag" -> yellowAttr + "robot" -> beigeAttr "type" -> magentaAttr _snippet -> highlightAttr -- same as plain code @@ -173,23 +204,25 @@ maxModalWindowWidth = 500 -- | Get the name of the current New Game menu. -curMenuName :: AppState -> Maybe Text -curMenuName s = case s ^. uiState . uiMenu of +curMenuName :: Menu -> Maybe Text +curMenuName m = case m of NewGameMenu (_ :| (parentMenu : _)) -> Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName) NewGameMenu _ -> Just "Scenarios" _ -> Nothing -quitMsg :: Menu -> Text -quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this scenario will be lost!" +quitMsg :: Bool -> Text +quitMsg isNoMenu = + T.unwords + [ "Are you sure you want to" + , quitAction <> "?" + , "All progress on this scenario will be lost!" + ] where - quitAction = case m of - NoMenu -> "quit" - _ -> "return to the menu" - -locationToString :: Location -> String -locationToString (Location x y) = - unwords $ map show [x, y] + quitAction = + if isNoMenu + then "quit" + else "return to the menu" -- | Display a list of text-wrapped paragraphs with one blank line after each. displayParagraphs :: [Text] -> Widget Name @@ -244,11 +277,10 @@ ] -- | Render the keybinding bound to a specific event. -bindingText :: AppState -> SwarmEvent -> Text -bindingText s e = maybe "" ppBindingShort b +bindingText :: KeyConfig SwarmEvent -> SwarmEvent -> Text +bindingText keyConf e = maybe "" ppBindingShort b where - conf = s ^. keyEventHandling . keyConfig - b = firstActiveBinding conf e + b = firstActiveBinding keyConf e ppBindingShort = \case Binding V.KUp m | null m -> "↑" Binding V.KDown m | null m -> "↓" diff --git a/src/swarm-util/Control/Carrier/Accum/FixedStrict.hs b/src/swarm-util/Control/Carrier/Accum/FixedStrict.hs deleted file mode 100644 --- a/src/swarm-util/Control/Carrier/Accum/FixedStrict.hs +++ /dev/null @@ -1,139 +0,0 @@ --- This file is a temporary copy of the code from fused-effects, with --- https://github.com/fused-effects/fused-effects/issues/449 fixed --- (the fixed line of code is marked with a comment below). We should --- keep this only until the above issue is fixed upstream. -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | A carrier for 'Accum' effects. --- This carrier performs its append operations strictly and thus avoids the space leaks inherent in lazy writer monads. --- These appends are left-associative; as such, @[]@ is a poor choice of monoid for computations that entail many calls to 'tell'. --- The [Seq](http://hackage.haskell.org/package/containersdocs/Data-Sequence.html) or [DList](http://hackage.haskell.org/package/dlist) monoids may be a superior choice. --- --- @since 1.1.2.0 -module Control.Carrier.Accum.FixedStrict ( - -- * Accum carrier - runAccum, - execAccum, - evalAccum, - AccumC (AccumC), - - -- * Accum effect - module Control.Effect.Accum, -) where - -import Control.Algebra -import Control.Applicative (Alternative (..)) -import Control.Effect.Accum -import Control.Monad (MonadPlus (..)) -import Control.Monad.Fail as Fail -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Trans.Class - --- | Run an 'Accum' effect with a 'Monoid'al log, applying a continuation to the final log and result. --- --- @ --- 'runAccum' w0 ('pure' a) = 'pure' (w0, a) --- @ --- @ --- 'runAccum' w0 ('add' w) = 'pure' (w0 <> w, ()) --- @ --- @ --- 'runAccum' w0 ('add' w >> 'look') = 'pure' (w0 <> w, w0 <> w) --- @ --- --- @since 1.1.2.0 -runAccum :: w -> AccumC w m a -> m (w, a) -runAccum = flip runAccumC -{-# INLINE runAccum #-} - --- | Run a 'Accum' effect (typically with a 'Monoid'al log), --- producing the final log and discarding the result value. --- --- @ --- 'execAccum' w = 'fmap' 'fst' . 'runAccum' w --- @ --- --- @since 1.1.2.0 -execAccum :: (Functor m) => w -> AccumC w m a -> m w -execAccum w = fmap fst . runAccum w -{-# INLINE execAccum #-} - --- | Run a 'Accum' effect (typically with a 'Monoid'al log), --- producing the result value and discarding the final log. --- --- @ --- 'evalAccum' w = 'fmap' 'snd' . 'runAccum' w --- @ --- --- @since 1.1.2.0 -evalAccum :: (Functor m) => w -> AccumC w m a -> m a -evalAccum w = fmap snd . runAccum w -{-# INLINE evalAccum #-} - --- | @since 1.1.2.0 -newtype AccumC w m a = AccumC {runAccumC :: w -> m (w, a)} - -instance Monoid w => MonadTrans (AccumC w) where - lift ma = AccumC $ \_ -> (mempty,) <$> ma - {-# INLINE lift #-} - -instance Functor m => Functor (AccumC w m) where - fmap f ma = AccumC $ fmap (fmap f) . runAccumC ma - {-# INLINE fmap #-} - -instance (Monad m, Monoid w) => Applicative (AccumC w m) where - pure a = AccumC $ const $ pure (mempty, a) - {-# INLINE pure #-} - - mf <*> ma = AccumC $ \w -> do - (w', f) <- runAccumC mf w - (w'', a) <- runAccumC ma $ mappend w w' - return (mappend w' w'', f a) - {-# INLINE (<*>) #-} - -instance (Alternative m, Monad m, Monoid w) => Alternative (AccumC w m) where - empty = lift empty - {-# INLINE empty #-} - - ma1 <|> ma2 = AccumC $ \w -> runAccumC ma1 w <|> runAccumC ma2 w - {-# INLINE (<|>) #-} - -instance (Monad m, Monoid w) => Monad (AccumC w m) where - ma >>= f = AccumC $ \w -> do - (w', a) <- runAccumC ma w - (w'', b) <- runAccumC (f a) $ mappend w w' - return (mappend w' w'', b) - {-# INLINE (>>=) #-} - -instance (MonadPlus m, Monoid w) => MonadPlus (AccumC w m) where - mzero = lift mzero - {-# INLINE mzero #-} - - ma1 `mplus` ma2 = AccumC $ \w -> runAccumC ma1 w `mplus` runAccumC ma2 w - {-# INLINE mplus #-} - -instance (MonadFail m, Monoid w) => MonadFail (AccumC w m) where - fail = AccumC . const . Fail.fail - {-# INLINE fail #-} - -instance (MonadFix m, Monoid w) => MonadFix (AccumC w m) where - mfix ma = AccumC $ \w -> mfix $ flip runAccumC w . ma . snd - {-# INLINE mfix #-} - -instance (MonadIO m, Monoid w) => MonadIO (AccumC w m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (AccumC w m) where - alg hdl sig ctx = AccumC $ \w -> case sig of - L accum -> case accum of - Add w' -> pure (w', ctx) - Look -> pure (mempty, w <$ ctx) - R other -> thread (uncurry runAccum ~<~ hdl) other (mempty, ctx) -- THIS IS THE FIXED LINE - {-# INLINE alg #-} diff --git a/src/swarm-util/Data/BoolExpr/Simplify.hs b/src/swarm-util/Data/BoolExpr/Simplify.hs --- a/src/swarm-util/Data/BoolExpr/Simplify.hs +++ b/src/swarm-util/Data/BoolExpr/Simplify.hs @@ -52,9 +52,8 @@ replace m c@(BConst x) = case M.lookup varname m of Nothing -> c Just val -> - if txform val + if isPositive == val then BTrue else BFalse where (varname, isPositive) = extractConstFromSigned x - txform = if isPositive then id else not diff --git a/src/swarm-util/Swarm/Failure.hs b/src/swarm-util/Swarm/Failure.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Failure.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A data type to represent system failures (as distinct from robot +-- program failures). +-- +-- These failures are often not fatal and serve +-- to create common infrastructure for logging. +module Swarm.Failure ( + SystemFailure (..), + simpleErrorHandle, + AssetData (..), + Asset (..), + Entry (..), + LoadingFailure (..), + OrderFileWarning (..), +) where + +import Control.Carrier.Throw.Either (ThrowC (..), runThrow) +import Control.Monad ((<=<)) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void +import Data.Yaml (ParseException, prettyPrintParseException) +import Prettyprinter (Pretty (pretty), nest, squotes, vcat, (<+>)) +import Swarm.Pretty (BulletList (..), PrettyPrec (..), ppr, prettyShowLow, prettyString) +import Swarm.Util (showLowT) +import Text.Megaparsec (ParseErrorBundle, errorBundlePretty) +import Witch (into) + +------------------------------------------------------------ +-- Failure descriptions + +-- | Enumeration of various assets we can attempt to load. +data AssetData = AppAsset | NameGeneration | Entities | Terrain | Recipes | Worlds | Scenarios | Script + deriving (Eq, Show) + +-- | Overarching enumeration of various assets we can attempt to load. +data Asset = Achievement | Data AssetData | History | Keybindings | Save + deriving (Eq, Show) + +-- | Enumeration type to distinguish between directories and files. +data Entry = Directory | File + deriving (Eq, Show) + +-- | An error that occurred while attempting to load some kind of asset. +data LoadingFailure + = DoesNotExist Entry + | EntryNot Entry + | CanNotParseYaml ParseException + | Duplicate AssetData Text + | SystemFailure SystemFailure + deriving (Show) + +-- ~~~~ Note [Pretty-printing typechecking errors] +-- +-- It would make sense to store a CheckErr in DoesNotTypecheck; +-- however, Swarm.Failure is imported in lots of places, and +-- CheckErr can contain high-level things like TTerms etc., so it +-- would lead to an import cycle. Instead, we choose to just +-- pretty-print typechecking errors before storing them here. + +-- | A warning that arose while processing an @00-ORDER.txt@ file. +data OrderFileWarning + = NoOrderFile + | MissingFiles (NonEmpty FilePath) + | DanglingFiles (NonEmpty FilePath) + deriving (Eq, Show) + +-- | An enumeration of various types of failures (errors or warnings) +-- that can occur. +data SystemFailure + = AssetNotLoaded Asset FilePath LoadingFailure + | ScenarioNotFound FilePath + | OrderFileWarning FilePath OrderFileWarning + | CanNotParseMegaparsec (ParseErrorBundle Text Void) + | DoesNotTypecheck Text -- See Note [Pretty-printing typechecking errors] + | CustomFailure Text + deriving (Show) + +------------------------------------------------------------ +-- Basic error handling + +simpleErrorHandle :: ThrowC SystemFailure IO a -> IO a +simpleErrorHandle = either (fail . prettyString) pure <=< runThrow + +------------------------------------------------------------ +-- Pretty-printing + +instance PrettyPrec AssetData where + prettyPrec _ = \case + NameGeneration -> "name generation data" + AppAsset -> "data assets" + d -> pretty (showLowT d) + +instance PrettyPrec Asset where + prettyPrec _ = \case + Data ad -> ppr ad + a -> pretty (showLowT a) + +instance PrettyPrec Entry where + prettyPrec _ = prettyShowLow + +instance PrettyPrec LoadingFailure where + prettyPrec prec = \case + DoesNotExist e -> "The" <+> ppr e <+> "is missing!" + EntryNot e -> "The entry is not a" <+> ppr e <> "!" + CanNotParseYaml p -> + nest 2 . vcat $ + "Parse failure:" + : map pretty (T.lines (into @Text (prettyPrintParseException p))) + Duplicate thing duped -> "Duplicate" <+> ppr thing <> ":" <+> squotes (pretty duped) + SystemFailure g -> prettyPrec prec g + +instance PrettyPrec OrderFileWarning where + prettyPrec _ = \case + NoOrderFile -> "File not found; using alphabetical order" + MissingFiles missing -> + ppr . BulletList "Files not listed will be ignored:" $ + map (into @Text) (NE.toList missing) + DanglingFiles dangling -> + ppr . BulletList "Some listed files do not exist:" $ + map (into @Text) (NE.toList dangling) + +instance PrettyPrec SystemFailure where + prettyPrec _ = \case + AssetNotLoaded a fp l -> + nest 2 . vcat $ + [ "Failed to acquire" <+> ppr a <+> "from path" <+> squotes (pretty fp) <> ":" + , ppr l + ] + ScenarioNotFound s -> "Scenario not found:" <+> pretty s + OrderFileWarning orderFile w -> + nest 2 . vcat $ + [ "Warning: while processing" <+> pretty orderFile <> ":" + , ppr w + ] + CanNotParseMegaparsec p -> + nest 2 . vcat $ + "Parse failure:" + : map pretty (T.lines (into @Text (errorBundlePretty p))) + DoesNotTypecheck t -> + nest 2 . vcat $ + "Parse failure:" + : map pretty (T.lines t) + CustomFailure m -> pretty m diff --git a/src/swarm-util/Swarm/Language/Syntax/Direction.hs b/src/swarm-util/Swarm/Language/Syntax/Direction.hs --- a/src/swarm-util/Swarm/Language/Syntax/Direction.hs +++ b/src/swarm-util/Swarm/Language/Syntax/Direction.hs @@ -10,6 +10,7 @@ module Swarm.Language.Syntax.Direction ( -- * Directions Direction (..), + CoordinateOrientation (..), AbsoluteDir (..), RelativeDir (..), PlanarRelativeDir (..), @@ -26,9 +27,11 @@ import Data.Hashable (Hashable) import Data.List qualified as L (drop) import Data.List.Extra (enumerate) -import Data.Text hiding (filter, length, map) +import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) +import Prettyprinter (pretty) +import Swarm.Pretty (PrettyPrec (..)) import Swarm.Util.JSON (optionsMinimize) ------------------------------------------------------------ @@ -131,6 +134,9 @@ DRelative x -> case x of DPlanar y -> show y _ -> show x + +instance PrettyPrec Direction where + prettyPrec _ = pretty . directionSyntax -- | Check if the direction is absolute (e.g. 'Swarm.Game.Location.north' or 'Swarm.Game.Location.south'). isCardinal :: Direction -> Bool diff --git a/src/swarm-util/Swarm/Pretty.hs b/src/swarm-util/Swarm/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Pretty.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Common pretty-printing infrastructure for the Swarm project. +module Swarm.Pretty ( + -- * The 'PrettyPrec' class + PrettyPrec (..), + + -- * Running pretty-printers + ppr, + prettyText, + prettyTextWidth, + prettyTextLine, + prettyString, + docToText, + docToTextWidth, + docToString, + + -- * Pretty-printing utilities + pparens, + pparens', + encloseWithIndent, + bquote, + prettyShowLow, + reportBug, + BulletList (..), + prettyBinding, + prettyEquality, + Wildcard (..), +) where + +import Control.Monad.Free +import Data.Fix (Fix, unFix) +import Data.Text (Text) +import Prettyprinter +import Prettyprinter.Render.String qualified as RS +import Prettyprinter.Render.Text qualified as RT +import Swarm.Util (showLowT) + +------------------------------------------------------------ +-- PrettyPrec class + utilities + +-- | Type class for things that can be pretty-printed, given a +-- precedence level of their context. +class PrettyPrec a where + prettyPrec :: Int -> a -> Doc ann -- can replace with custom ann type later if desired + +instance PrettyPrec Text where + prettyPrec _ = pretty + +instance (PrettyPrec (t (Fix t))) => PrettyPrec (Fix t) where + prettyPrec p = prettyPrec p . unFix + +instance (PrettyPrec (t (Free t v)), PrettyPrec v) => PrettyPrec (Free t v) where + prettyPrec p (Free t) = prettyPrec p t + prettyPrec p (Pure v) = prettyPrec p v + +-- | Pretty-print a thing, with a context precedence level of zero. +ppr :: (PrettyPrec a) => a -> Doc ann +ppr = prettyPrec 0 + +-- | Render a pretty-printed document as @Text@. +docToText :: Doc a -> Text +docToText = RT.renderStrict . layoutPretty defaultLayoutOptions + +-- | Render a pretty-printed document as @Text@. +-- This function consumes number of allowed characters in a +-- line before introducing a line break. In other words, it +-- expects the space of the layouter to be supplied. +docToTextWidth :: Doc a -> Int -> Text +docToTextWidth doc layoutWidth = + RT.renderStrict $ layoutPretty (LayoutOptions (AvailablePerLine layoutWidth 1.0)) doc + +-- | Pretty-print something and render it as @Text@. +prettyText :: (PrettyPrec a) => a -> Text +prettyText = docToText . ppr + +-- | Pretty-print something and render it as @Text@. +-- This is different than @prettyText@ in the sense that it also +-- consumes number of allowed characters in a line before introducing +-- a line break. +prettyTextWidth :: (PrettyPrec a) => a -> Int -> Text +prettyTextWidth = docToTextWidth . ppr + +-- | Pretty-print something and render it as (preferably) one line @Text@. +prettyTextLine :: (PrettyPrec a) => a -> Text +prettyTextLine = RT.renderStrict . layoutPretty (LayoutOptions Unbounded) . group . ppr + +-- | Render a pretty-printed document as a @String@. +docToString :: Doc a -> String +docToString = RS.renderString . layoutPretty defaultLayoutOptions + +-- | Pretty-print something and render it as a @String@. +prettyString :: (PrettyPrec a) => a -> String +prettyString = docToString . ppr + +-- | Optionally surround a document with parentheses depending on the +-- @Bool@ argument and if it does not fit on line, indent the lines, +-- with the parens on separate lines. +pparens :: Bool -> Doc ann -> Doc ann +pparens True = group . encloseWithIndent 2 lparen rparen +pparens False = id + +-- | Same as pparens but does not indent the lines. Only encloses +-- the document with parantheses. +pparens' :: Bool -> Doc ann -> Doc ann +pparens' True = group . enclose lparen rparen +pparens' False = id + +encloseWithIndent :: Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann +encloseWithIndent i l r = nest i . enclose (l <> line') (nest (-2) $ line' <> r) + +-- | Surround a document with backticks. +bquote :: Doc ann -> Doc ann +bquote = group . enclose "`" "`" + +-- | Turn a 'Show' instance into a @Doc@, lowercasing it in the +-- process. +prettyShowLow :: Show a => a -> Doc ann +prettyShowLow = pretty . showLowT + +-- | An invitation to report an error as a bug. +reportBug :: Doc ann +reportBug = "This should never happen; please report this as a bug: https://github.com/swarm-game/swarm/issues/new" + +-------------------------------------------------- +-- Bullet lists + +data BulletList i = BulletList + { bulletListHeader :: forall a. Doc a + , bulletListItems :: [i] + } + +instance (PrettyPrec i) => PrettyPrec (BulletList i) where + prettyPrec _ (BulletList hdr items) = + nest 2 . vcat $ hdr : map (("-" <+>) . ppr) items + +-------------------------------------------------- +-- Term- and type-printing utilities: bindings, equalities, wildcards, +-- etc. + +prettyBinding :: (PrettyPrec a, PrettyPrec b) => (a, b) -> Doc ann +prettyBinding (x, ty) = ppr x <> ":" <+> ppr ty + +prettyEquality :: (PrettyPrec a, PrettyPrec b) => (a, Maybe b) -> Doc ann +prettyEquality (x, Nothing) = ppr x +prettyEquality (x, Just t) = ppr x <+> "=" <+> ppr t + +-- | We can use the 'Wildcard' value to replace unification variables +-- when we don't care about them, e.g. to print out the shape of a +-- type like @(_ -> _) * _@ +data Wildcard = Wildcard + deriving (Eq, Ord, Show) + +instance PrettyPrec Wildcard where + prettyPrec _ _ = "_" diff --git a/src/swarm-util/Swarm/ResourceLoading.hs b/src/swarm-util/Swarm/ResourceLoading.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/ResourceLoading.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Fetching game data +-- +-- Various utilities related to loading game data files. +module Swarm.ResourceLoading ( + -- * Generic data access + getDataDirSafe, + getDataFileNameSafe, + + -- * Concrete data access + getSwarmConfigIniFile, + getSwarmSavePath, + getSwarmHistoryPath, + getSwarmAchievementsPath, + + -- ** Loading text files + readAppData, + NameGenerator (..), + initNameGenerator, +) where + +import Control.Algebra (Has) +import Control.Effect.Lift (Lift, sendIO) +import Control.Effect.Throw (Throw, liftEither, throwError) +import Control.Exception (catch) +import Control.Exception.Base (IOException) +import Control.Monad (forM, when, (<=<)) +import Data.Array (Array, listArray) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Paths_swarm (getDataDir) +import Swarm.Failure +import Swarm.Util +import System.Directory ( + XdgDirectory (..), + createDirectoryIfMissing, + doesDirectoryExist, + doesFileExist, + getXdgDirectory, + listDirectory, + ) +import System.FilePath +import Witch + +-- | Read-only lists of adjectives and words for use in building random robot names +data NameGenerator = NameGenerator + { adjList :: Array Int Text + , nameList :: Array Int Text + } + +-- | Get subdirectory from swarm data directory. +-- +-- This will first look in Cabal generated path and then +-- try a @data@ directory in 'XdgData' path. +-- +-- The idea is that when installing with Cabal/Stack the first +-- is preferred, but when the players install a binary they +-- need to extract the `data` archive to the XDG directory. +getDataDirSafe :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + AssetData -> + FilePath -> + m FilePath +getDataDirSafe asset p = do + d <- (`appDir` p) <$> sendIO getDataDir + de <- sendIO $ doesDirectoryExist d + if de + then return d + else do + xd <- (`appDir` p) <$> sendIO (getSwarmXdgDataSubdir False "data") + xde <- sendIO $ doesDirectoryExist xd + if xde then return xd else throwError $ AssetNotLoaded (Data asset) xd $ DoesNotExist Directory + where + appDir r = \case + "" -> r + "." -> r + d -> r d + +-- | Get file from swarm data directory. +-- +-- See the note in 'getDataDirSafe'. +getDataFileNameSafe :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + AssetData -> + FilePath -> + m FilePath +getDataFileNameSafe asset name = do + d <- getDataDirSafe asset "." + let fp = d name + fe <- sendIO $ doesFileExist fp + if fe + then return fp + else throwError $ AssetNotLoaded (Data asset) fp $ DoesNotExist File + +getSwarmConfigIniFile :: Bool -> IO (Bool, FilePath) +getSwarmConfigIniFile createDirs = do + swarmConfig <- getXdgDirectory XdgConfig "swarm" + when createDirs (createDirectoryIfMissing True swarmConfig) + let ini = swarmConfig "config.ini" + iniExists <- doesFileExist ini + return (iniExists, ini) + +-- | Get path to swarm data, optionally creating necessary +-- directories. This could fail if user has bad permissions +-- on his own @$HOME@ or @$XDG_DATA_HOME@ which is unlikely. +getSwarmXdgDataSubdir :: Bool -> FilePath -> IO FilePath +getSwarmXdgDataSubdir createDirs subDir = do + swarmData <- ( subDir) <$> getXdgDirectory XdgData "swarm" + when createDirs (createDirectoryIfMissing True swarmData) + pure swarmData + +getSwarmXdgDataFile :: Bool -> FilePath -> IO FilePath +getSwarmXdgDataFile createDirs filepath = do + let (subDir, file) = splitFileName filepath + d <- getSwarmXdgDataSubdir createDirs subDir + return $ d file + +-- | Get path to swarm saves, optionally creating necessary +-- directories. +getSwarmSavePath :: Bool -> IO FilePath +getSwarmSavePath createDirs = getSwarmXdgDataSubdir createDirs "saves" + +-- | Get path to swarm history, optionally creating necessary +-- directories. +getSwarmHistoryPath :: Bool -> IO FilePath +getSwarmHistoryPath createDirs = getSwarmXdgDataFile createDirs "history" + +-- | Get a path to the directory where achievement records are +-- stored. If the argument is set to @True@, create the directory if +-- it does not exist. +getSwarmAchievementsPath :: Bool -> IO FilePath +getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement" + +-- | Read all the @.txt@ files in the @data/@ directory. +readAppData :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m (Map Text Text) +readAppData = do + d <- getDataDirSafe AppAsset "." + dirMembers :: [FilePath] <- + (liftEither <=< sendIO) $ + (pure <$> listDirectory d) `catch` \(e :: IOException) -> + return . Left . AssetNotLoaded (Data AppAsset) d . SystemFailure . CustomFailure . T.pack $ show e + let fs = filter ((== ".txt") . takeExtension) dirMembers + + filesList <- sendIO $ forM fs (\f -> (into @Text (dropExtension f),) <$> readFileMayT (d f)) + return $ M.fromList . mapMaybe sequenceA $ filesList + +initNameGenerator :: Has (Throw SystemFailure) sig m => Map Text Text -> m NameGenerator +initNameGenerator appDataMap = do + adjs <- getDataLines "adjectives" + names <- getDataLines "names" + return $ + NameGenerator + { adjList = makeArr adjs + , nameList = makeArr names + } + where + makeArr xs = listArray (0, length xs - 1) xs + getDataLines f = case M.lookup f appDataMap of + Nothing -> + throwError $ + AssetNotLoaded (Data NameGeneration) (into @FilePath f <.> "txt") (DoesNotExist File) + Just content -> return . drop 1 . T.lines $ content diff --git a/src/swarm-util/Swarm/Util.hs b/src/swarm-util/Swarm/Util.hs --- a/src/swarm-util/Swarm/Util.hs +++ b/src/swarm-util/Swarm/Util.hs @@ -24,11 +24,12 @@ findDup, both, allEqual, - surfaceEmpty, tails1, prependList, deleteKeys, + lookupEither, applyWhen, + applyJust, hoistMaybe, unsnocNE, @@ -81,19 +82,20 @@ smallHittingSet, ) where -import Control.Applicative (Alternative) import Control.Carrier.Throw.Either import Control.Effect.State (State, modify, state) import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<&>), (<>~)) -import Control.Monad (filterM, guard, unless) +import Control.Monad (filterM, unless) import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.Bifunctor (Bifunctor (bimap), first) import Data.Char (isAlphaNum, toLower) +import Data.Either.Extra (maybeToEither) import Data.Either.Validation +import Data.Foldable (Foldable (..)) import Data.Foldable qualified as Foldable import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IM -import Data.List (foldl', maximumBy, partition) +import Data.List (maximumBy, partition) import Data.List qualified as List import Data.List.Extra (enumerate) import Data.List.NonEmpty (NonEmpty ((:|))) @@ -118,6 +120,7 @@ import System.FilePath (takeExtension, ()) import System.IO.Error (catchIOError) import Witch (from) +import Prelude hiding (Foldable (..)) infixr 1 ? infix 4 %%=, <+=, <%=, <<.=, <>= @@ -231,14 +234,16 @@ allEqual [] = True allEqual (x : xs) = all (== x) xs -surfaceEmpty :: Alternative f => (a -> Bool) -> a -> f a -surfaceEmpty isEmpty t = t <$ guard (not (isEmpty t)) - -- | Taken from here: -- https://hackage.haskell.org/package/ghc-9.8.1/docs/GHC-Data-FiniteMap.html#v:deleteList deleteKeys :: Ord key => [key] -> Map key elt -> Map key elt deleteKeys ks m = foldl' (flip M.delete) m ks +-- | Convenience function to indicate which key +-- was not found in the map. +lookupEither :: Ord k => k -> Map k v -> Either k v +lookupEither k = maybeToEither k . M.lookup k + ------------------------------------------------------------ -- Backported functions @@ -273,6 +278,12 @@ applyWhen True f x = f x applyWhen False _ x = x +-- | +-- Equivalent to `fromMaybe id`. +applyJust :: Maybe (a -> a) -> a -> a +applyJust Nothing x = x +applyJust (Just f) x = f x + -- | Convert a 'Maybe' computation to 'MaybeT'. -- -- TODO (#1151): Use implementation from "transformers" package v0.6.0.0 @@ -363,6 +374,9 @@ failT = fail . from @Text . T.unwords -- | Show a value, but as Text. +-- +-- Note: Data.Text.show was added in text-2.1.2. Eventually we can +-- require that version of text and get rid of showT. showT :: Show a => a -> Text showT = from @String . show @@ -525,6 +539,9 @@ -- | Remove any sets which are supersets of other sets. In other words, -- (1) no two sets in the output are in a subset relationship -- (2) every element in the input is a superset of some element in the output. +-- +-- Note this can also be seen as minimizing a boolean expression in positive +-- conjunctive normal form. -- -- >>> import qualified Data.Set as S -- >>> rss = map S.toList . S.toList . removeSupersets . S.fromList . map S.fromList diff --git a/src/swarm-util/Swarm/Util/Effect.hs b/src/swarm-util/Swarm/Util/Effect.hs --- a/src/swarm-util/Swarm/Util/Effect.hs +++ b/src/swarm-util/Swarm/Util/Effect.hs @@ -5,7 +5,7 @@ module Swarm.Util.Effect where import Control.Algebra -import Control.Carrier.Accum.FixedStrict +import Control.Carrier.Accum.Strict import Control.Carrier.Error.Either (ErrorC (..)) import Control.Carrier.Throw.Either (ThrowC (..), runThrow) import Control.Effect.Throw diff --git a/src/swarm-util/Swarm/Util/Graph.hs b/src/swarm-util/Swarm/Util/Graph.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/Graph.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Graph utilities shared by multiple aspects of scenarios +module Swarm.Util.Graph ( + isAcyclicGraph, + findCycle, + failOnCyclicGraph, +) where + +import Control.Monad (forM_) +import Control.Monad.ST +import Data.Array ((!)) +import Data.Array.ST +import Data.Graph (SCC (..), Vertex, graphFromEdges) +import Data.IntSet (IntSet) +import Data.IntSet qualified as IS +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Util + +isAcyclicGraph :: [SCC a] -> Bool +isAcyclicGraph = + all isAcyclicVertex + where + isAcyclicVertex = \case + AcyclicSCC _ -> True + _ -> False + +-- | Keep track of the current search path in a DFS, both as a set of +-- vertices (for fast membership testing) and as a reversed list of +-- vertices visited along the current path, in order. +-- +-- Note this is different than just keeping track of which vertices +-- have been visited at all; visited vertices remain visited when +-- DFS backtracks, but the DFSPath gets shorter again. +data DFSPath = DFSPath IntSet [Vertex] + +emptyDFSPath :: DFSPath +emptyDFSPath = DFSPath IS.empty [] + +appendPath :: DFSPath -> Vertex -> DFSPath +appendPath (DFSPath s p) v = DFSPath (IS.insert v s) (v : p) + +-- | Find a cycle in a directed graph (if any exist) via DFS. +-- +-- >>> findCycle [("a", 0, [0])] +-- Just ["a"] +-- >>> findCycle [("a", 0, [1]), ("b", 1, [])] +-- Nothing +-- >>> findCycle [("a", 0, [1]), ("b", 1, [0])] +-- Just ["a","b"] +-- >>> findCycle [("a", 0, [1]), ("b", 1, [2]), ("c", 2, [1])] +-- Just ["b","c"] +-- >>> findCycle [("a",3,[1]), ("b",1,[0,3]), ("c",2,[1]), ("d",0,[])] +-- Just ["b","a"] +-- >>> findCycle [("a",3,[]), ("b",1,[0,3]), ("c",2,[1]), ("d",0,[])] +-- Nothing +-- >>> findCycle [("a",3,[1]), ("b",1,[0,3]), ("c",2,[1]), ("d",0,[2])] +-- Just ["d","c","b"] +findCycle :: Ord key => [(a, key, [key])] -> Maybe [a] +findCycle es = runST $ do + visited <- newArray (0, n - 1) False + (fmap . map) (fst3 . v2l) <$> dfsL visited emptyDFSPath [0 .. n - 1] + where + n = length es + (g, v2l, _) = graphFromEdges es + fst3 (a, _, _) = a + + dfsL :: STUArray s Vertex Bool -> DFSPath -> [Vertex] -> ST s (Maybe [Vertex]) + dfsL _ _ [] = pure Nothing + dfsL visited path (v : vs) = do + found <- dfs visited path v + case found of + Nothing -> dfsL visited path vs + Just cyc -> pure (Just cyc) + + dfs :: STUArray s Vertex Bool -> DFSPath -> Vertex -> ST s (Maybe [Vertex]) + dfs visited p@(DFSPath pathMembers path) v + | v `IS.member` pathMembers = pure . Just . (v :) . reverse $ takeWhile (/= v) path + | otherwise = do + vis <- readArray visited v + case vis of + True -> pure Nothing + False -> dfsL visited (appendPath p v) (g ! v) + +failOnCyclicGraph :: + Ord key => + Text -> + (a -> Text) -> + [(a, key, [key])] -> + Either Text () +failOnCyclicGraph graphType keyFunction gEdges = + forM_ (findCycle gEdges) $ \cyc -> + Left $ + T.unwords + [ graphType + , "graph contains a cycle:" + , brackets . T.intercalate " -> " . fmap keyFunction $ cyc + ] diff --git a/src/swarm-util/Swarm/Util/ReadableIORef.hs b/src/swarm-util/Swarm/Util/ReadableIORef.hs deleted file mode 100644 --- a/src/swarm-util/Swarm/Util/ReadableIORef.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Ensures that access to an 'IORef' is read-only --- by hiding behind a newtype. -module Swarm.Util.ReadableIORef (mkReadonly, ReadableIORef, readIORef) where - -import Data.IORef (IORef) -import Data.IORef qualified as R (readIORef) - -newtype ReadableIORef a = ReadableIORef (IORef a) - -mkReadonly :: IORef a -> ReadableIORef a -mkReadonly = ReadableIORef - -readIORef :: ReadableIORef a -> IO a -readIORef (ReadableIORef ref) = R.readIORef ref diff --git a/src/swarm-util/Swarm/Util/WindowedCounter.hs b/src/swarm-util/Swarm/Util/WindowedCounter.hs --- a/src/swarm-util/Swarm/Util/WindowedCounter.hs +++ b/src/swarm-util/Swarm/Util/WindowedCounter.hs @@ -157,7 +157,7 @@ insert x (WindowedCounter s lastLargest nominalSpan) = discardGarbage x $ WindowedCounter (Set.insert x s) newLargest nominalSpan where - newLargest = Just $ maybe x (max x) lastLargest + newLargest = Just $! maybe x (max x) lastLargest -- | Drop the leading elements that are not larger than the cutoff. -- diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -19,7 +19,6 @@ -- -- Missing endpoints: -- --- * TODO: #625 run endpoint to load definitions -- * TODO: #493 export the whole game state module Swarm.Web ( startWebThread, @@ -34,7 +33,6 @@ webMain, ) where -import Brick.BChan import Commonmark qualified as Mark (commonmark, renderHtml) import Control.Arrow (left) import Control.Concurrent (forkIO) @@ -43,6 +41,7 @@ import Control.Lens import Control.Monad (void) import Control.Monad.IO.Class (liftIO) +import Data.Aeson (ToJSON) import Data.ByteString.Lazy (ByteString) import Data.Foldable (toList) import Data.IntMap qualified as IM @@ -52,6 +51,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Tree (Tree (Node), drawTree) import Network.HTTP.Types (ok200) @@ -63,28 +63,34 @@ import Servant.Docs (ToCapture) import Servant.Docs qualified as SD import Servant.Docs.Internal qualified as SD (renderCurlBasePath) -import Swarm.Doc.Command +import Servant.Types.SourceT qualified as S import Swarm.Game.Entity (EntityName, entityName) +import Swarm.Game.Location (Location) import Swarm.Game.Robot import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph import Swarm.Game.Scenario.Objective.WinCheck +import Swarm.Game.Scenario.Status import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..)) +import Swarm.Game.Scenario.Topography.Navigation.Portal import Swarm.Game.Scenario.Topography.Structure.Recognition import Swarm.Game.Scenario.Topography.Structure.Recognition.Log import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry import Swarm.Game.State +import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Substate import Swarm.Game.Step.Path.Type +import Swarm.Game.Universe (SubworldName) import Swarm.Language.Pipeline (processTermEither) -import Swarm.Language.Pretty (prettyTextLine) +import Swarm.Pretty (prettyTextLine) import Swarm.TUI.Model hiding (SwarmKeyDispatchers (..)) -import Swarm.TUI.Model.Goal -import Swarm.TUI.Model.Repl (REPLHistItem, replHistory, replSeq) -import Swarm.TUI.Model.UI -import Swarm.Util.ReadableIORef +import Swarm.TUI.Model.Dialog.Goal +import Swarm.TUI.Model.Repl (REPLHistItem, getSessionREPLHistoryItems, replHistory, replSeq) +import Swarm.TUI.Model.UI.Gameplay +import Swarm.Util (applyJust) import Swarm.Util.RingBuffer +import Swarm.Web.GraphRender import Swarm.Web.Worldview import System.Timeout (timeout) import Text.Read (readEither) @@ -103,14 +109,16 @@ :<|> "goals" :> "prereqs" :> Get '[JSON] [PrereqSatisfaction] :<|> "goals" :> "active" :> Get '[JSON] [Objective] :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo) + :<|> "goals" :> "render" :> Get '[PlainText] T.Text :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking :<|> "goals" :> Get '[JSON] WinCondition + :<|> "navigation" :> Get '[JSON] (Navigation (M.Map SubworldName) Location) :<|> "recognize" :> "log" :> Get '[JSON] [SearchLog EntityName] :<|> "recognize" :> "found" :> Get '[JSON] [StructureLocation] :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text - :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text + :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> StreamGet NewlineFraming JSON (SourceIO WebInvocationState) :<|> "paths" :> "log" :> Get '[JSON] (RingBuffer CacheLogEntry) - :<|> "commands" :> Get '[JSON] CommandCatalog + :<|> "repl" :> "history" :> "current" :> Get '[JSON] [REPLHistItem] :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem] :<|> "map" :> Capture "size" AreaDimensions :> Get '[JSON] GridResponse @@ -128,7 +136,7 @@ swarmApiHtml :: ByteString swarmApiHtml = encodeUtf8 - . either (error . show) (Mark.renderHtml @()) + . either (TL.pack . show) (Mark.renderHtml @()) . Mark.commonmark "" $ T.pack swarmApiMarkdown @@ -149,9 +157,10 @@ -- ------------------------------------------------------------------ mkApp :: - ReadableIORef AppState -> + -- | Read-only access to the current AppState + IO AppState -> -- | Writable channel to send events to the game - BChan AppEvent -> + EventChannel -> Servant.Server SwarmAPI mkApp state events = robotsHandler state @@ -159,69 +168,88 @@ :<|> prereqsHandler state :<|> activeGoalsHandler state :<|> goalsGraphHandler state + :<|> goalsRenderHandler state :<|> uiGoalHandler state :<|> goalsHandler state + :<|> navigationHandler state :<|> recogLogHandler state :<|> recogFoundHandler state :<|> codeRenderHandler :<|> codeRunHandler events :<|> pathsLogHandler state - :<|> cmdMatrixHandler state - :<|> replHistHandler state + :<|> replHistHandler Current state + :<|> replHistHandler Full state :<|> mapViewHandler state -robotsHandler :: ReadableIORef AppState -> Handler [Robot] +robotsHandler :: IO AppState -> Handler [Robot] robotsHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - pure $ IM.elems $ appState ^. gameState . robotInfo . robotMap + appState <- liftIO appStateRef + pure $ IM.elems $ appState ^. playState . scenarioState . gameState . robotInfo . robotMap -robotHandler :: ReadableIORef AppState -> RobotID -> Handler (Maybe Robot) +robotHandler :: IO AppState -> RobotID -> Handler (Maybe Robot) robotHandler appStateRef (RobotID rid) = do - appState <- liftIO (readIORef appStateRef) - pure $ IM.lookup rid (appState ^. gameState . robotInfo . robotMap) + appState <- liftIO appStateRef + pure $ IM.lookup rid (appState ^. playState . scenarioState . gameState . robotInfo . robotMap) -prereqsHandler :: ReadableIORef AppState -> Handler [PrereqSatisfaction] +prereqsHandler :: IO AppState -> Handler [PrereqSatisfaction] prereqsHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - case appState ^. gameState . winCondition of + appState <- liftIO appStateRef + case appState ^. playState . scenarioState . gameState . winCondition of WinConditions _winState oc -> return $ getSatisfaction oc _ -> return [] -activeGoalsHandler :: ReadableIORef AppState -> Handler [Objective] +activeGoalsHandler :: IO AppState -> Handler [Objective] activeGoalsHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - case appState ^. gameState . winCondition of + appState <- liftIO appStateRef + case appState ^. playState . scenarioState . gameState . winCondition of WinConditions _winState oc -> return $ getActiveObjectives oc _ -> return [] -goalsGraphHandler :: ReadableIORef AppState -> Handler (Maybe GraphInfo) +goalsGraphHandler :: IO AppState -> Handler (Maybe GraphInfo) goalsGraphHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - return $ case appState ^. gameState . winCondition of + appState <- liftIO appStateRef + return $ case appState ^. playState . scenarioState . gameState . winCondition of WinConditions _winState oc -> Just $ makeGraphInfo oc _ -> Nothing -uiGoalHandler :: ReadableIORef AppState -> Handler GoalTracking +goalsRenderHandler :: IO AppState -> Handler T.Text +goalsRenderHandler appStateRef = do + appState <- liftIO appStateRef + return $ case appState ^. playState . scenarioState . gameState . winCondition of + WinConditions _winState oc -> T.pack $ renderGoalsGraph oc + _ -> mempty + +uiGoalHandler :: IO AppState -> Handler GoalTracking uiGoalHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - return $ appState ^. uiState . uiGameplay . uiGoal . goalsContent + appState <- liftIO appStateRef + return $ appState ^. playState . scenarioState . uiGameplay . uiDialogs . uiGoal . goalsContent -goalsHandler :: ReadableIORef AppState -> Handler WinCondition +goalsHandler :: IO AppState -> Handler WinCondition goalsHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - return $ appState ^. gameState . winCondition + appState <- liftIO appStateRef + return $ appState ^. playState . scenarioState . gameState . winCondition -recogLogHandler :: ReadableIORef AppState -> Handler [SearchLog EntityName] +deriving instance ToJSON (Navigation (M.Map SubworldName) Location) + +instance SD.ToSample (Navigation (M.Map SubworldName) Location) where + toSamples _ = SD.noSamples + +navigationHandler :: IO AppState -> Handler (Navigation (M.Map SubworldName) Location) +navigationHandler appStateRef = do + appState <- liftIO appStateRef + return $ appState ^. playState . scenarioState . gameState . landscape . worldNavigation + +recogLogHandler :: IO AppState -> Handler [SearchLog EntityName] recogLogHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) + appState <- liftIO appStateRef return $ map (fmap (view entityName)) $ - appState ^. gameState . discovery . structureRecognition . recognitionLog + appState ^. playState . scenarioState . gameState . discovery . structureRecognition . recognitionLog -recogFoundHandler :: ReadableIORef AppState -> Handler [StructureLocation] +recogFoundHandler :: IO AppState -> Handler [StructureLocation] recogFoundHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - let registry = appState ^. gameState . discovery . structureRecognition . foundStructures + appState <- liftIO appStateRef + let registry = appState ^. playState . scenarioState . gameState . discovery . structureRecognition . foundStructures return . map (uncurry StructureLocation) . concatMap (\(x, ys) -> map (x,) $ NE.toList ys) @@ -236,35 +264,66 @@ into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ t Left x -> x -codeRunHandler :: BChan AppEvent -> Text -> Handler Text +{- Note [How to stream back responses as we get results] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Servant has a builtin simple streaming: +https://docs.servant.dev/en/stable/cookbook/basic-streaming/Streaming.html + +What we need is to: +1. run IO with 'Effect' +2. send the result with 'Yield' +3. if we are done 'Stop' +4. otherwise continue recursively + +With the endpoint type 'StreamGet NewlineFraming JSON', servant will send each +result as a JSON on a separate line. That is not a valid JSON document, but +it's commonly used because it works well with line-oriented tools. + +This gives the user an immediate feedback (did the code parse) and would +be well suited for streaming large collections of data like the logs +while consuming constant memory. +-} + +codeRunHandler :: EventChannel -> Text -> Handler (S.SourceT IO WebInvocationState) codeRunHandler chan contents = do - liftIO . writeBChan chan . Web $ RunWebCode contents - return $ T.pack "Sent\n" + replyVar <- liftIO newEmptyMVar + let putReplyForce r = do + void $ tryTakeMVar replyVar + putMVar replyVar r + liftIO . chan . Web $ RunWebCode contents putReplyForce + -- See note [How to stream back responses as we get results] + let waitForReply = S.Effect $ do + reply <- takeMVar replyVar + return . S.Yield reply $ case reply of + InProgress -> waitForReply + _ -> S.Stop + return $ S.fromStepT waitForReply -pathsLogHandler :: ReadableIORef AppState -> Handler (RingBuffer CacheLogEntry) +pathsLogHandler :: IO AppState -> Handler (RingBuffer CacheLogEntry) pathsLogHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - pure $ appState ^. gameState . pathCaching . pathCachingLog + appState <- liftIO appStateRef + pure $ appState ^. playState . scenarioState . gameState . pathCaching . pathCachingLog -cmdMatrixHandler :: ReadableIORef AppState -> Handler CommandCatalog -cmdMatrixHandler _ = pure getCatalog +data ReplHistoryType = Current | Full -replHistHandler :: ReadableIORef AppState -> Handler [REPLHistItem] -replHistHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - let replHistorySeq = appState ^. uiState . uiGameplay . uiREPL . replHistory . replSeq - items = toList replHistorySeq - pure items +replHistHandler :: ReplHistoryType -> IO AppState -> Handler [REPLHistItem] +replHistHandler historyType appStateRef = do + appState <- liftIO appStateRef + let replHist = appState ^. playState . scenarioState . uiGameplay . uiREPL . replHistory + pure . toList $ case historyType of + Full -> replHist ^. replSeq + Current -> getSessionREPLHistoryItems replHist -mapViewHandler :: ReadableIORef AppState -> AreaDimensions -> Handler GridResponse +mapViewHandler :: IO AppState -> AreaDimensions -> Handler GridResponse mapViewHandler appStateRef areaSize = do - appState <- liftIO (readIORef appStateRef) - let maybeScenario = fst <$> appState ^. uiState . uiGameplay . scenarioRef + appState <- liftIO appStateRef + let maybeScenario = appState ^? playState . scenarioState . uiGameplay . scenarioRef . _Just . getScenario pure $ case maybeScenario of Just s -> GridResponse True . Just - . getCellGrid s (appState ^. gameState) + . getCellGrid s (appState ^. playState . scenarioState . gameState) $ areaSize Nothing -> GridResponse False Nothing @@ -275,20 +334,20 @@ -- | Simple result type to report errors from forked startup thread. data WebStartResult = WebStarted | WebStartError String +type EventChannel = AppEvent -> IO () + webMain :: Maybe (MVar WebStartResult) -> Warp.Port -> -- | Read-only reference to the application state. - ReadableIORef AppState -> + IO AppState -> -- | Writable channel to send events to the game - BChan AppEvent -> + EventChannel -> IO () webMain baton port appStateRef chan = catch (Warp.runSettings settings app) handleErr where settings = Warp.setPort port $ onReady Warp.defaultSettings - onReady = case baton of - Just mv -> Warp.setBeforeMainLoop $ putMVar mv WebStarted - Nothing -> id + onReady = applyJust $ Warp.setBeforeMainLoop . flip putMVar WebStarted <$> baton server :: Server ToplevelAPI server = @@ -324,9 +383,9 @@ startWebThread :: Maybe Warp.Port -> -- | Read-only reference to the application state. - ReadableIORef AppState -> + IO AppState -> -- | Writable channel to send events to the game - BChan AppEvent -> + EventChannel -> IO (Either String Warp.Port) -- User explicitly provided port '0': don't run the web server startWebThread (Just 0) _ _ = pure $ Left "The web port has been turned off." diff --git a/src/swarm-web/Swarm/Web/GraphRender.hs b/src/swarm-web/Swarm/Web/GraphRender.hs new file mode 100644 --- /dev/null +++ b/src/swarm-web/Swarm/Web/GraphRender.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Web.GraphRender where + +import Control.Lens ((^.), (^..)) +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Graph +import Text.Dot + +renderGoalsGraph :: ObjectiveCompletion -> String +renderGoalsGraph oc = + showDot nlg + where + edgeLookup = M.fromList $ map (\x@(_, b, _) -> (b, x)) edges + nlg = + netlistGraph + (\k -> maybe mempty (\(a, _, _) -> [("label", T.unpack $ fromMaybe "" $ a ^. objectiveId)]) $ M.lookup k edgeLookup) + (\k -> maybe mempty (\(_, _, c) -> c) $ M.lookup k edgeLookup) + ([(a, a) | (_, a, _) <- edges]) + + edges = makeGraphEdges objs + objs = oc ^.. allObjectives diff --git a/src/swarm-web/Swarm/Web/Worldview.hs b/src/swarm-web/Swarm/Web/Worldview.hs --- a/src/swarm-web/Swarm/Web/Worldview.hs +++ b/src/swarm-web/Swarm/Web/Worldview.hs @@ -6,12 +6,11 @@ import Control.Lens ((^.)) import Data.Aeson (ToJSON) import Data.Colour.Palette.BrewerSet (Kolor) -import Data.Colour.SRGB (RGB (..), sRGB24, sRGB24show) +import Data.Colour.SRGB (RGB (..), sRGB24) import Data.IntMap qualified as IM -import Data.Text qualified as T import GHC.Generics (Generic) import Servant.Docs qualified as SD -import Swarm.Game.Entity.Cosmetic (RGBColor, flattenBg) +import Swarm.Game.Entity.Cosmetic (RGBColor, flattenBg, fromHiFi) import Swarm.Game.Scenario (Scenario, scenarioCosmetics, scenarioLandscape) import Swarm.Game.Scenario.Style import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..)) @@ -44,7 +43,7 @@ asColour :: RGBColor -> Kolor asColour (RGB r g b) = sRGB24 r g b - asHex = HexColor . T.pack . sRGB24show . asColour + asHex = HexColor . asColour f = asHex . maybe (RGB 0 0 0) (flattenBg . fromHiFi) . getTerrainEntityColor aMap (indexGrid, encoding) = runEncoder $ f <$> dg diff --git a/swarm.cabal b/swarm.cabal --- a/swarm.cabal +++ b/swarm.cabal @@ -1,1005 +1,1400 @@ cabal-version: 3.6 name: swarm -version: 0.6.0.0 -synopsis: 2D resource gathering game with programmable robots -description: - Swarm is a 2D programming and resource gathering - game. Program your robots to explore the world and - collect resources, which in turn allows you to - build upgraded robots that can run more - interesting and complex programs. See the - - for more information and instructions on how to - play or contribute! - - == Module organization - For developers getting oriented, Swarm's modules are organized into - sublibraries. Roughly in order from inner to outer, they are: - - * swarm-util: miscellaneous utilities - * swarm-lang: parsing, typechecking, etc. for the Swarm language - * swarm-scenario: scenario descriptions, parsing, & processing - * swarm-engine: game simulation - * swarm-doc: generating documentation - * swarm-tui: textual user interface - * swarm-web: web interface - * swarm: the swarm executable - - <> - - See the [Swarm module guide](https://github.com/swarm-game/swarm/wiki/Module-guide) - for a more in-depth guide to the codebase. - -license: BSD-3-Clause -license-file: LICENSE -author: Brent Yorgey -maintainer: byorgey@gmail.com -bug-reports: https://github.com/swarm-game/swarm/issues -copyright: Brent Yorgey 2021 -category: Game -tested-with: ghc ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 -extra-source-files: - CHANGELOG.md - editors/emacs/*.el - editors/vim/*.lua - editors/vim/*.vim - editors/vscode/syntaxes/*.yaml - example/*.sw - -extra-doc-files: docs/image/sublibrary-graph.svg -data-dir: data/ -data-files: - *.txt - *.yaml - scenarios/**/*.sw - scenarios/**/*.txt - scenarios/**/*.yaml - test/language-snippets/**/*.sw - test/standalone-topography/*.png - test/standalone-topography/*.yaml - worlds/*.world - -source-repository head - type: git - location: git://github.com/swarm-game/swarm.git - -flag ci - description: Make warnings error - default: False - manual: True - -common common - if flag(ci) - ghc-options: -Werror - ghc-options: - -Wall - -Wcompat - -Widentities - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wno-star-is-type - -Wpartial-fields - - default-language: Haskell2010 - -common stan-config - ghc-options: - -fwrite-ide-info - -hiedir=.hie - --- Harmless extensions from GHC2021 -common ghc2021-extensions - ghc-options: - -Wprepositive-qualified-module - -Wunused-packages - - default-extensions: - -- Note we warn on prequalified - -- Not GHC2021, but until we get \cases we use \case a lot - BangPatterns - DeriveAnyClass - DeriveDataTypeable - DeriveFunctor - DeriveGeneric - DeriveTraversable - ExplicitForAll - FlexibleContexts - FlexibleInstances - GADTSyntax - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - NumericUnderscores - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeOperators - -library swarm-lang - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-lang - exposed-modules: - Swarm.Effect.Unify - Swarm.Effect.Unify.Common - Swarm.Effect.Unify.Fast - Swarm.Effect.Unify.Naive - Swarm.Language.Capability - Swarm.Language.Context - Swarm.Language.Elaborate - Swarm.Language.Format - Swarm.Language.JSON - Swarm.Language.Key - Swarm.Language.Kindcheck - Swarm.Language.LSP - Swarm.Language.LSP.Hover - Swarm.Language.LSP.VarUsage - Swarm.Language.Parser - Swarm.Language.Parser.Comment - Swarm.Language.Parser.Core - Swarm.Language.Parser.Lex - Swarm.Language.Parser.QQ - Swarm.Language.Parser.Record - Swarm.Language.Parser.Term - Swarm.Language.Parser.Type - Swarm.Language.Parser.Util - Swarm.Language.Pipeline - Swarm.Language.Pipeline.QQ - Swarm.Language.Pretty - Swarm.Language.Requirements - Swarm.Language.Requirements.Analysis - Swarm.Language.Requirements.Type - Swarm.Language.Syntax - Swarm.Language.Syntax.AST - Swarm.Language.Syntax.CommandMetadata - Swarm.Language.Syntax.Comments - Swarm.Language.Syntax.Constants - Swarm.Language.Syntax.Loc - Swarm.Language.Syntax.Pattern - Swarm.Language.Syntax.Util - Swarm.Language.Text.Markdown - Swarm.Language.Typecheck - Swarm.Language.Typed - Swarm.Language.Types - Swarm.Language.Value - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - aeson, - base, - commonmark >=0.2 && <0.3, - commonmark-extensions >=0.2 && <0.3, - containers, - data-fix >=0.3 && <0.4, - deriving-compat >=0.6 && <0.7, - extra, - free >=5.2 && <5.3, - fused-effects, - hashable, - lens, - lsp >=2.4 && <2.7, - megaparsec, - mtl, - parser-combinators, - prettyprinter, - split, - syb >=0.7 && <0.8, - template-haskell, - terminal-size >=0.3 && <1.0, - text, - text-rope >=0.2 && <0.3, - unicode-show >=0.1 && <0.2, - vector, - vty, - witch, - yaml, - - build-depends: swarm:swarm-util - hs-source-dirs: src/swarm-lang - default-language: Haskell2010 - default-extensions: - -- Avoid unexpected unevaluated thunk buildup - -- See discussion in #415 - StrictData - -library swarm-topography - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-topography - exposed-modules: - Swarm.Game.Location - Swarm.Game.Scenario.Topography.Area - Swarm.Game.Scenario.Topography.Grid - Swarm.Game.Scenario.Topography.Navigation.Waypoint - Swarm.Game.Scenario.Topography.Placement - Swarm.Game.Scenario.Topography.ProtoCell - Swarm.Game.Scenario.Topography.Rasterize - Swarm.Game.Scenario.Topography.Structure - Swarm.Game.Scenario.Topography.Structure.Assembly - Swarm.Game.Scenario.Topography.Structure.Overlay - Swarm.Game.Scenario.Topography.Structure.Recognition - Swarm.Game.Scenario.Topography.Structure.Recognition.Log - Swarm.Game.Scenario.Topography.Structure.Recognition.Prep - Swarm.Game.Scenario.Topography.Structure.Recognition.Registry - Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry - Swarm.Game.Scenario.Topography.Structure.Recognition.Type - Swarm.Game.Universe - Swarm.Game.World.Coords - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - AhoCorasick >=0.0.4 && <0.0.5, - JuicyPixels >=3.3 && <3.4, - aeson >=2.2 && <2.3, - array, - base >=4.14 && <4.20, - containers >=0.6.2 && <0.8, - extra >=1.7 && <1.8, - hashable, - lens, - linear >=1.21.6 && <1.24, - nonempty-containers >=0.3.4 && <0.3.5, - servant-docs >=0.12 && <0.14, - text >=1.2.4 && <2.2, - unordered-containers, - vector >=0.12 && <0.14, - yaml >=0.11 && <0.11.12.0, - - build-depends: - swarm:swarm-util - - hs-source-dirs: src/swarm-topography - default-language: Haskell2010 - default-extensions: - -- Avoid unexpected unevaluated thunk buildup - -- See discussion in #415 - StrictData - -library swarm-scenario - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-scenario - exposed-modules: - Swarm.Constant - Swarm.Game.Achievement.Definitions - Swarm.Game.Device - Swarm.Game.Display - Swarm.Game.Entity - Swarm.Game.Entity.Cosmetic - Swarm.Game.Entity.Cosmetic.Assignment - Swarm.Game.Failure - Swarm.Game.Ingredients - Swarm.Game.Land - Swarm.Game.Recipe - Swarm.Game.ResourceLoading - Swarm.Game.Robot - Swarm.Game.Robot.Walk - Swarm.Game.Scenario - Swarm.Game.Scenario.Objective - Swarm.Game.Scenario.Objective.Graph - Swarm.Game.Scenario.Objective.Logic - Swarm.Game.Scenario.Objective.Validation - Swarm.Game.Scenario.RobotLookup - Swarm.Game.Scenario.Style - Swarm.Game.Scenario.Topography.Cell - Swarm.Game.Scenario.Topography.Center - Swarm.Game.Scenario.Topography.EntityFacade - Swarm.Game.Scenario.Topography.Navigation.Portal - Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute - Swarm.Game.Scenario.Topography.WorldDescription - Swarm.Game.Scenario.Topography.WorldPalette - Swarm.Game.State.Config - Swarm.Game.State.Landscape - Swarm.Game.Terrain - Swarm.Game.World - Swarm.Game.World.Abstract - Swarm.Game.World.Compile - Swarm.Game.World.Eval - Swarm.Game.World.Gen - Swarm.Game.World.Interpret - Swarm.Game.World.Load - Swarm.Game.World.Modify - Swarm.Game.World.Parse - Swarm.Game.World.Render - Swarm.Game.World.Syntax - Swarm.Game.World.Typecheck - Swarm.Util.Content - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - JuicyPixels >=3.3 && <3.4, - aeson >=2.2 && <2.3, - array >=0.5.4 && <0.6, - base >=4.14 && <4.20, - boolexpr >=0.2 && <0.3, - bytestring >=0.10 && <0.13, - clock >=0.8.2 && <0.9, - colour >=2.3.6 && <2.4, - containers >=0.6.2 && <0.8, - directory >=1.3 && <1.4, - either >=5.0 && <5.1, - extra >=1.7 && <1.8, - filepath >=1.4 && <1.5, - fused-effects >=1.1.1.1 && <1.2, - hashable >=1.3.4 && <1.5, - hsnoise >=0.0.3 && <0.1, - lens >=4.19 && <5.4, - linear >=1.21.6 && <1.24, - megaparsec >=9.6.1 && <9.7, - murmur3 >=1.0.4 && <1.1, - palette >=0.3 && <0.4, - parser-combinators >=1.2 && <1.4, - prettyprinter >=1.7.0 && <1.8, - random >=1.2.0 && <1.3, - servant-docs >=0.12 && <0.14, - simple-enumeration >=0.2 && <0.3, - tagged >=0.8 && <0.9, - text >=1.2.4 && <2.2, - vector >=0.12 && <0.14, - vty >=6.1 && <6.3, - witch >=1.1.1.0 && <1.3, - yaml >=0.11 && <0.11.12.0, - - build-depends: - swarm:swarm-lang, - swarm:swarm-topography, - swarm:swarm-util, - - hs-source-dirs: src/swarm-scenario - default-language: Haskell2010 - default-extensions: - -- Avoid unexpected unevaluated thunk buildup - -- See discussion in #415 - StrictData - -library swarm-engine - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-engine - exposed-modules: - Swarm.Effect - Swarm.Effect.Time - Swarm.Game.Achievement.Attainment - Swarm.Game.Achievement.Description - Swarm.Game.Achievement.Persistence - Swarm.Game.CESK - Swarm.Game.Exception - Swarm.Game.Robot.Activity - Swarm.Game.Robot.Concrete - Swarm.Game.Scenario.Objective.WinCheck - Swarm.Game.Scenario.Scoring.Best - Swarm.Game.Scenario.Scoring.CodeSize - Swarm.Game.Scenario.Scoring.ConcreteMetrics - Swarm.Game.Scenario.Scoring.GenericMetrics - Swarm.Game.Scenario.Status - Swarm.Game.Scenario.Topography.Navigation.Util - Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking - Swarm.Game.ScenarioInfo - Swarm.Game.State - Swarm.Game.State.Initialize - Swarm.Game.State.Robot - Swarm.Game.State.Runtime - Swarm.Game.State.Substate - Swarm.Game.Step - Swarm.Game.Step.Arithmetic - Swarm.Game.Step.Combustion - Swarm.Game.Step.Const - Swarm.Game.Step.Flood - Swarm.Game.Step.Path.Cache - Swarm.Game.Step.Path.Cache.DistanceLimit - Swarm.Game.Step.Path.Finding - Swarm.Game.Step.Path.Type - Swarm.Game.Step.Path.Walkability - Swarm.Game.Step.RobotStepState - Swarm.Game.Step.Util - Swarm.Game.Step.Util.Command - Swarm.Game.Step.Util.Inspect - Swarm.Game.Step.Validate - Swarm.Game.Tick - Swarm.Game.Value - Swarm.Log - Swarm.Version - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - AhoCorasick >=0.0.4 && <0.0.5, - SHA >=1.6.4 && <1.6.5, - aeson >=2.2 && <2.3, - array >=0.5.4 && <0.6, - astar >=0.3 && <0.3.1, - base >=4.14 && <4.20, - boolexpr >=0.2 && <0.3, - bytestring, - clock >=0.8.2 && <0.9, - containers >=0.6.2 && <0.8, - directory >=1.3 && <1.4, - extra >=1.7 && <1.8, - filepath >=1.4 && <1.5, - fused-effects >=1.1.1.1 && <1.2, - fused-effects-lens >=1.2.0.1 && <1.3, - githash, - hashable >=1.3.4 && <1.5, - http-client >=0.7 && <0.8, - http-client-tls >=0.3 && <0.4, - http-types >=0.12 && <0.13, - lens >=4.19 && <5.4, - linear >=1.21.6 && <1.24, - megaparsec >=9.6 && <9.7, - mtl >=2.2.2 && <2.4, - nonempty-containers >=0.3.4 && <0.3.5, - prettyprinter >=1.7.0 && <1.8, - random >=1.2.0 && <1.3, - servant-docs >=0.12 && <0.14, - text >=1.2.4 && <2.2, - time >=1.9 && <1.15, - transformers >=0.5 && <0.7, - unordered-containers >=0.2.14 && <0.3, - warp, - witch >=1.1.1.0 && <1.3, - yaml >=0.11 && <0.11.12.0, - - build-depends: - swarm:swarm-lang, - swarm:swarm-scenario, - swarm:swarm-topography, - swarm:swarm-util, - - hs-source-dirs: src/swarm-engine - default-language: Haskell2010 - default-extensions: - -- Avoid unexpected unevaluated thunk buildup - -- See discussion in #415 - StrictData - -library swarm-web - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-web - exposed-modules: - Swarm.Web - Swarm.Web.Worldview - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - aeson, - base, - brick, - bytestring, - colour, - commonmark, - containers, - http-types, - lens, - nonempty-containers, - palette, - servant-docs, - servant-server >=0.19 && <0.21, - text, - wai >=3.2 && <3.3, - wai-app-static >=3.1.8 && <3.2, - warp, - witch, - - build-depends: - swarm:swarm-doc, - swarm:swarm-engine, - swarm:swarm-lang, - swarm:swarm-scenario, - swarm:swarm-topography, - swarm:swarm-tui, - swarm:swarm-util, - - hs-source-dirs: src/swarm-web - default-language: Haskell2010 - default-extensions: - -- Avoid unexpected unevaluated thunk buildup - -- See discussion in #415 - StrictData - -library swarm-tournament - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-tournament - exposed-modules: - Swarm.Web.Auth - Swarm.Web.Tournament - Swarm.Web.Tournament.Database.Query - Swarm.Web.Tournament.Type - Swarm.Web.Tournament.Validate - Swarm.Web.Tournament.Validate.FailureMode - Swarm.Web.Tournament.Validate.Upload - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - SHA, - aeson, - base, - bytestring, - commonmark, - containers, - cookie, - exceptions, - extra, - fused-effects, - http-client, - http-client-tls >=0.3.6.3 && <0.3.7, - http-types, - lens, - mtl, - servant-docs, - servant-multipart, - servant-server >=0.19 && <0.21, - sqlite-simple >=0.4.19.0 && <0.4.20, - text, - time, - transformers, - utf8-string, - wai >=3.2 && <3.3, - wai-app-static >=3.1.8 && <3.2, - wai-extra, - warp, - yaml, - - build-depends: - swarm:swarm-engine, - swarm:swarm-lang, - swarm:swarm-scenario, - swarm:swarm-util, - - hs-source-dirs: src/swarm-tournament - default-language: Haskell2010 - -library swarm-util - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-util - exposed-modules: - Control.Carrier.Accum.FixedStrict - Data.BoolExpr.Simplify - Swarm.Language.Syntax.Direction - Swarm.Util - Swarm.Util.Effect - Swarm.Util.Erasable - Swarm.Util.JSON - Swarm.Util.Lens - Swarm.Util.OccurrenceEncoder - Swarm.Util.ReadableIORef - Swarm.Util.RingBuffer - Swarm.Util.UnitInterval - Swarm.Util.WindowedCounter - Swarm.Util.Yaml - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - aeson >=2.2 && <2.3, - base >=4.14 && <4.20, - boolexpr >=0.2 && <0.3, - clock >=0.8.2 && <0.9, - containers >=0.6.2 && <0.8, - directory >=1.3 && <1.4, - either >=5.0 && <5.1, - extra >=1.7 && <1.8, - filepath >=1.4 && <1.5, - fused-effects >=1.1.1.1 && <1.2, - hashable >=1.3.4 && <1.5, - lens >=4.19 && <5.4, - minimorph >=0.3 && <0.4, - mtl >=2.2.2 && <2.4, - servant-docs >=0.12 && <0.14, - template-haskell >=2.16 && <2.22, - text >=1.2.4 && <2.2, - transformers >=0.5 && <0.7, - vector >=0.12 && <0.14, - witch >=1.1.1.0 && <1.3, - witherable >=0.4 && <0.5, - yaml >=0.11 && <0.11.12.0, - - hs-source-dirs: src/swarm-util - default-language: Haskell2010 - default-extensions: - -- Avoid unexpected unevaluated thunk buildup - -- See discussion in #415 - StrictData - -library swarm-doc - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-doc - exposed-modules: - Swarm.Doc.Command - Swarm.Doc.Gen - Swarm.Doc.Keyword - Swarm.Doc.Pedagogy - Swarm.Doc.Schema.Arrangement - Swarm.Doc.Schema.Parse - Swarm.Doc.Schema.Refined - Swarm.Doc.Schema.Render - Swarm.Doc.Schema.SchemaType - Swarm.Doc.Util - Swarm.Doc.Wiki.Cheatsheet - Swarm.Doc.Wiki.Matrix - Swarm.Doc.Wiki.Util - - build-depends: - aeson >=2.2 && <2.3, - base >=4.14 && <4.20, - containers >=0.6.2 && <0.8, - directory >=1.3 && <1.4, - dotgen >=0.4 && <0.5, - extra >=1.7 && <1.8, - filepath >=1.4 && <1.5, - fused-effects >=1.1.1.1 && <1.2, - lens >=4.19 && <5.4, - mtl >=2.2.2 && <2.4, - pandoc >=3.0 && <3.2, - pandoc-types >=1.23 && <1.24, - scientific >=0.3.6 && <0.3.8, - servant-docs >=0.12 && <0.14, - text >=1.2.4 && <2.2, - transformers >=0.5 && <0.7, - vector >=0.12 && <0.14, - - build-depends: - swarm:swarm-engine, - swarm:swarm-lang, - swarm:swarm-scenario, - swarm:swarm-util, - - hs-source-dirs: src/swarm-doc - default-language: Haskell2010 - default-extensions: - -- Avoid unexpected unevaluated thunk buildup - -- See discussion in #415 - StrictData - -library swarm-tui - import: stan-config, common, ghc2021-extensions - visibility: public - -- cabal-gild: discover src/swarm-tui - exposed-modules: - Swarm.TUI.Border - Swarm.TUI.Controller - Swarm.TUI.Controller.EventHandlers - Swarm.TUI.Controller.EventHandlers.Frame - Swarm.TUI.Controller.EventHandlers.Main - Swarm.TUI.Controller.EventHandlers.REPL - Swarm.TUI.Controller.EventHandlers.Robot - Swarm.TUI.Controller.EventHandlers.World - Swarm.TUI.Controller.SaveScenario - Swarm.TUI.Controller.UpdateUI - Swarm.TUI.Controller.Util - Swarm.TUI.Editor.Controller - Swarm.TUI.Editor.Json - Swarm.TUI.Editor.Masking - Swarm.TUI.Editor.Model - Swarm.TUI.Editor.Palette - Swarm.TUI.Editor.Util - Swarm.TUI.Editor.View - Swarm.TUI.Inventory.Sorting - Swarm.TUI.Launch.Controller - Swarm.TUI.Launch.Model - Swarm.TUI.Launch.Prep - Swarm.TUI.Launch.View - Swarm.TUI.List - Swarm.TUI.Model - Swarm.TUI.Model.Achievements - Swarm.TUI.Model.Event - Swarm.TUI.Model.Goal - Swarm.TUI.Model.KeyBindings - Swarm.TUI.Model.Menu - Swarm.TUI.Model.Name - Swarm.TUI.Model.Popup - Swarm.TUI.Model.Repl - Swarm.TUI.Model.StateUpdate - Swarm.TUI.Model.Structure - Swarm.TUI.Model.UI - Swarm.TUI.Panel - Swarm.TUI.View - Swarm.TUI.View.Achievement - Swarm.TUI.View.Attribute.Attr - Swarm.TUI.View.Attribute.CustomStyling - Swarm.TUI.View.Attribute.Util - Swarm.TUI.View.CellDisplay - Swarm.TUI.View.Logo - Swarm.TUI.View.Objective - Swarm.TUI.View.Popup - Swarm.TUI.View.Structure - Swarm.TUI.View.Util - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - aeson >=2.2 && <2.3, - array >=0.5.4 && <0.6, - base >=4.14 && <4.20, - brick >=2.1.1 && <2.5, - brick-list-skip >=0.1.1.2 && <0.2, - bytestring >=0.10 && <0.13, - clock >=0.8.2 && <0.9, - colour >=2.3.6 && <2.4, - containers >=0.6.2 && <0.8, - extra >=1.7 && <1.8, - filepath >=1.4 && <1.5, - fused-effects >=1.1.1.1 && <1.2, - fuzzy >=0.1 && <0.2, - githash >=0.1.6 && <0.2, - lens >=4.19 && <5.4, - linear >=1.21.6 && <1.24, - mtl >=2.2.2 && <2.4, - murmur3 >=1.0.4 && <1.1, - natural-sort >=0.1.2 && <0.2, - nonempty-containers >=0.3.4 && <0.3.5, - palette >=0.3 && <0.4, - servant-docs >=0.12 && <0.14, - split >=0.2.3 && <0.3, - tagged >=0.8 && <0.9, - text >=1.2.4 && <2.2, - text-zipper >=0.10 && <0.14, - time >=1.9 && <1.15, - transformers >=0.5 && <0.7, - vector >=0.12 && <0.14, - vty >=6.1 && <6.3, - warp >=3.2 && <3.5, - witch >=1.1.1.0 && <1.3, - word-wrap >=0.5 && <0.6, - yaml >=0.11 && <0.11.12.0, - - build-depends: - swarm:swarm-engine, - swarm:swarm-lang, - swarm:swarm-scenario, - swarm:swarm-topography, - swarm:swarm-util, - - hs-source-dirs: src/swarm-tui - default-language: Haskell2010 - default-extensions: - -- Avoid unexpected unevaluated thunk buildup - -- See discussion in #415 - StrictData - -executable swarm - import: stan-config, common - main-is: Main.hs - other-modules: Swarm.App - build-depends: - -- Imports shared with the library don't need bounds - base, - brick, - fused-effects, - githash >=0.1.6 && <0.2, - lens, - optparse-applicative >=0.16 && <0.19, - swarm:swarm-engine, - swarm:swarm-lang, - swarm:swarm-scenario, - swarm:swarm-tui, - swarm:swarm-util, - swarm:swarm-web, - text, - vty, - vty-crossplatform >=0.4 && <0.5, - - hs-source-dirs: app - default-language: Haskell2010 - ghc-options: -threaded - default-extensions: ImportQualifiedPost - -executable swarm-scene - import: stan-config, common, ghc2021-extensions - main-is: Main.hs - build-depends: - base, - optparse-applicative >=0.16 && <0.19, - - build-depends: - swarm:swarm-scenario, - swarm:swarm-topography, - - hs-source-dirs: app/scene - default-language: Haskell2010 - ghc-options: -threaded - default-extensions: ImportQualifiedPost - -executable swarm-docs - import: stan-config, common, ghc2021-extensions - main-is: Main.hs - other-modules: - build-depends: - -- Imports shared with the library don't need bounds - base, - optparse-applicative >=0.16 && <0.19, - swarm:swarm-doc, - text, - - hs-source-dirs: app/doc - default-language: Haskell2010 - ghc-options: -threaded - default-extensions: ImportQualifiedPost - -executable swarm-host-tournament - import: stan-config, common, ghc2021-extensions - main-is: Main.hs - build-depends: - base, - optparse-applicative >=0.16 && <0.19, - sqlite-simple, - transformers, - warp, - yaml, - - build-depends: - swarm:swarm-engine, - swarm:swarm-tournament, - - hs-source-dirs: app/tournament - default-language: Haskell2010 - ghc-options: -threaded - default-extensions: ImportQualifiedPost - -test-suite swarm-unit - import: stan-config, common, ghc2021-extensions - main-is: Main.hs - type: exitcode-stdio-1.0 - other-modules: - TestBoolExpr - TestCommand - TestEval - TestInventory - TestLSP - TestLanguagePipeline - TestNotification - TestOrdering - TestOverlay - TestParse - TestPedagogy - TestPretty - TestRepl - TestRequirements - TestScoring - TestUtil - - build-depends: - -- Imports shared with the library don't need bounds - QuickCheck >=2.14 && <2.16, - aeson, - base, - boolexpr, - containers, - data-fix, - filepath, - hashable, - lens, - megaparsec, - mtl, - tasty >=0.10 && <1.6, - tasty-hunit >=0.10 && <0.11, - tasty-quickcheck >=0.10 && <0.11, - text, - time, - vty, - witch, - - build-depends: - swarm:swarm-doc, - swarm:swarm-engine, - swarm:swarm-lang, - swarm:swarm-scenario, - swarm:swarm-topography, - swarm:swarm-tui, - swarm:swarm-util, - - hs-source-dirs: test/unit - default-language: Haskell2010 - ghc-options: -threaded - -test-suite swarm-integration - import: stan-config, common, ghc2021-extensions - main-is: Main.hs - other-modules: TestRecipeCoverage - type: exitcode-stdio-1.0 - build-depends: - -- Imports shared with the library don't need bounds - base, - containers, - filepath, - fused-effects, - lens, - mtl, - tasty >=0.10 && <1.6, - tasty-expected-failure >=0.12 && <0.13, - tasty-hunit >=0.10 && <0.11, - text, - witch, - yaml, - - build-depends: - swarm:swarm-doc, - swarm:swarm-engine, - swarm:swarm-lang, - swarm:swarm-scenario, - swarm:swarm-tui, - swarm:swarm-util, - - hs-source-dirs: test/integration - default-language: Haskell2010 - ghc-options: -threaded - -test-suite tournament-host - import: stan-config, common, ghc2021-extensions - main-is: Main.hs - type: exitcode-stdio-1.0 - build-depends: - SHA, - base, - bytestring, - http-client, - http-types, - nonempty-containers, - tasty, - tasty-hunit, - warp, - - build-depends: - swarm:swarm-engine, - swarm:swarm-tournament, - - hs-source-dirs: test/tournament-host - default-language: Haskell2010 - ghc-options: -threaded - -test-suite standalone-topography - import: stan-config, common, ghc2021-extensions - main-is: Main.hs - type: exitcode-stdio-1.0 - other-modules: - Lib - - other-modules: Paths_swarm - autogen-modules: Paths_swarm - build-depends: - JuicyPixels >=3.3 && <3.4, - MissingH, - aeson, - base, - bytestring, - filepath, - tasty, - tasty-hunit, - yaml, - - build-depends: - swarm:swarm-topography, - swarm:swarm-util, - - hs-source-dirs: test/standalone-topography/src - default-language: Haskell2010 - ghc-options: -threaded - -benchmark benchmark - import: stan-config, common, ghc2021-extensions - main-is: Benchmark.hs - hs-source-dirs: test/bench - type: exitcode-stdio-1.0 - build-depends: - base, - containers, - extra, - lens, - mtl, - tasty-bench >=0.3.1 && <0.4, - text, - - build-depends: +version: 0.7.0.0 +synopsis: 2D resource gathering game with programmable robots +description: + Swarm is a 2D programming and resource gathering + game. Program your robots to explore the world and + collect resources, which in turn allows you to + build upgraded robots that can run more + interesting and complex programs. See the + + for more information and instructions on how to + play or contribute! + + == Module organization + For developers getting oriented, Swarm's modules are organized into + sublibraries. Roughly in order from inner to outer, they are: + + * swarm-util: miscellaneous utilities + * swarm-lang: parsing, typechecking, etc. for the Swarm language + * swarm-topography: working with location in 2D (sub-)worlds + * swarm-scenario: scenario descriptions, parsing, & processing + * swarm-engine: game simulation + * swarm-doc: generating documentation + * swarm-tui: textual user interface + * swarm-web: web interface + * swarm: the swarm executable + + <> + + See the [Swarm module guide](https://github.com/swarm-game/swarm/wiki/Module-guide) + for a more in-depth guide to the codebase. + +license: BSD-3-Clause +license-file: LICENSE +author: Brent Yorgey +maintainer: byorgey@gmail.com +bug-reports: https://github.com/swarm-game/swarm/issues +copyright: Brent Yorgey 2021 +category: Game +tested-with: ghc ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 +extra-doc-files: + CHANGELOG.md + +extra-source-files: + editors/emacs/*.el + editors/vim/*.lua + editors/vim/*.vim + editors/vscode/syntaxes/*.yaml + example/*.sw + +extra-doc-files: docs/image/sublibrary-graph.svg +data-dir: data/ +data-files: + *.txt + *.yaml + scenarios/**/*.sw + scenarios/**/*.txt + scenarios/**/*.yaml + test/language-snippets/**/*.sw + test/saves/*.yaml + test/standalone-topography/*.png + test/standalone-topography/*.yaml + worlds/*.world + +source-repository head + type: git + location: https://github.com/swarm-game/swarm.git + +flag ci + description: Make warnings error + default: False + manual: True + +common common + if flag(ci) + ghc-options: -Werror + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wno-star-is-type + -Wpartial-fields + + default-language: Haskell2010 + +common stan-config + ghc-options: + -fwrite-ide-info + +-- Harmless extensions from GHC2021 +common ghc2021-extensions + ghc-options: + -Wprepositive-qualified-module + -Wunused-packages + + default-extensions: + -- Note we warn on prequalified + -- Not GHC2021, but until we get \cases we use \case a lot + BangPatterns + DeriveAnyClass + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTSyntax + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NumericUnderscores + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + +common base + build-depends: base >=4.18 && <4.22 + +common AhoCorasick + build-depends: AhoCorasick >=0.0.4 && <0.0.5 + +common JuicyPixels + build-depends: JuicyPixels >=3.3 && <3.4 + +common QuickCheck + build-depends: QuickCheck >=2.14 && <2.16 + +common SHA + build-depends: SHA >=1.6.4 && <1.6.5 + +common aeson + build-depends: aeson >=2.2 && <2.3 + +common array + build-depends: array >=0.5.4 && <0.6 + +common astar + build-depends: astar >=0.3 && <0.3.1 + +common boolexpr + build-depends: boolexpr >=0.2 && <0.3 + +common brick + build-depends: brick >=2.1.1 && <2.9 + +common brick-list-skip + build-depends: brick-list-skip >=0.1.1.2 && <0.2 + +common brick-tabular-list + build-depends: brick-tabular-list >=2.2.0 && <2.2.1 + +common bytestring + build-depends: bytestring >=0.10 && <0.13 + +common clock + build-depends: clock >=0.8.2 && <0.9 + +common colour + build-depends: colour >=2.3.6 && <2.4 + +common commonmark + build-depends: commonmark >=0.2 && <0.3 + +common commonmark-extensions + build-depends: commonmark-extensions >=0.2 && <0.3 + +common containers + build-depends: containers >=0.6.2 && <0.8 + +common cookie + build-depends: cookie >=0.4 && <1.0 + +common data-fix + build-depends: data-fix >=0.3 && <0.4 + +common deriving-compat + build-depends: deriving-compat >=0.6 && <0.7 + +common directory + build-depends: directory >=1.3 && <1.4 + +common dotgen + build-depends: dotgen >=0.4 && <0.5 + +common either + build-depends: either >=5.0 && <5.1 + +common exceptions + build-depends: exceptions >=0.10 && <0.11 + +common extra + build-depends: extra >=1.8 && <1.9 + +common filepath + build-depends: filepath >=1.4 && <1.6 + +common free + build-depends: free >=5.2 && <5.3 + +common fused-effects + build-depends: fused-effects >=1.1.2.5 && <1.2 + +common fused-effects-lens + build-depends: fused-effects-lens >=1.2.0.1 && <1.3 + +common fuzzy + build-depends: fuzzy >=0.1 && <0.2 + +common generic-data + build-depends: generic-data >=1.0 && <1.2 + +common githash + build-depends: githash >=0.1.6 && <0.2 + +common hashable + build-depends: hashable >=1.3.4 && <1.6 + +common hsnoise + build-depends: hsnoise >=0.0.3 && <0.1 + +common http-client + build-depends: http-client >=0.7 && <0.8 + +common http-client-tls + build-depends: http-client-tls >=0.3 && <0.4 + +common http-types + build-depends: http-types >=0.12 && <0.13 + +common lens + build-depends: lens >=4.19 && <5.4 + +common linear + build-depends: linear >=1.21.6 && <1.24 + +common lsp + build-depends: lsp >=2.4 && <2.8 + +common megaparsec + build-depends: megaparsec >=9.6.1 && <9.8 + +common minimorph + build-depends: minimorph >=0.3 && <0.4 + +common MissingH + build-depends: MissingH >=1.4 && <2 + +common monad-logger + build-depends: monad-logger >=0.3.0 && <0.4.0 + +common monoidmap + build-depends: monoidmap >=0.0.3.0 && <0.1 + +common monoidmap-aeson + build-depends: monoidmap-aeson >=0.0.0.1 && <0.1 + +common mtl + build-depends: mtl >=2.2.2 && <2.4 + +common murmur3 + build-depends: murmur3 >=1.0.4 && <1.1 + +common natural-sort + build-depends: natural-sort >=0.1.2 && <0.2 + +common nonempty-containers + build-depends: nonempty-containers >=0.3.4 && <0.3.5 + +common optparse-applicative + build-depends: optparse-applicative >=0.16 && <0.19 + +common ordered-containers + build-depends: ordered-containers >=0.2.4 && <0.2.5 + +common palette + build-depends: palette >=0.3 && <0.4 + +common pandoc + build-depends: pandoc >=3.0 && <3.7 + +common pandoc-types + build-depends: pandoc-types >=1.23 && <1.24 + +common parser-combinators + build-depends: parser-combinators >=1.2 && <1.4 + +common prettyprinter + build-depends: prettyprinter >=1.7.0 && <1.8 + +common quickcheck-instances + build-depends: quickcheck-instances >=0.3.17 && <0.4 + +common random + build-depends: random >=1.2.0 && <1.4 + +common scientific + build-depends: scientific >=0.3.6 && <0.3.9 + +common servant + build-depends: servant >=0.19 && <0.22 + +common servant-docs + build-depends: servant-docs >=0.12 && <0.14 + +common servant-multipart + build-depends: servant-multipart >=0.11 && <1.0 + +common servant-JuicyPixels + build-depends: servant-JuicyPixels >=0.3.1 && <0.3.2 + +common servant-server + build-depends: servant-server >=0.19 && <0.22 + +common split + build-depends: split >=0.2.3 && <0.3 + +common sqlite-simple + build-depends: sqlite-simple >=0.4.19.0 && <0.4.20 + +common syb + build-depends: syb >=0.7 && <0.8 + +common tagged + build-depends: tagged >=0.8 && <0.9 + +common tasty + build-depends: tasty >=0.10 && <1.6 + +common tasty-bench + build-depends: tasty-bench >=0.3.1 && <0.5 + +common tasty-expected-failure + build-depends: tasty-expected-failure >=0.12 && <0.13 + +common tasty-hunit + build-depends: tasty-hunit >=0.10 && <0.11 + +common tasty-quickcheck + build-depends: tasty-quickcheck >=0.10 && <0.12 + +common template-haskell + build-depends: template-haskell >=2.16 && <2.24 + +common terminal-size + build-depends: terminal-size >=0.3 && <1.0 + +common text + build-depends: text >=1.2.4 && <2.2 + +common text-rope + build-depends: text-rope >=0.2 && <0.4 + +common text-zipper + build-depends: text-zipper >=0.10 && <0.14 + +common time + build-depends: time >=1.9 && <1.15 + +common transformers + build-depends: transformers >=0.5 && <0.7 + +common unicode-show + build-depends: unicode-show >=0.1 && <0.2 + +common unordered-containers + build-depends: unordered-containers >=0.2.14 && <0.3 + +common utf8-string + build-depends: utf8-string >=1.0 && <2.0 + +common vector + build-depends: vector >=0.12 && <0.14 + +common vty + build-depends: vty >=6.1 && <6.5 + +common vty-crossplatform + build-depends: vty-crossplatform >=0.4 && <0.5 + +common wai + build-depends: wai >=3.2 && <3.3 + +common wai-app-static + build-depends: wai-app-static >=3.1.8 && <3.2 + +common wai-extra + build-depends: wai-extra >=3.1 && <3.2 + +common warp + build-depends: warp >=3.2 && <3.5 + +common witch + build-depends: witch >=1.1.1.0 && <1.4 + +common witherable + build-depends: witherable >=0.4 && <0.6 + +common word-wrap + build-depends: word-wrap >=0.5 && <0.6 + +common yaml + build-depends: yaml >=0.11 && <0.11.12.0 + +library swarm-lang + import: + stan-config, common, ghc2021-extensions, + aeson, + base, + commonmark, + commonmark-extensions, + containers, + data-fix, + deriving-compat, + extra, + free, + fused-effects, + generic-data, + hashable, + lens, + lsp, + megaparsec, + monoidmap, + monoidmap-aeson, + mtl, + parser-combinators, + prettyprinter, + split, + syb, + template-haskell, + terminal-size, + text, + text-rope, + unicode-show, + vector, + vty, + witch, + yaml, + + visibility: public + -- cabal-gild: discover src/swarm-lang + exposed-modules: + Swarm.Effect.Unify + Swarm.Effect.Unify.Common + Swarm.Effect.Unify.Fast + Swarm.Effect.Unify.Naive + Swarm.Language.Capability + Swarm.Language.Context + Swarm.Language.Elaborate + Swarm.Language.Format + Swarm.Language.JSON + Swarm.Language.Key + Swarm.Language.Kindcheck + Swarm.Language.LSP + Swarm.Language.LSP.Hover + Swarm.Language.LSP.VarUsage + Swarm.Language.Parser + Swarm.Language.Parser.Comment + Swarm.Language.Parser.Core + Swarm.Language.Parser.Lex + Swarm.Language.Parser.QQ + Swarm.Language.Parser.Record + Swarm.Language.Parser.Term + Swarm.Language.Parser.Type + Swarm.Language.Parser.Util + Swarm.Language.Parser.Value + Swarm.Language.Pipeline + Swarm.Language.Pipeline.QQ + Swarm.Language.Requirements + Swarm.Language.Requirements.Analysis + Swarm.Language.Requirements.Type + Swarm.Language.Syntax + Swarm.Language.Syntax.AST + Swarm.Language.Syntax.CommandMetadata + Swarm.Language.Syntax.Comments + Swarm.Language.Syntax.Constants + Swarm.Language.Syntax.Loc + Swarm.Language.Syntax.Pattern + Swarm.Language.Syntax.Pretty + Swarm.Language.Syntax.Util + Swarm.Language.TDVar + Swarm.Language.Text.Markdown + Swarm.Language.Typecheck + Swarm.Language.Typed + Swarm.Language.Types + Swarm.Language.Value + Swarm.Language.Var + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: swarm:swarm-util + hs-source-dirs: src/swarm-lang + ghc-options: + -hiedir=.hie/src/swarm-lang + + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + +library swarm-topography + import: + stan-config, common, ghc2021-extensions, + AhoCorasick, + JuicyPixels, + aeson, + array, + either, + base, + containers, + extra, + hashable, + lens, + linear, + nonempty-containers, + servant-docs, + split, + text, + transformers, + unordered-containers, + vector, + yaml, + + visibility: public + -- cabal-gild: discover src/swarm-topography + exposed-modules: + Swarm.Game.Location + Swarm.Game.Scenario.Topography.Area + Swarm.Game.Scenario.Topography.Grid + Swarm.Game.Scenario.Topography.Modify + Swarm.Game.Scenario.Topography.Navigation.Waypoint + Swarm.Game.Scenario.Topography.Placement + Swarm.Game.Scenario.Topography.ProtoCell + Swarm.Game.Scenario.Topography.Rasterize + Swarm.Game.Scenario.Topography.Structure + Swarm.Game.Scenario.Topography.Structure.Assembly + Swarm.Game.Scenario.Topography.Structure.Named + Swarm.Game.Scenario.Topography.Structure.Overlay + Swarm.Game.Scenario.Topography.Structure.Recognition + Swarm.Game.Scenario.Topography.Structure.Recognition.Log + Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute + Swarm.Game.Scenario.Topography.Structure.Recognition.Prep + Swarm.Game.Scenario.Topography.Structure.Recognition.Registry + Swarm.Game.Scenario.Topography.Structure.Recognition.Static + Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry + Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking + Swarm.Game.Scenario.Topography.Structure.Recognition.Type + Swarm.Game.Scenario.Topography.Terraform + Swarm.Game.Universe + Swarm.Game.World.Coords + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: + swarm:swarm-util + + hs-source-dirs: src/swarm-topography + ghc-options: + -hiedir=.hie/src/swarm-topography + + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + +library swarm-scenario + import: + stan-config, common, ghc2021-extensions, + JuicyPixels, + aeson, + array, + base, + boolexpr, + bytestring, + clock, + colour, + containers, + directory, + either, + extra, + filepath, + fused-effects, + hashable, + nonempty-containers, + hsnoise, + lens, + linear, + megaparsec, + monad-logger, + monoidmap, + monoidmap-aeson, + mtl, + murmur3, + palette, + parser-combinators, + prettyprinter, + random, + servant-docs, + tagged, + text, + vector, + vty, + witch, + yaml, + + visibility: public + -- cabal-gild: discover src/swarm-scenario + exposed-modules: + Swarm.Constant + Swarm.Game.Achievement.Definitions + Swarm.Game.Device + Swarm.Game.Display + Swarm.Game.Entity + Swarm.Game.Entity.Cosmetic + Swarm.Game.Entity.Cosmetic.Assignment + Swarm.Game.Ingredients + Swarm.Game.Land + Swarm.Game.Recipe + Swarm.Game.Recipe.Graph + Swarm.Game.Robot + Swarm.Game.Robot.Walk + Swarm.Game.Scenario + Swarm.Game.Scenario.Objective + Swarm.Game.Scenario.Objective.Graph + Swarm.Game.Scenario.Objective.Logic + Swarm.Game.Scenario.Objective.Validation + Swarm.Game.Scenario.RobotLookup + Swarm.Game.Scenario.Style + Swarm.Game.Scenario.Topography.Cell + Swarm.Game.Scenario.Topography.Center + Swarm.Game.Scenario.Topography.EntityFacade + Swarm.Game.Scenario.Topography.Navigation.Portal + Swarm.Game.Scenario.Topography.WorldDescription + Swarm.Game.Scenario.Topography.WorldPalette + Swarm.Game.State.Config + Swarm.Game.State.Landscape + Swarm.Game.Terrain + Swarm.Game.World + Swarm.Game.World.Abstract + Swarm.Game.World.Compile + Swarm.Game.World.Eval + Swarm.Game.World.Gen + Swarm.Game.World.Interpret + Swarm.Game.World.Load + Swarm.Game.World.Parse + Swarm.Game.World.Render + Swarm.Game.World.Syntax + Swarm.Game.World.Typecheck + Swarm.Util.Content + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: + swarm:swarm-lang, + swarm:swarm-topography, + swarm:swarm-util, + + hs-source-dirs: src/swarm-scenario + ghc-options: + -hiedir=.hie/src/swarm-scenario + + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + +library swarm-engine + import: + stan-config, common, ghc2021-extensions, + SHA, + aeson, + array, + astar, + base, + boolexpr, + clock, + containers, + directory, + extra, + filepath, + fused-effects, + fused-effects-lens, + lens, + linear, + megaparsec, + monoidmap, + mtl, + nonempty-containers, + ordered-containers, + prettyprinter, + random, + servant-docs, + text, + time, + hashable, + transformers, + unordered-containers, + witch, + yaml, + + visibility: public + -- cabal-gild: discover src/swarm-engine + exposed-modules: + Swarm.Effect + Swarm.Effect.Time + Swarm.Game.Achievement.Attainment + Swarm.Game.Achievement.Description + Swarm.Game.Achievement.Persistence + Swarm.Game.CESK + Swarm.Game.Exception + Swarm.Game.Popup + Swarm.Game.Robot.Activity + Swarm.Game.Robot.Concrete + Swarm.Game.Scenario.Objective.WinCheck + Swarm.Game.Scenario.Scoring.Best + Swarm.Game.Scenario.Scoring.CodeSize + Swarm.Game.Scenario.Scoring.ConcreteMetrics + Swarm.Game.Scenario.Scoring.GenericMetrics + Swarm.Game.Scenario.Status + Swarm.Game.Scenario.Topography.Navigation.Util + Swarm.Game.ScenarioInfo + Swarm.Game.State + Swarm.Game.State.Initialize + Swarm.Game.State.Robot + Swarm.Game.State.Runtime + Swarm.Game.State.Substate + Swarm.Game.Step + Swarm.Game.Step.Arithmetic + Swarm.Game.Step.Combustion + Swarm.Game.Step.Const + Swarm.Game.Step.Flood + Swarm.Game.Step.Path.Cache + Swarm.Game.Step.Path.Cache.DistanceLimit + Swarm.Game.Step.Path.Finding + Swarm.Game.Step.Path.Type + Swarm.Game.Step.Path.Walkability + Swarm.Game.Step.RobotStepState + Swarm.Game.Step.Util + Swarm.Game.Step.Util.Command + Swarm.Game.Step.Util.Inspect + Swarm.Game.Step.Validate + Swarm.Game.Tick + Swarm.Game.Value + Swarm.Log + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: + swarm:swarm-lang, + swarm:swarm-scenario, + swarm:swarm-topography, + swarm:swarm-util, + + hs-source-dirs: src/swarm-engine + ghc-options: + -hiedir=.hie/src/swarm-engine + + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + +library swarm-web + import: + stan-config, common, ghc2021-extensions, + aeson, + base, + bytestring, + colour, + commonmark, + containers, + http-types, + lens, + nonempty-containers, + palette, + servant, + servant-docs, + servant-server, + text, + wai, + wai-app-static, + warp, + dotgen, + witch, + + visibility: public + -- cabal-gild: discover src/swarm-web + exposed-modules: + Swarm.Web + Swarm.Web.GraphRender + Swarm.Web.Worldview + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: + swarm:swarm-engine, + swarm:swarm-lang, + swarm:swarm-scenario, + swarm:swarm-topography, + swarm:swarm-tui, + swarm:swarm-util, + + hs-source-dirs: src/swarm-web + ghc-options: + -hiedir=.hie/src/swarm-web + + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + +library swarm-tournament + import: + stan-config, common, ghc2021-extensions, + SHA, + aeson, + base, + bytestring, + commonmark, + containers, + cookie, + exceptions, + extra, + fused-effects, + http-client, + http-client-tls, + http-types, + lens, + mtl, + JuicyPixels, + servant-JuicyPixels, + servant-docs, + servant-multipart, + servant-server, + sqlite-simple, + text, + time, + transformers, + utf8-string, + wai, + wai-app-static, + wai-extra, + warp, + yaml, + + visibility: public + -- cabal-gild: discover src/swarm-tournament + exposed-modules: + Swarm.Web.Auth + Swarm.Web.Tournament + Swarm.Web.Tournament.Database.Query + Swarm.Web.Tournament.Type + Swarm.Web.Tournament.Validate + Swarm.Web.Tournament.Validate.FailureMode + Swarm.Web.Tournament.Validate.Upload + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: + swarm:swarm-engine, + swarm:swarm-lang, + swarm:swarm-scenario, + swarm:swarm-util, + + hs-source-dirs: src/swarm-tournament + ghc-options: + -hiedir=.hie/src/swarm-tournament + + default-language: Haskell2010 + +library swarm-util + import: + stan-config, common, ghc2021-extensions, + aeson, + array, + base, + boolexpr, + clock, + containers, + data-fix, + directory, + either, + extra, + filepath, + free, + fused-effects, + hashable, + lens, + megaparsec, + minimorph, + mtl, + prettyprinter, + servant-docs, + template-haskell, + text, + transformers, + vector, + witch, + witherable, + yaml, + + visibility: public + -- cabal-gild: discover src/swarm-util + exposed-modules: + Data.BoolExpr.Simplify + Swarm.Failure + Swarm.Language.Syntax.Direction + Swarm.Pretty + Swarm.ResourceLoading + Swarm.Util + Swarm.Util.Effect + Swarm.Util.Erasable + Swarm.Util.Graph + Swarm.Util.JSON + Swarm.Util.Lens + Swarm.Util.OccurrenceEncoder + Swarm.Util.RingBuffer + Swarm.Util.UnitInterval + Swarm.Util.WindowedCounter + Swarm.Util.Yaml + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + hs-source-dirs: src/swarm-util + ghc-options: + -hiedir=.hie/src/swarm-util + + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + +library swarm-doc + import: + stan-config, common, ghc2021-extensions, + aeson, + base, + containers, + directory, + dotgen, + extra, + filepath, + fused-effects, + lens, + mtl, + pandoc, + pandoc-types, + scientific, + servant-docs, + text, + transformers, + vector, + + visibility: public + -- cabal-gild: discover src/swarm-doc + exposed-modules: + Swarm.Doc.Command + Swarm.Doc.Gen + Swarm.Doc.Keyword + Swarm.Doc.Pedagogy + Swarm.Doc.Schema.Arrangement + Swarm.Doc.Schema.Parse + Swarm.Doc.Schema.Refined + Swarm.Doc.Schema.Render + Swarm.Doc.Schema.SchemaType + Swarm.Doc.Util + Swarm.Doc.Wiki.Cheatsheet + Swarm.Doc.Wiki.Matrix + Swarm.Doc.Wiki.Util + + build-depends: + swarm:swarm-engine, + swarm:swarm-lang, + swarm:swarm-scenario, + swarm:swarm-util, + + hs-source-dirs: src/swarm-doc + ghc-options: + -hiedir=.hie/src/swarm-doc + + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + +library swarm-tui + import: + stan-config, common, ghc2021-extensions, + aeson, + array, + base, + brick, + brick-list-skip, + brick-tabular-list, + bytestring, + clock, + prettyprinter, + colour, + containers, + extra, + filepath, + fused-effects, + fuzzy, + generic-data, + githash, + lens, + linear, + mtl, + murmur3, + natural-sort, + nonempty-containers, + palette, + servant-docs, + split, + tagged, + text, + text-zipper, + time, + transformers, + vector, + vty, + warp, + witch, + word-wrap, + yaml, + + visibility: public + -- cabal-gild: discover src/swarm-tui + exposed-modules: + Swarm.TUI.Border + Swarm.TUI.Controller + Swarm.TUI.Controller.EventHandlers + Swarm.TUI.Controller.EventHandlers.Frame + Swarm.TUI.Controller.EventHandlers.Main + Swarm.TUI.Controller.EventHandlers.REPL + Swarm.TUI.Controller.EventHandlers.Robot + Swarm.TUI.Controller.EventHandlers.World + Swarm.TUI.Controller.SaveScenario + Swarm.TUI.Controller.UpdateUI + Swarm.TUI.Controller.Util + Swarm.TUI.Editor.Controller + Swarm.TUI.Editor.Json + Swarm.TUI.Editor.Masking + Swarm.TUI.Editor.Model + Swarm.TUI.Editor.Palette + Swarm.TUI.Editor.Util + Swarm.TUI.Editor.View + Swarm.TUI.Inventory.Sorting + Swarm.TUI.Launch.Controller + Swarm.TUI.Launch.Model + Swarm.TUI.Launch.Prep + Swarm.TUI.Launch.View + Swarm.TUI.List + Swarm.TUI.Model + Swarm.TUI.Model.Achievements + Swarm.TUI.Model.DebugOption + Swarm.TUI.Model.Dialog + Swarm.TUI.Model.Dialog.Goal + Swarm.TUI.Model.Dialog.Structure + Swarm.TUI.Model.Event + Swarm.TUI.Model.KeyBindings + Swarm.TUI.Model.Menu + Swarm.TUI.Model.Name + Swarm.TUI.Model.Repl + Swarm.TUI.Model.StateUpdate + Swarm.TUI.Model.UI + Swarm.TUI.Model.UI.Gameplay + Swarm.TUI.Model.WebCommand + Swarm.TUI.Panel + Swarm.TUI.View + Swarm.TUI.View.Achievement + Swarm.TUI.View.Attribute.Attr + Swarm.TUI.View.Attribute.CustomStyling + Swarm.TUI.View.Attribute.Util + Swarm.TUI.View.CellDisplay + Swarm.TUI.View.Logo + Swarm.TUI.View.Objective + Swarm.TUI.View.Popup + Swarm.TUI.View.Robot + Swarm.TUI.View.Robot.Details + Swarm.TUI.View.Robot.Type + Swarm.TUI.View.Shared + Swarm.TUI.View.Structure + Swarm.TUI.View.Util + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: + swarm:swarm-engine, + swarm:swarm-lang, + swarm:swarm-scenario, + swarm:swarm-topography, + swarm:swarm-util, + + hs-source-dirs: src/swarm-tui + ghc-options: + -hiedir=.hie/src/swarm-tui + + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + +executable swarm + import: + stan-config, common, ghc2021-extensions, + aeson, + base, + brick, + bytestring, + containers, + extra, + fused-effects, + githash, + http-client, + http-client-tls, + http-types, + lens, + optparse-applicative, + text, + vty, + vty-crossplatform, + yaml, + + build-depends: + swarm:swarm-engine, + swarm:swarm-lang, + swarm:swarm-tui, + swarm:swarm-util, + swarm:swarm-web, + + main-is: Main.hs + autogen-modules: Paths_swarm + other-modules: + Paths_swarm + Swarm.App + Swarm.Version + + hs-source-dirs: app/game + ghc-options: + -hiedir=.hie/app/game + + default-language: Haskell2010 + ghc-options: -threaded + default-extensions: ImportQualifiedPost + +executable swarm-scene + import: + stan-config, common, ghc2021-extensions, + base, + optparse-applicative, + + main-is: Main.hs + build-depends: + swarm:swarm-scenario, + swarm:swarm-topography, + + hs-source-dirs: app/scene + ghc-options: + -hiedir=.hie/app/scene + + default-language: Haskell2010 + ghc-options: -threaded + default-extensions: ImportQualifiedPost + +executable swarm-docs + import: + stan-config, common, ghc2021-extensions, + base, + optparse-applicative, + text, + + build-depends: + swarm:swarm-doc + + main-is: Main.hs + other-modules: + hs-source-dirs: app/doc + ghc-options: + -hiedir=.hie/app/doc + + default-language: Haskell2010 + ghc-options: -threaded + default-extensions: ImportQualifiedPost + +executable swarm-host-tournament + import: + stan-config, common, ghc2021-extensions, + base, + optparse-applicative, + sqlite-simple, + transformers, + warp, + yaml, + + main-is: Main.hs + build-depends: + swarm:swarm-engine, + swarm:swarm-tournament, + + hs-source-dirs: app/tournament + ghc-options: + -hiedir=.hie/app/tournament + + default-language: Haskell2010 + ghc-options: -threaded + default-extensions: ImportQualifiedPost + +test-suite swarm-unit + import: + stan-config, common, ghc2021-extensions, + QuickCheck, + aeson, + base, + boolexpr, + containers, + data-fix, + filepath, + hashable, + lens, + megaparsec, + mtl, + quickcheck-instances, + tasty, + tasty-hunit, + tasty-quickcheck, + text, + time, + vty, + witch, + yaml, + + main-is: Main.hs + type: exitcode-stdio-1.0 + other-modules: + TestBoolExpr + TestCommand + TestContext + TestEval + TestInventory + TestLSP + TestLanguagePipeline + TestNotification + TestOrdering + TestOverlay + TestParse + TestPedagogy + TestPretty + TestQQ + TestRepl + TestRequirements + TestScoring + TestUtil + + build-depends: + swarm:swarm-doc, + swarm:swarm-engine, + swarm:swarm-lang, + swarm:swarm-scenario, + swarm:swarm-topography, + swarm:swarm-tui, + swarm:swarm-util, + + hs-source-dirs: test/unit + ghc-options: + -hiedir=.hie/test/unit + + default-language: Haskell2010 + ghc-options: -threaded + +test-suite swarm-integration + import: + stan-config, common, ghc2021-extensions, + base, + containers, + filepath, + fused-effects, + lens, + mtl, + tasty, + tasty-expected-failure, + tasty-hunit, + text, + witch, + yaml, + + main-is: Main.hs + other-modules: + TestFormat + TestRecipeCoverage + + type: exitcode-stdio-1.0 + build-depends: + swarm:swarm-doc, + swarm:swarm-engine, + swarm:swarm-lang, + swarm:swarm-scenario, + swarm:swarm-tui, + swarm:swarm-util, + + hs-source-dirs: test/integration + ghc-options: + -hiedir=.hie/test/integration + + default-language: Haskell2010 + ghc-options: -threaded + +test-suite tournament-host + import: + stan-config, common, ghc2021-extensions, + SHA, + base, + bytestring, + http-client, + http-types, + nonempty-containers, + tasty, + tasty-hunit, + warp, + + main-is: Main.hs + type: exitcode-stdio-1.0 + build-depends: + swarm:swarm-engine, + swarm:swarm-tournament, + + hs-source-dirs: test/tournament-host + ghc-options: + -hiedir=.hie/test/tournament-host + + default-language: Haskell2010 + ghc-options: -threaded + +test-suite standalone-topography + import: + stan-config, common, ghc2021-extensions, + JuicyPixels, + MissingH, + base, + bytestring, + filepath, + tasty, + tasty-hunit, + yaml, + + main-is: Main.hs + type: exitcode-stdio-1.0 + other-modules: + Lib + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: + swarm:swarm-scenario, + swarm:swarm-topography, + swarm:swarm-util, + + hs-source-dirs: test/standalone-topography/src + ghc-options: + -hiedir=.hie/test/standalone-topography/src + + default-language: Haskell2010 + ghc-options: -threaded + +benchmark benchmark + import: + stan-config, common, ghc2021-extensions, + base, + containers, + extra, + lens, + mtl, + tasty-bench, + text, + + main-is: Benchmark.hs + hs-source-dirs: test/bench + ghc-options: + -hiedir=.hie/test/bench + + type: exitcode-stdio-1.0 + build-depends: + fused-effects, swarm:swarm-engine, swarm:swarm-lang, swarm:swarm-scenario, diff --git a/test/bench/Benchmark.hs b/test/bench/Benchmark.hs --- a/test/bench/Benchmark.hs +++ b/test/bench/Benchmark.hs @@ -5,7 +5,7 @@ -- SPDX-License-Identifier: BSD-3-Clause module Main where -import Control.Carrier.Accum.FixedStrict (runAccum) +import Control.Carrier.Accum.Strict (runAccum) import Control.Lens (view, (&), (.~)) import Control.Monad (replicateM_) import Control.Monad.State (evalStateT, execStateT) @@ -14,18 +14,19 @@ import Data.Text qualified as T import Data.Tuple.Extra (dupe) import Swarm.Effect (runTimeIO) +import Swarm.Failure (SystemFailure, simpleErrorHandle) import Swarm.Game.CESK (initMachine) import Swarm.Game.Display (defaultRobotDisplay) -import Swarm.Game.Failure (SystemFailure, simpleErrorHandle) import Swarm.Game.Location import Swarm.Game.Robot (TRobot, mkRobot) import Swarm.Game.Robot.Walk (emptyExceptions) import Swarm.Game.Scenario (loadStandaloneScenario) +import Swarm.Game.Scenario.Status import Swarm.Game.State (GameState, creativeMode, landscape, zoomRobots) import Swarm.Game.State.Initialize (pureScenarioToGameState) import Swarm.Game.State.Landscape (multiWorld) import Swarm.Game.State.Robot (addTRobot) -import Swarm.Game.State.Runtime (initRuntimeState, stdGameConfigInputs) +import Swarm.Game.State.Runtime (RuntimeOptions (..), initRuntimeState, stdGameConfigInputs) import Swarm.Game.Step (gameTick) import Swarm.Game.Terrain (blankTerrainIndex) import Swarm.Game.Universe (Cosmic (..), SubworldName (DefaultRootSubworld)) @@ -110,7 +111,8 @@ end; def start = pos <- whereami; - wait $ fst pos; + match pos \x. \_. + wait x; go; end; start; @@ -142,9 +144,11 @@ -- NOTE: This replaces "classicGame0", which is still used by unit tests. gs <- simpleErrorHandle $ do - (_ :: Seq SystemFailure, initRS) <- runAccum mempty initRuntimeState - (scenario, _) <- loadStandaloneScenario "classic" - return $ pureScenarioToGameState scenario 0 0 Nothing $ view stdGameConfigInputs initRS + (_ :: Seq SystemFailure, initRS) <- + runAccum mempty . initRuntimeState $ + RuntimeOptions {startPaused = False, pauseOnObjectiveCompletion = False, loadTestScenarios = False} + (scenario, _gsi) <- loadStandaloneScenario "classic" + return $ pureScenarioToGameState (ScenarioWith scenario Nothing) 0 0 Nothing $ view stdGameConfigInputs initRS execStateT (zoomRobots $ mapM_ (addTRobot $ initMachine prog) robots) diff --git a/test/integration/Main.hs b/test/integration/Main.hs --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -21,20 +21,23 @@ import Data.List (partition) import Data.Map qualified as M import Data.Maybe (isJust) +import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T -import Data.Yaml (ParseException, prettyPrintParseException) +import Data.Yaml (ParseException, decodeFileEither, prettyPrintParseException) import Swarm.Doc.Keyword (EditorType (..)) import Swarm.Doc.Keyword qualified as Keyword +import Swarm.Failure (SystemFailure) import Swarm.Game.Achievement.Definitions (GameplayAchievement (..)) import Swarm.Game.CESK (initMachine) import Swarm.Game.Entity (lookupByName) -import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.Robot (equippedDevices, systemRobot) +import Swarm.Game.Robot (equippedDevices, robotName, systemRobot) import Swarm.Game.Robot.Activity (commandsHistogram, lifetimeStepCount, tangibleCommandCount) import Swarm.Game.Robot.Concrete (activityCounts, machine, robotLog, waitingUntil) import Swarm.Game.Scenario (Scenario, ScenarioInputs (..), gsiScenarioInputs) +import Swarm.Game.Scenario.Scoring.GenericMetrics (Metric (..), Progress (..)) +import Swarm.Game.ScenarioInfo (ScenarioInfo, ScenarioStatus (..), scenarioStatus) import Swarm.Game.State ( GameState, baseRobot, @@ -66,18 +69,20 @@ import Swarm.Game.Step.Validate (badErrorsInLogs, playUntilWin) import Swarm.Game.Tick (getTickNumber) import Swarm.Language.Pipeline (processTerm) -import Swarm.Language.Pretty (prettyString) import Swarm.Log +import Swarm.Pretty (prettyString) import Swarm.TUI.Model ( - KeyEventHandlingState, + debugOptions, defaultAppOpts, gameState, + playState, runtimeState, + scenarioState, userScenario, ) -import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState) -import Swarm.TUI.Model.UI (UIState) -import Swarm.Util (findAllWithExt) +import Swarm.TUI.Model.DebugOption (DebugOption (LoadTestingScenarios)) +import Swarm.TUI.Model.StateUpdate (PersistentState (..), constructAppState, initPersistentState) +import Swarm.Util (applyWhen, findAllWithExt) import Swarm.Util.RingBuffer qualified as RB import Swarm.Util.Yaml (decodeFileEitherE) import System.FilePath (splitDirectories) @@ -85,6 +90,7 @@ import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) +import TestFormat import TestRecipeCoverage import Witch (into) @@ -97,12 +103,14 @@ scenarioPaths <- findAllWithExt "data/scenarios" "yaml" let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths scenarioPrograms <- findAllWithExt "data/scenarios" "sw" - (rs, ui, key) <- do - out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts + PersistentState rs ui key progState <- do + let testingOptions = defaultAppOpts {debugOptions = S.singleton LoadTestingScenarios} + out <- runM . runThrow @SystemFailure $ initPersistentState testingOptions either (assertFailure . prettyString) return out let scenarioInputs = gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs rs' = rs & eventLog .~ mempty recipeTests <- testRecipeCoverage + formatTests <- testFormatting defaultMain $ testGroup "Tests" @@ -111,9 +119,11 @@ , exampleTests scenarioPrograms , scenarioParseTests scenarioInputs parseableScenarios , scenarioParseInvalidTests scenarioInputs unparseableScenarios - , testScenarioSolutions rs' ui key + , formatTests + , testScenarioSolutions $ PersistentState rs' ui key progState , testEditorFiles , recipeTests + , saveFileTests ] testNoLoadingErrors :: RuntimeState -> TestTree @@ -131,13 +141,13 @@ isError = (>= Warning) . view leSeverity exampleTests :: [FilePath] -> TestTree -exampleTests inputs = testGroup "Test example" (map exampleTest inputs) +exampleTests = testGroup "Test example" . map exampleTest exampleTest :: FilePath -> TestTree exampleTest path = testCase ("processTerm for contents of " ++ show path) $ do value <- processTerm <$> T.readFile path - either (assertFailure . into @String) (\_ -> return ()) value + either (assertFailure . into @String) (const $ return ()) value scenarioParseTests :: ScenarioInputs -> [FilePath] -> TestTree scenarioParseTests scenarioInputs inputs = @@ -162,11 +172,9 @@ res <- decodeFileEitherE scenarioInputs p :: IO (Either ParseException Scenario) case expRes of Parsed -> case res of - Left err -> assertFailure (prettyPrintParseException err) + Left err -> assertFailure $ prettyPrintParseException err Right _s -> return () - Failed -> case res of - Left _err -> return () - Right _s -> assertFailure "Unexpectedly parsed invalid scenario!" + Failed -> forM_ res $ const $ assertFailure "Unexpectedly parsed invalid scenario!" data Time = -- | One second should be enough to run most programs. @@ -187,14 +195,16 @@ data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show) -testScenarioSolutions :: RuntimeState -> UIState -> KeyEventHandlingState -> TestTree -testScenarioSolutions rs ui key = +testScenarioSolutions :: + PersistentState -> + TestTree +testScenarioSolutions ps = testGroup "Test scenario solutions" [ testGroup "Tutorial" [ testTutorialSolution Default "Tutorials/backstory" - , testTutorialSolution (Sec 3) "Tutorials/move" + , testTutorialSolution (Sec 10) "Tutorials/move" , testTutorialSolution Default "Tutorials/craft" , testTutorialSolution Default "Tutorials/grab" , testTutorialSolution Default "Tutorials/place" @@ -203,7 +213,8 @@ , testTutorialSolution Default "Tutorials/equip" , testTutorialSolution Default "Tutorials/build" , testTutorialSolution Default "Tutorials/bind2" - , testTutorialSolution' Default "Tutorials/crash" CheckForBadErrors $ \g -> do + , testTutorialSolution' Default "Tutorials/debug" CheckForBadErrors $ \g -> do + -- printAllLogs g let robots = toList $ g ^. robotInfo . robotMap let hints = any (T.isInfixOf "you will win" . view leText) . toList . view robotLog let win = isJust $ find hints robots @@ -213,7 +224,7 @@ , testTutorialSolution Default "Tutorials/def" , testTutorialSolution Default "Tutorials/lambda" , testTutorialSolution Default "Tutorials/require" - , testTutorialSolution (Sec 3) "Tutorials/requireinv" + , testTutorialSolution (Sec 3) "Tutorials/stock" , testTutorialSolution Default "Tutorials/conditionals" , testTutorialSolution Default "Tutorials/world101" , testTutorialSolution (Sec 5) "Tutorials/farming" @@ -237,13 +248,16 @@ , testSolution (Sec 10) "Challenges/gopher" , testSolution (Sec 5) "Challenges/hackman" , testSolution (Sec 5) "Challenges/blender" + , testSolution (Sec 10) "Challenges/dna" , testSolution (Sec 10) "Challenges/hanoi" , testSolution (Sec 3) "Challenges/lights-out" , testSolution (Sec 10) "Challenges/Sliding Puzzles/3x3" , testSolution Default "Challenges/friend" , testSolution Default "Challenges/pack-tetrominoes" , testSolution (Sec 10) "Challenges/dimsum" - , testSolution (Sec 15) "Challenges/gallery" + , testSolution (Sec 20) "Challenges/gallery" + , testSolution (Sec 10) "Challenges/telephone" + , testSolution (Sec 10) "Challenges/flower-count" , testGroup "Mazes" [ testSolution Default "Challenges/Mazes/easy_cave_maze" @@ -258,6 +272,7 @@ , testSolution (Sec 20) "Challenges/Ranching/powerset" , testSolution (Sec 10) "Challenges/Ranching/fishing" , testSolution (Sec 30) "Challenges/Ranching/gated-paddock" + , testSolution (Sec 30) "Challenges/Ranching/pied-piper" ] , testGroup "Sokoban" @@ -287,7 +302,7 @@ let t = g ^. temporal . ticks r1Waits = g ^?! robotInfo . robotMap . ix 1 . to waitingUntil active = IS.member 1 $ g ^. robotInfo . activeRobots - waiting = elem 1 . concat . M.elems $ g ^. robotInfo . waitingRobots + waiting = elem 1 . concat . toList $ g ^. robotInfo . waitingRobots assertBool "The game should only take two ticks" $ getTickNumber t == 2 assertBool "Robot 1 should have waiting machine" $ isJust r1Waits assertBool "Robot 1 should be still active" active @@ -306,8 +321,8 @@ [ testSolution Default "Testing/201-require/201-require-device" , testSolution Default "Testing/201-require/201-require-device-creative" , testSolution Default "Testing/201-require/201-require-device-creative1" - , testSolution Default "Testing/201-require/201-require-entities" - , testSolution Default "Testing/201-require/201-require-entities-def" + , testSolution Default "Testing/201-require/201-stock-entities" + , testSolution Default "Testing/201-require/201-stock-entities-def" , testSolution Default "Testing/201-require/533-reprogram-simple" , testSolution Default "Testing/201-require/533-reprogram" , testSolution Default "Testing/201-require/1664-require-system-robot-children" @@ -338,7 +353,7 @@ , testSolution Default "Testing/956-GPS" , testSolution Default "Testing/958-isempty" , testSolution Default "Testing/1007-use-command" - , testSolution Default "Testing/1024-sand" + , testSolution (Sec 2) "Testing/1024-sand" , testSolution Default "Testing/1034-custom-attributes" , testSolution Default "Testing/1140-detect-command" , testSolution Default "Testing/1157-drill-return-value" @@ -353,6 +368,7 @@ , testSolution Default "Testing/1295-density-command" , testSolution Default "Testing/1356-portals/portals-flip-and-rotate" , testSolution Default "Testing/144-subworlds/basic-subworld" + , testSolution Default "Testing/144-subworlds/teleport-and-query" , testSolution Default "Testing/144-subworlds/subworld-mapped-robots" , testSolution Default "Testing/144-subworlds/subworld-located-robots" , testSolution Default "Testing/144-subworlds/subworld-shared-structures" @@ -371,6 +387,9 @@ , testSolution Default "Testing/1642-biomes" , testSolution (Sec 10) "Testing/1533-sow-command" , testSolution Default "Testing/1533-sow-seed-maturation" + , testSolution Default "Testing/2085-toplevel-mask" + , testSolution Default "Testing/2086-structure-palette" + , testSolution Default "Testing/1271-wall-boundaries" , testGroup -- Note that the description of the classic world in -- data/worlds/classic.yaml (automatically tested to some @@ -435,6 +454,16 @@ , testSolution Default "Testing/1535-ping/1535-out-of-range" ] , testGroup + "Structure placement (#1780)" + [ testSolution Default "Testing/1780-structure-merge-expansion/sequential-placement" + , testSolution Default "Testing/1780-structure-merge-expansion/coordinate-offset-propagation" + , testSolution Default "Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset" + -- TODO(#2148) define goal conditions or convert to image fixtures + -- , testSolution Default "Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge" + -- , testSolution Default "Testing/1780-structure-merge-expansion/root-map-expansion" + -- , testSolution Default "Testing/1780-structure-merge-expansion/structure-composition" + ] + , testGroup "Structure recognition (#1575)" [ testSolution Default "Testing/1575-structure-recognizer/1575-browse-structures" , testSolution Default "Testing/1575-structure-recognizer/1575-nested-structure-definition" @@ -452,6 +481,12 @@ , testSolution Default "Testing/1575-structure-recognizer/1575-bounding-box-overlap" , testSolution Default "Testing/1575-structure-recognizer/1644-rotated-recognition" , testSolution Default "Testing/1575-structure-recognizer/1644-rotated-preplacement-recognition" + , testSolution Default "Testing/1575-structure-recognizer/2115-encroaching-upon-interior-transparent-cells" + , testSolution Default "Testing/1575-structure-recognizer/2115-encroaching-upon-exterior-transparent-cells" + , testSolution Default "Testing/1575-structure-recognizer/2201-piecewise-lines" + , testSolution Default "Testing/1575-structure-recognizer/2201-preclude-overlapping-recognition" + , testSolution Default "Testing/1575-structure-recognizer/2201-initial-recognition-overlap" + , testSolution Default "Testing/1575-structure-recognizer/2229-position-uniqueness-multiple-orientations" ] ] , testSolution' Default "Testing/1430-built-robot-ownership" CheckForBadErrors $ \g -> do @@ -474,6 +509,21 @@ assertEqual "Incorrect step count." 62 $ view lifetimeStepCount counters , expectFailBecause "Awaiting fix for #231" $ testSolution Default "Testing/231-requirements/231-command-transformer-reqs" + , testSolution Default "Testing/2239-custom-entity" + , testSolution' Default "Testing/2240-overridden-entity-capabilities" CheckForBadErrors $ \g -> do + let msgs = g ^.. robotInfo . robotMap . traverse . robotLog . to logToText . traverse + assertBool "Error message should mention tank treads but not treads" $ + not (any ("- treads" `T.isInfixOf`) msgs) + && any ("- tank treads" `T.isInfixOf`) msgs + , testSolution Default "Testing/2253-halt-waiting" + , testSolution Default "Testing/2270-instant-defs" + , testSolution' Default "Testing/1592-shared-template-robot-say-logs" CheckForBadErrors $ \g -> do + let baseLogs = g ^.. baseRobot . robotLog . to logToText . traverse + -- printAllLogs g + assertEqual + "There should be 6 logs from all of the robots saying things at once!" + (length baseLogs) + 6 -- the final OK said by base happens after win, and is for debugging ] where -- expectFailIf :: Bool -> String -> TestTree -> TestTree @@ -482,17 +532,22 @@ testSolution :: Time -> FilePath -> TestTree testSolution s p = testSolution' s p CheckForBadErrors (const $ pure ()) - testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree + testSolution' :: + Time -> + FilePath -> + ShouldCheckBadErrors -> + (GameState -> Assertion) -> + TestTree testSolution' s p shouldCheckBadErrors verify = testCase p $ do - out <- runM . runThrow @SystemFailure $ constructAppState rs ui key $ defaultAppOpts {userScenario = Just p} + out <- runM . runThrow @SystemFailure $ constructAppState ps (defaultAppOpts {userScenario = Just p}) Nothing case out of Left err -> assertFailure $ prettyString err - Right appState -> case appState ^. gameState . winSolution of + Right appState -> case appState ^. playState . scenarioState . gameState . winSolution of Nothing -> assertFailure "No solution to test!" Just sol -> do when (shouldCheckBadErrors == CheckForBadErrors) (checkNoRuntimeErrors $ appState ^. runtimeState) let gs' = - (appState ^. gameState) + (appState ^. playState . scenarioState . gameState) & baseRobot . machine .~ initMachine sol m <- timeout (time s) (execStateT playUntilWin gs') case m of @@ -521,9 +576,9 @@ printAllLogs :: GameState -> IO () printAllLogs g = - mapM_ - (\r -> forM_ (r ^. robotLog) (putStrLn . T.unpack . view leText)) - (g ^. robotInfo . robotMap) + forM_ (g ^. robotInfo . robotMap) $ \r -> do + putStrLn $ "-- ROBOT: " ++ T.unpack (r ^. robotName) + forM_ (r ^. robotLog) (putStrLn . T.unpack . view leText) -- | Test that editor files are up-to-date. testEditorFiles :: TestTree @@ -559,7 +614,7 @@ testTextInFile :: Bool -> String -> Text -> FilePath -> TestTree testTextInFile whitespace name t fp = testCase name $ do let removeLW' = T.unlines . map (T.dropWhile isSpace) . T.lines - removeLW = if whitespace then removeLW' else id + removeLW = applyWhen whitespace removeLW' f <- T.readFile fp assertBool ( "EDITOR FILE IS NOT UP TO DATE!\n" @@ -569,3 +624,19 @@ <> fp ) (removeLW t `T.isInfixOf` removeLW f) + +saveFileTests :: TestTree +saveFileTests = + testGroup + "Save files" + [ checkLoaded "backstory" "0.6.0.0" + , checkLoaded "backstory" "latest" + ] + where + checkLoaded scenario version = testCase ("save from version " <> version) $ do + ef <- decodeFileEither @ScenarioInfo $ "data/test/saves/" <> scenario <> "-" <> version <> ".yaml" + case ef of + Left e -> assertFailure $ prettyPrintParseException e + Right si -> case si ^. scenarioStatus of + Played _par (Metric Completed _) _best -> pure () + other -> assertFailure $ "scenario save file loaded wrong - contains: " <> show other diff --git a/test/integration/TestFormat.hs b/test/integration/TestFormat.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestFormat.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Test the behavior of 'swarm format' on selected input files. +module TestFormat (testFormatting) where + +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Swarm.Language.Format +import Swarm.Language.Parser.Core (LanguageVersion (SwarmLangLatest)) +import Swarm.Util (findAllWithExt, readFileMayT) +import Test.Tasty +import Test.Tasty.HUnit +import Witch (into) + +-- | Generate test tree to check that 'swarm format' is the identity +-- on .sw files in @data/test/language-snippets/format@. +testFormatting :: IO TestTree +testFormatting = do + testFilePaths <- findAllWithExt "data/test/language-snippets/format" "sw" + pure . testGroup "Check code formatting" $ map checkFormat testFilePaths + where + defaultFormatCfg = FormatConfig Stdin Stdout Nothing SwarmLangLatest + + -- Remove a final trailing newline character, if any + trimFinalEOL :: T.Text -> T.Text + trimFinalEOL t = fromMaybe t (T.stripSuffix "\n" t) + + checkFormat :: FilePath -> TestTree + checkFormat f = testCase f $ do + mcontent <- readFileMayT f + case mcontent of + Nothing -> assertFailure $ "Failed to load " <> f + Just content -> case formatSwarm defaultFormatCfg content of + Left err -> assertFailure (into @String err) + -- Make sure they are the same, up to a trailing newline + Right formatted -> + assertEqual "Formatted code does not match." (trimFinalEOL content) (trimFinalEOL formatted) diff --git a/test/integration/TestRecipeCoverage.hs b/test/integration/TestRecipeCoverage.hs --- a/test/integration/TestRecipeCoverage.hs +++ b/test/integration/TestRecipeCoverage.hs @@ -10,9 +10,9 @@ import Data.List qualified as List import Data.Set qualified as Set import Data.Text qualified as T -import Swarm.Doc.Gen import Swarm.Game.Entity (Entity, EntityName, entityName) -import Swarm.Util (quote) +import Swarm.Game.Recipe.Graph qualified as RG +import Swarm.Util (applyWhen, quote) import Test.Tasty import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit @@ -26,9 +26,9 @@ -- the dot graph of entity recipes in 'Swarm.Doc.Gen' that this test uses. testRecipeCoverage :: IO TestTree testRecipeCoverage = do - graphData <- classicScenarioRecipeGraphData + graphData <- RG.classicScenarioRecipeGraph let sortE = List.sortOn (T.unpack . view entityName) - allEntities = sortE . Set.toList $ rgAllEntities graphData + allEntities = sortE . Set.toList $ RG.allEntities graphData nonCovered = getNonCoveredEntities graphData return . testGroup "Ensure all entities have recipes" $ map (\e -> expectNonCovered e $ checkCoverage nonCovered e) allEntities @@ -37,32 +37,28 @@ checkCoverage s e = let name = view entityName e in testCase (T.unpack name) $ do - assertBool (errMessage name) (name `elem` ignoredEntities || e `Set.notMember` s) + assertBool (errMessage name) (name `elem` RG.ignoredEntities || e `Set.notMember` s) where errMessage missing = T.unpack $ "Can not make " <> quote missing <> " from starting entities." expectNonCovered :: Entity -> TestTree -> TestTree expectNonCovered e = let name = T.toCaseFold (view entityName e) - in if name `elem` nonCoveredList - then expectFailBecause "More recipes needed (#1268)" - else id + in applyWhen (name `elem` nonCoveredList) $ + expectFailBecause "More recipes needed (#1268)" -- | Known non-covered entities that need a recipe. nonCoveredList :: [EntityName] nonCoveredList = map T.toCaseFold - [ "Elmer's glue" - , "ash" - , "binoculars" + [ "ash" , "blueprint" - , "caliper" , "decoder ring" , "linotype" , "tape drive" , "wedge" ] -getNonCoveredEntities :: RecipeGraphData -> Set.Set Entity -getNonCoveredEntities graphData = rgAllEntities graphData `Set.difference` Set.unions (rgLevels graphData) +getNonCoveredEntities :: RG.RecipeGraph -> Set.Set Entity +getNonCoveredEntities graphData = RG.allEntities graphData `Set.difference` Set.unions (RG.levels graphData) diff --git a/test/standalone-topography/src/Lib.hs b/test/standalone-topography/src/Lib.hs --- a/test/standalone-topography/src/Lib.hs +++ b/test/standalone-topography/src/Lib.hs @@ -6,11 +6,9 @@ import Codec.Picture import Control.Arrow (left) -import Data.Aeson import Data.ByteString.Lazy qualified as LBS import Data.Either.Utils (forceEither) import Data.Yaml (prettyPrintParseException) -import GHC.Generics (Generic) import Paths_swarm (getDataDir) import Swarm.Game.Scenario.Topography.Navigation.Waypoint ( Parentage (Root), @@ -19,43 +17,34 @@ import Swarm.Game.Scenario.Topography.Structure import Swarm.Game.Scenario.Topography.Structure.Assembly import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.World.Render import Swarm.Util.Yaml import System.FilePath import Test.Tasty.HUnit (Assertion, assertEqual) -newtype CustomCell = CustomCell Bool - deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) - -instance FromJSONE e CustomCell - -parseStructures :: FilePath -> FilePath -> IO (PStructure (Maybe CustomCell)) +parseStructures :: + FilePath -> + FilePath -> + IO (PStructure (Maybe ColorableCell)) parseStructures dataDir baseFilename = do eitherResult <- decodeFileEitherE () $ dataDir "test/standalone-topography" baseFilename return $ forceEither $ left prettyPrintParseException eitherResult -getDisplayColor :: Maybe CustomCell -> PixelRGBA8 -getDisplayColor = maybe transparent mkPixelColor - where - mkPixelColor (CustomCell b) = case b of - False -> PixelRGBA8 0 0 0 255 - True -> PixelRGBA8 255 255 255 255 - - transparent = PixelRGBA8 0 0 0 0 - -compareToReferenceImage :: String -> Assertion -compareToReferenceImage fileStem = do +compareToReferenceImage :: + -- | set this to update the golden tests + Bool -> + FilePath -> + Assertion +compareToReferenceImage refreshReferenceImage fileStem = do dataDir <- getDataDir parentStruct <- parseStructures dataDir $ fileStem <.> "yaml" let MergedStructure overlayArea _ _ = forceEither $ mergeStructures mempty Root parentStruct - let encodedImgBytestring = encodePng $ makeImage getDisplayColor $ gridContent overlayArea - - let referenceFilepath = dataDir "test/standalone-topography" fileStem <.> "png" + encodedImgBytestring = encodePng $ makeImage $ gridContent overlayArea + referenceFilepath = dataDir "test/standalone-topography" fileStem <.> "png" if refreshReferenceImage then LBS.writeFile referenceFilepath encodedImgBytestring else do decodedImg <- LBS.readFile referenceFilepath assertEqual "Generated image must equal reference image!" decodedImg encodedImgBytestring - where - refreshReferenceImage = False diff --git a/test/standalone-topography/src/Main.hs b/test/standalone-topography/src/Main.hs --- a/test/standalone-topography/src/Main.hs +++ b/test/standalone-topography/src/Main.hs @@ -4,20 +4,45 @@ -- SPDX-License-Identifier: BSD-3-Clause module Main where -import Test.Tasty (defaultMain, testGroup) +import Data.Proxy +import Lib (compareToReferenceImage) +import Test.Tasty import Test.Tasty.HUnit (testCase) +import Test.Tasty.Options -import Lib +newtype UpdateGoldenTests = UpdateGoldenTests Bool + deriving (Eq, Ord) +instance IsOption UpdateGoldenTests where + parseValue = fmap UpdateGoldenTests . safeRead + defaultValue = UpdateGoldenTests False + optionName = return "refresh" + optionHelp = return "Should overwrite the golden test images" + optionCLParser = mkFlagCLParser mempty (UpdateGoldenTests True) + main :: IO () main = do - defaultMain - $ testGroup - "Test structure assembly" - $ map - doTest - [ "circle-and-crosses" - , "checkerboard" - ] + defaultMainWithIngredients ingredients $ askOption $ \(UpdateGoldenTests shouldRefreshTests) -> + let doTest stem = + testCase (unwords ["Image equality:", stem]) $ + compareToReferenceImage shouldRefreshTests stem + + mkGroup title members = + testGroup title $ + map + doTest + members + in testGroup + "Test structure assembly" + [ mkGroup + "Black and white" + [ "circle-and-crosses" + , "checkerboard" + ] + , mkGroup + "Color" + [ "rainbow" + ] + ] where - doTest stem = testCase (unwords ["Image equality:", stem]) $ compareToReferenceImage stem + ingredients = includingOptions [Option (Proxy :: Proxy UpdateGoldenTests)] : defaultIngredients diff --git a/test/unit/Main.hs b/test/unit/Main.hs --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -13,7 +13,7 @@ import Data.List (subsequences) import Data.Set (Set) import Data.Set qualified as S -import Swarm.TUI.Model (AppState, gameState, runtimeState) +import Swarm.TUI.Model (AppState, gameState, playState, progression, scenarioState) import Swarm.TUI.Model.StateUpdate (classicGame0) import Swarm.Util (removeSupersets, smallHittingSet) import Test.QuickCheck qualified as QC @@ -28,6 +28,7 @@ ) import TestBoolExpr (testBoolExpr) import TestCommand (testCommands) +import TestContext (testContext) import TestEval (testEval) import TestInventory (testInventory) import TestLSP (testLSP) @@ -38,6 +39,7 @@ import TestParse (testParse) import TestPedagogy (testPedagogy) import TestPretty (testPrettyConst) +import TestQQ (testQQ) import TestRepl (testRepl) import TestRequirements (testRequirements) import TestScoring (testHighScores) @@ -54,22 +56,44 @@ tests s = testGroup "Tests" + [ statelessTests + , stateDependentTests s + ] + +-- | Initializing an 'AppState' entails loading challenge scenarios, etc. from +-- disk. We might not want to do this, in case we inject a 'trace' somewhere +-- in the scenario loading code and want to minimize the noise. +-- +-- So we keep this list separate from the stateless tests so we can easily +-- comment it out. +stateDependentTests :: AppState -> TestTree +stateDependentTests s = + testGroup + "Stateful tests" + [ testEval (s ^. playState . scenarioState . gameState) + , testPedagogy (s ^. playState . progression) + , testNotification (s ^. playState . scenarioState . gameState) + ] + +statelessTests :: TestTree +statelessTests = + testGroup + "Stateless tests" [ testLanguagePipeline , testParse , testPrettyConst , testBoolExpr , testCommands + , testContext , testHighScores - , testEval (s ^. gameState) , testRepl , testRequirements - , testPedagogy (s ^. runtimeState) , testInventory - , testNotification (s ^. gameState) , testOrdering , testOverlay , testMisc , testLSP + , testQQ ] testMisc :: TestTree diff --git a/test/unit/TestContext.hs b/test/unit/TestContext.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestContext.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Swarm unit tests for contexts +module TestContext where + +import Control.Monad (replicateM) +import Data.Hashable +import Data.List (nub) +import Data.Map qualified as M +import Data.Yaml (decodeEither', encode) +import Swarm.Language.Context +import Swarm.Language.Var (Var) +import Swarm.Util (showT) +import Test.QuickCheck.Instances.Text () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase) +import Test.Tasty.QuickCheck (Arbitrary (..), Gen, generate, testProperty, withMaxSuccess) + +testContext :: TestTree +testContext = + testGroup + "Contexts" + [ testGroup + "Context equality" + [ testCase "idempotence 1" $ ctxsEqual ctx1 (ctx1 <> ctx1) + , testCase "idempotence 2" $ ctxsEqual ctx2 (ctx2 <> ctx2) + , testCase "deletion" $ ctxsEqual ctx1 (delete "z" ctx2) + , testCase "empty/delete" $ ctxsEqual empty (delete "x" ctx1) + , testCase "fromMap" $ ctxsEqual ctx2 (fromMap (M.fromList [("x", 3), ("z", 6)])) + , testCase "right bias" $ ctxsEqual ctx4 (ctx2 <> ctx3) + , testCase "commutativity" $ ctxsEqual (ctx1 <> ctx5) (ctx5 <> ctx1) + ] + , testGroup + "de/rehydrate round-trip" + (map (\(name, ctx) -> testCase name $ hydrationRoundTrip ctx) testCtxs) + , testGroup + "serialize round-trip" + (map (\(name, ctx) -> testCase name $ serializeRoundTrip ctx) testCtxs) + , testProperty + "no paired hash collisions" + (withMaxSuccess 10000 (hashConsistent @Var @Int)) + , testCase + "no hash collisions in a large pool" + $ do + ctxs <- generate (replicateM 100000 (arbitrary :: Gen (Ctx Var Int))) + let m = M.fromListWith (++) (map (\ctx -> (ctxHash ctx, [unCtx ctx])) ctxs) + assertBool "foo" $ all ((== 1) . length . nub) m + ] + where + ctx1 = singleton "x" 3 + ctx2 = singleton "x" 3 <> singleton "z" 6 + ctx3 = singleton "x" 5 <> singleton "y" 7 + ctx4 = singleton "x" 5 <> singleton "y" 7 <> singleton "z" 6 + ctx5 = singleton "y" 10 + bigCtx = fromMap . M.fromList $ zip (map (("x" <>) . showT) [1 :: Int ..]) [1 .. 10000] + + testCtxs = [("empty", empty), ("ctx1", ctx1), ("ctx2", ctx2), ("ctx3", ctx3), ("ctx4", ctx4), ("ctx5", ctx5), ("large", bigCtx), ("delete", delete "y" ctx4)] + +instance (Ord v, Hashable v, Arbitrary v, Hashable a, Arbitrary a) => Arbitrary (Ctx v a) where + arbitrary = fromMap <$> arbitrary + +hashConsistent :: (Eq v, Eq a) => Ctx v a -> Ctx v a -> Bool +hashConsistent ctx1 ctx2 = (ctx1 == ctx2) == (ctx1 `ctxStructEqual` ctx2) + +ctxsEqual :: Ctx Var Int -> Ctx Var Int -> Assertion +ctxsEqual ctx1 ctx2 = do + -- Contexts are compared by hash for equality + assertEqual "hash equality" ctx1 ctx2 + + -- Make sure they are also structurally equal + assertBool "structural equality" (ctxStructEqual ctx1 ctx2) + +ctxStructEqual :: (Eq a, Eq v) => Ctx v a -> Ctx v a -> Bool +ctxStructEqual (Ctx m1 _) (Ctx m2 _) = m1 == m2 + +hydrationRoundTrip :: Ctx Var Int -> Assertion +hydrationRoundTrip ctx = do + case getCtx (ctxHash ctx) (rehydrate (dehydrate (toCtxMap ctx))) of + Nothing -> fail "Failed to reconstitute dehydrated context" + Just ctx' -> ctxsEqual ctx ctx' + +serializeRoundTrip :: Ctx Var Int -> Assertion +serializeRoundTrip ctx = do + case decodeEither' (encode (dehydrate (toCtxMap ctx))) of + Left e -> fail $ "Failed to decode JSON-encoded context: " ++ show e + Right c -> case getCtx (ctxHash ctx) (rehydrate c) of + Nothing -> fail "Failed to reconstitute dehydrated context" + Just ctx' -> ctxsEqual ctx ctx' diff --git a/test/unit/TestEval.hs b/test/unit/TestEval.hs --- a/test/unit/TestEval.hs +++ b/test/unit/TestEval.hs @@ -9,10 +9,16 @@ import Control.Lens ((^.), _3) import Data.Char (ord) +import Data.Fix import Data.Map qualified as M import Data.Text (Text) import Data.Text qualified as T +import Graphics.Vty.Input.Events qualified as V import Swarm.Game.State +import Swarm.Game.Value (Valuable (..)) +import Swarm.Language.Key +import Swarm.Language.Syntax.Direction +import Swarm.Language.Types import Swarm.Language.Value import Test.Tasty import Test.Tasty.HUnit @@ -145,7 +151,7 @@ "operator evaluation" [ testCase "application operator #239" - ("fst $ snd $ (1,2,3)" `evaluatesTo` VInt 2) + ("(\\x. -x) $ (\\x. x^2) $ 2" `evaluatesTo` VInt (-4)) ] , testGroup "recursive bindings" @@ -202,19 +208,19 @@ ("fail \"foo\"" `throwsError` ("foo" `T.isInfixOf`)) , testCase "try / no exception 1" - ("try {return 1} {return 2}" `evaluatesTo` VInt 1) + ("try {pure 1} {pure 2}" `evaluatesTo` VInt 1) , testCase "try / no exception 2" - ("try {return 1} {let x = x in x}" `evaluatesTo` VInt 1) + ("try {pure 1} {let x = x in x}" `evaluatesTo` VInt 1) , testCase "try / fail" - ("try {fail \"foo\"} {return 3}" `evaluatesTo` VInt 3) + ("try {fail \"foo\"} {pure 3}" `evaluatesTo` VInt 3) , testCase "try / fail / fail" ("try {fail \"foo\"} {fail \"bar\"}" `throwsError` ("bar" `T.isInfixOf`)) , testCase "try / div by 0" - ("try {return (1/0)} {return 3}" `evaluatesTo` VInt 3) + ("try {pure (1/0)} {pure 3}" `evaluatesTo` VInt 3) ] , testGroup "text" @@ -269,6 +275,156 @@ ) ] , testGroup + "read" + [ testCase + "read Unit" + ("read @Unit \"()\"" `evaluatesToV` ()) + , testCase + "read Unit with spaces" + ("read @Unit \" () \"" `evaluatesToV` ()) + , testCase + "no read Unit" + ("read @Unit \"xyz\"" `throwsError` ("Could not read" `T.isInfixOf`)) + , testCase + "read Int" + ("read @Int \"32\"" `evaluatesToV` (32 :: Integer)) + , testCase + "read negative Int" + ("read @Int \"-32\"" `evaluatesToV` (-32 :: Integer)) + , testCase + "read Int with spaces" + ("read @Int \" - 32 \"" `evaluatesToV` (-32 :: Integer)) + , testCase + "no read Int" + ("read @Int \"32.0\"" `throwsError` ("Could not read" `T.isInfixOf`)) + , testCase + "read false" + ("read @Bool \"false\"" `evaluatesToV` False) + , testCase + "read true" + ("read @Bool \"true\"" `evaluatesToV` True) + , testCase + "read forward" + ( "read @Dir \"forward\"" + `evaluatesTo` VDir (DRelative (DPlanar DForward)) + ) + , testCase + "read east" + ("read @Dir \"east\"" `evaluatesTo` VDir (DAbsolute DEast)) + , testCase + "read down" + ("read @Dir \"down\"" `evaluatesTo` VDir (DRelative DDown)) + , testCase + "read text" + ("read @Text \"\\\"hi\\\"\"" `evaluatesToV` ("hi" :: Text)) + , testCase + "read sum inl" + ( "read @(Int + Bool) \"inl 3\"" + `evaluatesToV` Left @Integer @Bool 3 + ) + , testCase + "read sum inr" + ( "read @(Int + Bool) \"inr true\"" + `evaluatesToV` Right @Integer True + ) + , testCase + "read nested sum" + ( "read @((Int + Bool) + Unit) \"inl (inr true)\"" + `evaluatesToV` Left @_ @() (Right @Integer True) + ) + , testCase + "read pair" + ( "read @(Int * Bool) \"(3, true)\"" + `evaluatesToV` (3 :: Integer, True) + ) + , testCase + "read pair with non-atomic value" + ( "read @(Int * (Unit + Bool)) \"(3, inr true)\"" + `evaluatesToV` (3 :: Integer, Right @() True) + ) + , testCase + "read nested pair" + ( "read @(Int * Bool * Unit) \"(3, true, ())\"" + `evaluatesToV` (3 :: Integer, (True, ())) + ) + , testCase + "read left-nested pair" + ( "read @((Int * Bool) * Unit) \"((3, true), ())\"" + `evaluatesToV` ((3 :: Integer, True), ()) + ) + , testCase + "read empty record" + ("read @[] \"[]\"" `evaluatesTo` VRcd M.empty) + , testCase + "read singleton record" + ( "read @[x : Int] \"[x = 2]\"" + `evaluatesTo` VRcd (M.singleton "x" (VInt 2)) + ) + , testCase + "read doubleton record" + ( "read @[x : Int, y : Bool + Unit] \"[x = 2, y = inr ()]\"" + `evaluatesTo` (VRcd . M.fromList $ [("x", VInt 2), ("y", VInj True VUnit)]) + ) + , testCase + "read permuted doubleton record" + ( "read @[x : Int, y : Bool + Unit] \"[y = inr (), x = 2]\"" + `evaluatesTo` (VRcd . M.fromList $ [("x", VInt 2), ("y", VInj True VUnit)]) + ) + , testCase + "no read record with repeated fields" + ( "read @[x : Int] \"[x = 2, x = 3]\"" + `throwsError` ("Could not read" `T.isInfixOf`) + ) + , testCase + "read key" + ( "read @Key \"key \\\"M-C-F5\\\"\"" + `evaluatesTo` VKey (mkKeyCombo [V.MCtrl, V.MMeta] (V.KFun 5)) + ) + , testCase + "read recursive list" + ( "read @(rec l. Unit + (Int * l)) \"inr (3, inr (5, inl ()))\"" + `evaluatesToV` [3 :: Integer, 5] + ) + , testCase + "read paper with int" + ("read @Int \"paper: 52\"" `evaluatesToV` (52 :: Integer)) + , testCase + "read paper with tuple" + ( "read @(Int * Bool * Unit) \"paper: (3, false, ())\"" + `evaluatesToV` (3 :: Integer, (False, ())) + ) + , testCase + "read random entity with tuple" + ( "read @(Int * Bool * Unit) \"foo: (3, false, ())\"" + `evaluatesToV` (3 :: Integer, (False, ())) + ) + , testCase + "read Text value containing colon" + ( "read @Text \"\\\"hi: there\\\"\"" + `evaluatesToV` ("hi: there" :: Text) + ) + , testCase + "read at user-defined type Foo = Int" + ( "tydef Foo = Int end; read @Foo \"3\"" + `evaluatesToV` (3 :: Integer) + ) + , testCase + "read at user-defined recursive type" + ( "tydef List a = rec l. Unit + a * l end; read @(List(Int)) \"inr (1, inl ())\"" + `evaluatesToV` [1 :: Integer] + ) + , testCase + "read at complex type with user-defined types" + ( "tydef Foo = Int end; read @(Bool * Foo) \"(True, 3)\"" + `evaluatesToV` (True, 3 :: Integer) + ) + , testCase + "read at nested user-defined type" + ( "tydef A = Int end; tydef B = Bool end; tydef C = B * A end; read @C \"(True, 3)\"" + `evaluatesToV` (True, 3 :: Integer) + ) + ] + , testGroup "records - #1093" [ testCase "empty record" @@ -312,39 +468,54 @@ "scope - #681" [ testCase "binder in local scope" - ("def f = a <- scan down end; let a = 2 in f; return (a+1)" `evaluatesTo` VInt 3) + ("def f = a <- scan down end; let a = 2 in f; pure (a+1)" `evaluatesTo` VInt 3) , testCase "binder in local scope, no type change" - ("def f = a <- return 1 end; let a = 2 in f; return a" `evaluatesTo` VInt 2) + ("def f = a <- pure 1 end; let a = 2 in f; pure a" `evaluatesTo` VInt 2) , testCase "repeat with scan" - ("def x = \\n. \\c. if (n==0) {} {c; x (n-1) c} end; x 10 ( c <- scan down; case c (\\_. say \"Hi\") (\\_. return ()))" `evaluatesTo` VUnit) + ("def x = \\n. \\c. if (n==0) {} {c; x (n-1) c} end; x 10 ( c <- scan down; case c (\\_. say \"Hi\") (\\_. pure ()))" `evaluatesTo` VUnit) , testCase "nested recursion with binder - #1032" - ("def go = \\n. if (n > 0) {i <- return n; s <- go (n-1); return (s+i)} {return 0} end; go 4" `evaluatesTo` VInt 10) + ("def go = \\n. if (n > 0) {i <- pure n; s <- go (n-1); pure (s+i)} {pure 0} end; go 4" `evaluatesTo` VInt 10) , testCase "binder in local scope - #1796" - ("def x = \\x.x end; def foo = x <- return 0 end; foo; return (x 42)" `evaluatesTo` VInt 42) + ("def x = \\x.x end; def foo = x <- pure 0 end; foo; pure (x 42)" `evaluatesTo` VInt 42) ] , testGroup "nesting" [ testCase "def nested in def" - ("def x : Cmd Int = def y : Int = 3 end; return (y + 2) end; x" `evaluatesTo` VInt 5) + ("def x : Cmd Int = def y : Int = 3 end; pure (y + 2) end; x" `evaluatesTo` VInt 5) , testCase "nested def does not escape" - ( "def z = 1 end; def x = def z = 3 end; return (z + 2) end; n <- x; return (n + z)" + ( "def z = 1 end; def x = def z = 3 end; pure (z + 2) end; n <- x; pure (n + z)" `evaluatesTo` VInt 6 ) , testCase "nested tydef" - ( "def x = (tydef X = Int end; def z : X = 3 end; return (z + 2)) end; x" + ( "def x = (tydef X = Int end; def z : X = 3 end; pure (z + 2)) end; x" `evaluatesTo` VInt 5 ) ] , testCase "tydef does not prevent forcing of recursive variables" ("def forever = \\c. c; forever c end; tydef X = Int end; def go = forever move end" `evaluatesTo` VUnit) + , testGroup + "term-level types" + [ testCase + "Int" + ("@Int" `evaluatesTo` VType TyInt) + , testCase + "Int * Bool" + ("@(Int * Bool)" `evaluatesTo` VType (TyInt :*: TyBool)) + , testCase + "foo" + ("@(rec a. a)" `evaluatesTo` VType (TyRec "a" (Fix (TyRecVarF NZ)))) + , testCase + "list" + ("@(rec l. Unit + Int * l)" `evaluatesTo` VType (TyRec "l" (TyUnit :+: (TyInt :*: Fix (TyRecVarF NZ))))) + ] ] where tquote :: String -> Text @@ -363,12 +534,15 @@ evaluatesTo :: Text -> Value -> Assertion evaluatesTo tm val = do result <- evaluate tm - assertEqual "" (Right val) (fst <$> result) + assertBool "" $ Right val == (fst <$> result) + evaluatesToV :: Valuable v => Text -> v -> Assertion + evaluatesToV tm val = tm `evaluatesTo` asValue val + evaluatesToP :: Text -> Value -> Property evaluatesToP tm val = ioProperty $ do result <- evaluate tm - return $ Right val === (fst <$> result) + return . property $ Right val == (fst <$> result) evaluatesToInAtMost :: Text -> (Value, Int) -> Assertion evaluatesToInAtMost tm (val, maxSteps) = do @@ -376,7 +550,7 @@ case result of Left err -> assertFailure ("Evaluation failed: " ++ from @Text @String err) Right (v, steps) -> do - assertEqual "" val v + assertBool "Values are not equal" (val == v) assertBool ("Took more than " ++ show maxSteps ++ " steps!") (steps <= maxSteps) evaluate :: Text -> IO (Either Text (Value, Int)) diff --git a/test/unit/TestLSP.hs b/test/unit/TestLSP.hs --- a/test/unit/TestLSP.hs +++ b/test/unit/TestLSP.hs @@ -72,6 +72,22 @@ checkFile "single-bind-used.sw" [] + , testCase "lambda with var used inside annotation" $ + checkFile + "lambda-with-annot.sw" + [] + , testCase "record with used var" $ + checkFile + "lambda-with-record-used.sw" + [] + , testCase "record with used var abbrev" $ + checkFile + "lambda-with-record-used-abbrev.sw" + [] + , testCase "record with unused var" $ + checkFile + "lambda-with-record-unused.sw" + [UnusedVar "y" VU.Lambda] ] where checkFile :: FilePath -> [UnusedVar] -> IO () diff --git a/test/unit/TestLanguagePipeline.hs b/test/unit/TestLanguagePipeline.hs --- a/test/unit/TestLanguagePipeline.hs +++ b/test/unit/TestLanguagePipeline.hs @@ -20,10 +20,10 @@ import Swarm.Language.Parser.QQ (tyQ) import Swarm.Language.Pipeline (processTerm) import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax import Swarm.Language.Typecheck (isSimpleUType) import Swarm.Language.Types +import Swarm.Pretty (prettyText) import Test.Tasty import Test.Tasty.HUnit import Witch (from) @@ -33,27 +33,27 @@ testGroup "Language - pipeline" [ testCase "end semicolon #79" (valid "def a = 41 end def b = a + 1 end def c = b + 2 end") - , testCase - "quantification #148 - implicit" - (valid "def id : a -> a = \\x. x end; id move") - , testCase - "quantification #148 - explicit" - (valid "def id : forall a. a -> a = \\x. x end; id move") - , testCase - "quantification #148 - explicit with free tyvars" - ( process - "def id : forall a. b -> b = \\x. x end; id move" - ( T.unlines - [ "1:27:" - , " |" - , "1 | def id : forall a. b -> b = \\x. x end; id move" - , " | ^" - , " Type contains free variable(s): b" - , " Try adding them to the 'forall'." - , "" - ] + , testGroup + "quantification + scope" + [ testCase + "quantification #148 - implicit" + (valid "def id : a -> a = \\x. x end; id move") + , testCase + "quantification #148 - explicit" + (valid "def id : forall a. a -> a = \\x. x end; id move") + , testCase + "quantification #148 - explicit with free tyvars" + (valid "def id : forall a. b -> b = \\x. x end; id move") + , testCase + "type variable scope #2178" + (valid "def f : a -> (a * Int) = \\x. let g : a * Int = (x, 3) in g end") + , testCase + "type variable scope #2178 - shadowing" + ( process + "def f : a -> (a * Int) = \\x. let g : forall a. a * Int = (x, 3) in g end" + "1:59: Type mismatch:\n From context, expected `x` to have type `a`,\n but it actually has type `a`" ) - ) + ] , testCase "parsing operators #188 - parse valid operator (!=)" (valid "1!=(2)") @@ -62,7 +62,7 @@ (valid "1 <= 2") , testCase "parsing operators #239 - parse valid operator ($)" - (valid "fst $ snd $ (1,2,3)") + (valid "(\\x. -x) $ (\\x. x^2) $ 2") , testGroup "Identifiers" [ testCase @@ -154,7 +154,7 @@ "failure inside function call" ( process "if true \n{} \n(move)" - "3:1: Type mismatch:\n From context, expected `move` to have type `{Cmd Unit}`,\n but it actually has type `Cmd Unit`" + "3:2: Type mismatch:\n From context, expected `move` to have type `{Cmd Unit}`,\n but it actually has type `Cmd Unit`" ) , testCase "parsing operators #236 - report failure on invalid operator start" @@ -176,8 +176,8 @@ "require device" (valid "require \"boat\"") , testCase - "require entities" - (valid "require 64 \"rock\"") + "stock entities" + (valid "stock 64 \"rock\"") , testCase "invalid syntax to require" ( process @@ -188,19 +188,19 @@ , "1 | require x" , " | ^" , "unexpected 'x'" - , "expecting device name in double quotes or integer literal" + , "expecting device name in double quotes" ] ) ) , testCase - "invalid syntax to require n" + "invalid syntax to stock n" ( process - "require 2 x" + "stock 2 x" ( T.unlines - [ "1:11:" + [ "1:9:" , " |" - , "1 | require 2 x" - , " | ^" + , "1 | stock 2 x" + , " | ^" , "unexpected 'x'" , "expecting entity name in double quotes" ] @@ -216,25 +216,24 @@ "atomic - #479" [ testCase "atomic move" - ( valid "atomic move" - ) + (valid "atomic move") , testCase "grabif" - (valid "def grabif : Text -> Cmd Unit = \\x. atomic (b <- ishere x; if b {grab; return ()} {}) end") + (valid "def grabif : Text -> Cmd Unit = \\x. atomic (b <- ishere x; if b {grab; pure ()} {}) end") , testCase "placeif" - (valid "def placeif : Text -> Cmd Bool = \\thing. atomic (res <- scan down; if (res == inl ()) {place thing; return true} {return false}) end") + (valid "def placeif : Text -> Cmd Bool = \\thing. atomic (res <- scan down; if (res == inl ()) {place thing; pure true} {pure false}) end") , testCase "atomic move+move" ( process "atomic (move; move)" - "1:8: Invalid atomic block: block could take too many ticks (2): `move; move`" + "1:8: Invalid atomic block: block could take too many ticks (2): `(move; move)`" ) , testCase "atomic lambda" ( process "atomic ((\\c. c;c) move)" - "1:9: Invalid atomic block: def, let, and lambda are not allowed: `\\c. c; c`" + "1:10: Invalid atomic block: def, let, and lambda are not allowed: `\\c. c; c`" ) , testCase "atomic non-simple" @@ -270,8 +269,11 @@ "atomic salvage" ( process "atomic (salvage)" - "1:8: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `salvage`" + "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `salvage`" ) + , testCase + "atomic with comment #2412" + (valid "atomic (if true {c <- scan down; /* COMMENT */ noop } {})") ] , testGroup "integer literals" @@ -298,8 +300,7 @@ "Void type" [ testCase "isSimpleUType" - ( assertBool "" $ isSimpleUType UTyVoid - ) + (assertBool "" $ isSimpleUType UTyVoid) , testCase "valid type signature" (valid "def f : Void -> a = \\x. undefined end") @@ -330,6 +331,36 @@ "(\\r:[x:Int, y:Int]. r.x) [x = 3, z = 5]" "1:26: Field mismatch; record literal has:\n - Extra field(s) `z`\n - Missing field(s) `y`" ) + , testCase + "type mismatch with record projection" + ( process + "\\x:Int. x.y" + "1:9: Type mismatch:\n From context, expected `x` to have a record type,\n but it actually has type `Int`" + ) + , testCase + "inference failure with record projection" + ( process + "\\x. x.y" + "1:5: In the record projection `x.y`, can't infer whether the LHS has a record type. Try adding a type annotation." + ) + , testCase + "infer record projection with tydef" + (valid "tydef R = [x:Int] end; def f : R -> Int = \\r. r.x end") + , testCase + "infer record projection with nested tydef" + (valid "tydef B = [x:Int] end; tydef A = B end; def f : A -> Int = \\r. r.x end") + , testCase + "infer record projection with tydef and recursive type" + (valid "tydef S = rec s. [hd:Int, tl:s] end; def two : S -> Int = \\s. s.tl.hd end") + , testCase + "infer record projection with tydef - RBTree" + (valid "tydef Color = Bool end; tydef RBTree k v = rec b. Unit + [c: Color, k: k, v: v, l: b, r: b] end; def balanceLR : RBTree k v -> RBTree k v = \\ln. case ln undefined (\\ne. ne.r) end") + , testCase + "infer record projection with tydef - RBTree, error" + ( process + "tydef Color = Bool end; tydef RBTree k v = rec b. Unit + [c: Color, k: k, v: v, l: b, r: b] end; def balanceLR : RBTree k v -> RBTree k v = \\ln. case ln.r undefined undefined end" + "1:151: Type mismatch:\n From context, expected `ln` to have a record type,\n but it actually has type `Unit +" + ) ] , testGroup "type annotations" @@ -346,6 +377,7 @@ isVar (TVar {}) = True isVar _ = False + getVars :: TSyntax -> [(Term' Polytype, Polytype)] getVars = map (_sTerm &&& _sType) . filter (isVar . _sTerm) . universe in assertEqual "variable types" @@ -365,21 +397,21 @@ (valid "((\\x . x) : a -> a) 3") , testCase "type ascription too general" - (process "1 : a" "1:1: Type mismatch:\n From context, expected `1` to have type `s0`,\n but it actually has type `Int`") + (process "1 : a" "1:1: Type mismatch:\n From context, expected `1` to have type `a`,\n but it actually has type `Int`") , testCase "type specialization through type ascription" - (valid "fst:(Int + b) * a -> Int + b") + (valid "match : (Int + b) * a -> ((Int + b) -> a -> c) -> c") , testCase "type ascription doesn't allow rank 2 types" ( process "\\f. (f:forall a. a->a) 3" - "1:5: Skolem variable s3 would escape its scope" + "1:24: Type mismatch:\n From context, expected `3` to have type `a`,\n but it actually has type `Int`" ) , testCase "checking a lambda with the wrong argument type" ( process "(\\x:Int. x + 2) : Text -> Int" - "1:1: Lambda argument has type annotation `Int`, but expected argument type `Text`" + "1:2: Lambda argument has type annotation `Int`, but expected argument type `Text`" ) ] , testGroup @@ -518,7 +550,7 @@ "unify two-argument function and Int" ( process "1 + (\\x. \\y. 3)" - "1:5: Type mismatch:\n From context, expected `\\x. \\y. 3` to have type `Int`,\n but it is actually a function\n" + "1:6: Type mismatch:\n From context, expected `\\x. \\y. 3` to have type `Int`,\n but it is actually a function\n" ) , testCase "apply HOF to int - #1888" @@ -526,18 +558,24 @@ "(\\f. f 3) 2" "1:11: Type mismatch:\n From context, expected `2` to have a type like `Int -> _`" ) + , testCase + "inferring type of bad recursive function - #2186" + ( process + "def fst = \\p. match p \\a. \\_. a end; def bad = \\acc. \\n. if (n <= 0) {fst acc} {bad (fst acc + 1) (n - 1)} end" + "1:38: Type mismatch:\n From context, expected `\\acc. \\n. if (n <= 0) {fst acc} {\n bad (fst acc + 1) (n - 1)\n }` to have type `Int -> Int -> Int`,\n but it actually has a type like `(Int * _) -> Int -> Int`" + ) ] , testGroup "generalize top-level binds #351 #1501" [ testCase "top-level polymorphic bind is OK" - (valid "r <- return (\\x.x)") + (valid "r <- pure (\\x.x)") , testCase "top-level bind is polymorphic" - (valid "f <- return (\\x.x); return (f 3, f \"hi\")") + (valid "f <- pure (\\x.x); pure (f 3, f \"hi\")") , testCase "local bind is polymorphic" - (valid "def foo : Cmd (Int * Text) = f <- return (\\x.x); return (f 3, f \"hi\") end") + (valid "def foo : Cmd (Int * Text) = f <- pure (\\x.x); pure (f 3, f \"hi\") end") ] , testGroup "type synonyms" @@ -588,18 +626,29 @@ "tydef Unbound a b = a + b + c end" "1:34:\n |\n1 | tydef Unbound a b = a + b + c end\n | ^\nUndefined type variable(s) on right-hand side of tydef: c\n" ) + , testCase + "tydef shadowing #2437" + ( process + "tydef Foo = Int end; def f : Int -> Foo = \\x. x + 1 end; tydef Foo = Bool end; if (f 3) {} {}" + "1:84: Type mismatch:\n From context, expected `f 3` to have type `Bool`,\n but it actually has type `Foo`" + ) + , testCase + "tydef shadowing #2437" + ( valid + "tydef Foo = Int end; def f : Int -> Foo = \\x. x + 1 end; tydef Foo = Bool end; def g : Int -> Foo = \\x. x > 5 end; if (g (f 3)) {} {}" + ) ] , testGroup "recursive types" [ testCase "occurs check" ( process - "def sum = \\l. case l (\\_. 0) (\\c. fst c + sum (snd c)) end" + "def sum = \\l. case l (\\_. 0) (\\c. match c \\hd. \\tl. hd + sum tl) end" "Encountered infinite type u6 = Int * (u5 + u6).\nSwarm will not infer recursive types; if you want a recursive type, add an explicit type annotation." ) , testCase "no occurs check with type annotation" - (valid "def sum : (rec l. Unit + Int * l) -> Int = \\l. case l (\\_. 0) (\\c. fst c + sum (snd c)) end") + (valid "def sum : (rec l. Unit + Int * l) -> Int = \\l. case l (\\_. 0) (\\c. match c \\hd. \\tl. hd + sum tl) end") , testCase "vacuous" ( process @@ -631,21 +680,42 @@ "1:1: Undefined type U" ) ] - , testCase - "Stop printing context after a definition. - #1336" - ( processCompare - (==) - "move; def x = move; say 3 end; move;" - "1:25: Type mismatch:\n From context, expected `3` to have type `Text`,\n but it actually has type `Int`\n\n - While checking the right-hand side of a semicolon\n - While checking the definition of x" - ) , testGroup + "typechecking context stack" + [ testCase + "Stop printing context after a definition. - #1336" + ( processCompare + (==) + "move; def x = move; say 3 end; move;" + "1:25: Type mismatch:\n From context, expected `3` to have type `Text`,\n but it actually has type `Int`\n\n - While checking the argument to a function: say _\n - While checking the definition of x" + ) + , testCase + "Error inside function application + argument #2220" + ( process + "id 3 3" + "1:1: Unbound variable id\n\n - While checking a function applied to an argument: _ 3\n - While checking a function applied to an argument: _ 3" + ) + , testCase + "Error inside function application + argument #2220" + ( process + "(\\x. x) 7 8" + "1:1: Type mismatch:\n From context, expected `(\\x. x) 7` to be a function,\n but it actually has type `Int`\n\n - While checking a function applied to an argument: _ 8" + ) + , testCase + "Nested error #2220" + ( process + "\"hi\" + 2" + "1:1: Type mismatch:\n From context, expected `\"hi\"` to have type `Int`,\n but it actually has type `Text`\n\n - While checking the argument to a function: (+) _\n - While checking a function applied to an argument: _ 2" + ) + ] + , testGroup "let and def types" [ testCase "let at non-cmd type" (valid "let x = 3 in x + 2") , testCase "let at cmd type" - (valid "let x = 3 in move; return (x+2)") + (valid "let x = 3 in move; pure (x+2)") , testCase "def at non-cmd type" ( process @@ -654,7 +724,40 @@ ) , testCase "def at cmd type" - (valid "def x = 3 end; move; return (x+2)") + (valid "def x = 3 end; move; pure (x+2)") + ] + , testGroup + "nested let/def/annot #2101" + [ testCase + "nested polymorphic def/let" + (valid "def id : a -> a = \\y. let x = 3 in y end") + , testCase + "nested polymorphic def/annot" + (valid "def id : a -> a * Int = \\y. (y, 3 : Int) end") + ] + , testGroup + "Custom error message for missing end #1141" + [ testCase + "missing end" + ( process + "def x = 3;\n def y = 3 end;\n def z = 3 end" + "3:15:\n |\n3 | def z = 3 end\n | ^\nunexpected end of input\nexpecting \"!=\", \"&&\", \"()\", \"++\", \"<=\", \"==\", \">=\", \"def\", \"false\", \"let\", \"require\", \"requirements\", \"stock\", \"true\", \"tydef\", \"||\", '\"', '$', '(', '*', '+', '-', '.', '/', ':', ';', '<', '>', '@', '[', '\\', '^', 'end' keyword for definition of 'x', '{', built-in user function, direction constant, integer literal, or variable name\n" + ) + ] + , testGroup + "Typechecking for read #2461" + [ testCase + "read type argument propagates" + ( process + "(read @Int \"3\") 4" + "1:1: Type mismatch:\n From context, expected `(read @Int \"3\")` to be a function,\n but it actually has type `Int`" + ) + , testCase + "read at type stored in a variable" + ( process + "def T : Type = @(Bool * Int) end; read T \"(True, 3)\"" + "1:35: The `read` command must be given a literal type as its first argument (Swarm does not have dependent types); found `T` instead." + ) ] ] where diff --git a/test/unit/TestOverlay.hs b/test/unit/TestOverlay.hs --- a/test/unit/TestOverlay.hs +++ b/test/unit/TestOverlay.hs @@ -4,30 +4,128 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Unit tests for generic grid overlay logic -module TestOverlay where +module TestOverlay (testOverlay) where +import Control.Monad (when) +import Data.Function (on) +import Data.Text (Text) import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Area ( + AreaDimensions (AreaDimensions), + ) import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Placement +import Swarm.Game.Scenario.Topography.Structure +import Swarm.Game.Scenario.Topography.Structure.Assembly ( + foldLayer, + ) +import Swarm.Game.Scenario.Topography.Structure.Named import Swarm.Game.Scenario.Topography.Structure.Overlay import Test.Tasty import Test.Tasty.HUnit +debugRenderGrid :: Bool +debugRenderGrid = False + +-- * Example grids + +-- | Single cell +oneByOneGrid :: [[Int]] +oneByOneGrid = [[0]] + +-- | Single row with two columns +oneByTwoGrid :: [[Int]] +oneByTwoGrid = [[5, 6]] + +-- | Two rows with two columns +twoByTwoGrid :: [[Int]] +twoByTwoGrid = + [ [1, 2] + , [3, 4] + ] + testOverlay :: TestTree testOverlay = testGroup "Overlay" - [ -- Overlay is to the east and north of the base. - -- Therefore, the origin of the combined grid must - -- be adjusted southward to match its original position - -- in the base layer. - mkOriginTestCase "Southward" (Location 3 2) (Location 0 (-2)) - , -- Overlay is to the west and south of the base. - -- Therefore, the origin of the combined grid must - -- be adjusted eastward to match its original position - -- in the base layer. - mkOriginTestCase "Eastward" (Location (-7) (-1)) (Location 7 0) + [ testGroup + "Empty grids, base grid at origin" + [ mkOriginTestCase "Northward" (Location 3 2) (Location 0 2) + , mkOriginTestCase "Westward" (Location (-7) (-1)) (Location (-7) 0) + ] + , testGroup + "Overlay sequences" + [ testGroup + "Horizontal siblings" + [ mkOverlaySequenceOriginTest + "negative first west of second" + [ placeUnshifted "sibling1" (Location (-2) 0) twoByTwoGrid + , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid + ] + (Location (-2) 0) + , mkOverlaySequenceOriginTest + "first east of negative second" + [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid + , placeUnshifted "sibling2" (Location (-2) 0) oneByTwoGrid + ] + (Location (-2) 0) + ] + , testGroup + "Vertical siblings" + [ mkOverlaySequenceOriginTest + "positive first south of second" + [ placeUnshifted "sibling1" (Location 0 2) twoByTwoGrid + , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid + ] + (Location 0 2) + , mkOverlaySequenceOriginTest + "first north of positive second" + [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid + , placeUnshifted "sibling2" (Location 0 2) oneByTwoGrid + ] + (Location 0 2) + ] + , testGroup + "Merge sizes" + [ testMergedSize + "merge an offset 1x1 atop a 0x0 base" + (mkNamedStructure "baseLayer" (Location 0 0) [[]]) + (mkNamedStructure "sibling1" (Location (-1) 1) oneByOneGrid) + (AreaDimensions 1 1) + , testMergedSize + "merge a 2x2 atop a 1x1 with an offset" + (mkNamedStructure "sibling1" (Location (-1) 1) oneByOneGrid) + (mkNamedStructure "sibling2" (Location 0 0) twoByTwoGrid) + (AreaDimensions 3 3) + ] + , testGroup + "Northwesterly offset of first sibling" + [ mkOverlaySequenceOriginTest + "positive first south of second" + [ placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid + , placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid + ] + (Location (-1) 1) + ] + ] ] +-- * Test construction +testMergedSize :: + String -> + NamedStructure (Maybe Int) -> + NamedStructure (Maybe Int) -> + AreaDimensions -> + TestTree +testMergedSize testLabel ns1 ns2 expectedArea = + testCase testLabel $ do + assertEqual "Merged area is wrong" expectedArea mergedSize + where + mergedSize = + computeMergedArea $ + (OverlayPair `on` (area . structure)) ns1 ns2 + +-- | Base layer is at the origin (0, 0). mkOriginTestCase :: String -> Location -> @@ -40,3 +138,82 @@ baseLayer = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe ())) overlayLayer = PositionedGrid overlayLocation EmptyGrid PositionedGrid actualBaseLoc _ = baseLayer <> overlayLayer + +mkOverlaySequenceOriginTest :: + String -> + [Placed (Maybe Int)] -> + Location -> + TestTree +mkOverlaySequenceOriginTest = mkOverlaySequenceTest gridPosition + +mkOverlaySequenceTest :: + (Show a, Eq a) => + (PositionedGrid (Maybe Int) -> a) -> + String -> + [Placed (Maybe Int)] -> + a -> + TestTree +mkOverlaySequenceTest f testLabel overlays expectedBaseLoc = + testCase testLabel $ do + when debugRenderGrid $ + renderGridResult eitherResultGrid + + assertEqual "Base loc wrong" (Right expectedBaseLoc) $ + f <$> eitherResultGrid + where + baseArea = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe Int)) + + eitherResultGrid = getGridFromMergedStructure <$> eitherResult + eitherResult = + foldLayer + mempty + baseArea + overlays + [] + +getGridFromMergedStructure :: MergedStructure c -> PositionedGrid c +getGridFromMergedStructure (MergedStructure g _ _) = g + +-- | Place an structure at an offset. +-- The structure's local origin is (0, 0). +placeUnshifted :: + Text -> + Location -> + [[a]] -> + Placed (Maybe a) +placeUnshifted = place (Location 0 0) + +-- | Place a structure at an offset. +-- That structure's local origin might not be (0, 0). +place :: + Location -> + Text -> + Location -> + [[a]] -> + Placed (Maybe a) +place localOrigin theName placementOffset g = + Placed (Placement sName (Pose placementOffset defaultOrientation)) $ + mkNamedStructure theName localOrigin g + where + sName = StructureName theName + +mkNamedStructure :: + Text -> + Location -> + [[a]] -> + NamedArea (PStructure (Maybe a)) +mkNamedStructure theName pos g = + NamedArea sName mempty mempty s + where + sName = StructureName theName + s = + Structure + (PositionedGrid pos $ Just <$> mkGrid g) + mempty + mempty + mempty + +renderGridResult :: Either a (PositionedGrid (Maybe Int)) -> IO () +renderGridResult = mapM_ $ \pg -> do + print pg + print $ getRows $ gridContent pg diff --git a/test/unit/TestPedagogy.hs b/test/unit/TestPedagogy.hs --- a/test/unit/TestPedagogy.hs +++ b/test/unit/TestPedagogy.hs @@ -9,13 +9,13 @@ import Control.Lens (view) import Data.Map qualified as M import Swarm.Doc.Pedagogy -import Swarm.Game.ScenarioInfo (scenarioPath) -import Swarm.Game.State.Runtime (RuntimeState, scenarios) +import Swarm.Game.Scenario.Status (ScenarioPath (..), ScenarioWith (..)) +import Swarm.TUI.Model import Test.Tasty import Test.Tasty.HUnit -testPedagogy :: RuntimeState -> TestTree -testPedagogy rs = +testPedagogy :: ProgressionState -> TestTree +testPedagogy ps = testGroup "Pedagogical soundness" [ testGroup @@ -23,10 +23,10 @@ testList ] where - tutorialInfos = generateIntroductionsSequence $ view scenarios rs + tutorialInfos = generateIntroductionsSequence $ view scenarios ps testFromTut :: Int -> CoverageInfo -> TestTree - testFromTut idx (CoverageInfo (TutorialInfo (_s, si) _ _ descCommands) novelCommands) = + testFromTut idx (CoverageInfo (TutorialInfo (ScenarioWith _s (ScenarioPath scPath)) _ _ descCommands) novelCommands) = testCase (unwords [show idx, scPath]) $ assertBool errMsg allCommandsCovered @@ -38,7 +38,6 @@ , show $ M.keysSet missingCmds ] - scPath = view scenarioPath si allCommandsCovered = M.null missingCmds testList = zipWith testFromTut [0 ..] tutorialInfos diff --git a/test/unit/TestPretty.hs b/test/unit/TestPretty.hs --- a/test/unit/TestPretty.hs +++ b/test/unit/TestPretty.hs @@ -7,9 +7,9 @@ module TestPretty where import Data.Fix (Fix (..)) -import Swarm.Language.Pretty import Swarm.Language.Syntax hiding (mkOp) import Swarm.Language.Types +import Swarm.Pretty import Test.Tasty import Test.Tasty.HUnit import Witch (into) @@ -91,7 +91,7 @@ , testCase "type ascription" ( equalPrettyLine "1 : Int" $ - TAnnotate (TInt 1) (Forall [] TyInt) + TAnnotate (TInt 1) (mkTrivPoly TyInt) ) , testCase "lambda precedence (#1468)" @@ -109,68 +109,52 @@ "types" [ testCase "Void type" - ( equalPrettyLine "Void" TyVoid - ) + (equalPrettyLine "Void" TyVoid) , testCase "Unit type" - ( equalPrettyLine "Unit" TyUnit - ) + (equalPrettyLine "Unit" TyUnit) , testCase "Function type" - ( equalPrettyLine "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit - ) + (equalPrettyLine "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit) , testCase "Cmd type" - ( equalPrettyLine "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt) - ) + (equalPrettyLine "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt)) , testCase "Product type" - ( equalPrettyLine "Int * Int" $ TyInt :*: TyInt - ) + (equalPrettyLine "Int * Int" $ TyInt :*: TyInt) , testCase "Sum type" - ( equalPrettyLine "Int + Int" $ TyInt :+: TyInt - ) + (equalPrettyLine "Int + Int" $ TyInt :+: TyInt) , testCase "Sum of sum right" - ( equalPrettyLine "Int + (Unit + Bool)" $ TyInt :+: (TyUnit :+: TyBool) - ) + (equalPrettyLine "Int + (Unit + Bool)" $ TyInt :+: (TyUnit :+: TyBool)) , testCase "Sum of sum left" - ( equalPrettyLine "(Int + Unit) + Bool" $ (TyInt :+: TyUnit) :+: TyBool - ) + (equalPrettyLine "(Int + Unit) + Bool" $ (TyInt :+: TyUnit) :+: TyBool) , testCase "Product of product right" - ( equalPrettyLine "Int * (Unit * Bool)" $ TyInt :*: (TyUnit :*: TyBool) - ) + (equalPrettyLine "Int * (Unit * Bool)" $ TyInt :*: (TyUnit :*: TyBool)) , testCase "Product of product left" - ( equalPrettyLine "(Int * Unit) * Bool" $ (TyInt :*: TyUnit) :*: TyBool - ) + (equalPrettyLine "(Int * Unit) * Bool" $ (TyInt :*: TyUnit) :*: TyBool) , testCase "Product of sum" - ( equalPrettyLine "Int * (Unit + Bool)" $ TyInt :*: (TyUnit :+: TyBool) - ) + (equalPrettyLine "Int * (Unit + Bool)" $ TyInt :*: (TyUnit :+: TyBool)) , testCase "Sum of product" - ( equalPrettyLine "Int + (Unit * Bool)" $ TyInt :+: (TyUnit :*: TyBool) - ) + (equalPrettyLine "Int + (Unit * Bool)" $ TyInt :+: (TyUnit :*: TyBool)) , testCase "Product of function" - ( equalPrettyLine "Int * (Unit -> Bool)" $ TyInt :*: (TyUnit :->: TyBool) - ) + (equalPrettyLine "Int * (Unit -> Bool)" $ TyInt :*: (TyUnit :->: TyBool)) , testCase "Function of product" - ( equalPrettyLine "Int -> (Unit * Bool)" $ TyInt :->: (TyUnit :*: TyBool) - ) + (equalPrettyLine "Int -> (Unit * Bool)" $ TyInt :->: (TyUnit :*: TyBool)) , testCase "Function of function right" - ( equalPrettyLine "Int -> Unit -> Bool" $ TyInt :->: (TyUnit :->: TyBool) - ) + (equalPrettyLine "Int -> Unit -> Bool" $ TyInt :->: (TyUnit :->: TyBool)) , testCase "Function of function left" - ( equalPrettyLine "(Int -> Unit) -> Bool" $ (TyInt :->: TyUnit) :->: TyBool - ) + (equalPrettyLine "(Int -> Unit) -> Bool" $ (TyInt :->: TyUnit) :->: TyBool) , testCase "density (two nested products)" ( equalPrettyLine "((Int * Int) * (Int * Int)) -> Cmd Int" $ @@ -181,28 +165,22 @@ "types but with limited width for pretty printing" [ testCase "Void type" - ( equalPrettyWidth 10 "Void" TyVoid - ) + (equalPrettyWidth 10 "Void" TyVoid) , testCase "Function type" - ( equalPrettyWidth 20 "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit - ) + (equalPrettyWidth 20 "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit) , testCase "Cmd type" - ( equalPrettyWidth 20 "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt) - ) + (equalPrettyWidth 20 "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt)) , testCase "Product type" - ( equalPrettyWidth 20 "Int * Int" $ TyInt :*: TyInt - ) + (equalPrettyWidth 20 "Int * Int" $ TyInt :*: TyInt) , testCase "Function of function right" - ( equalPrettyWidth 10 "Int ->\nUnit ->\nBool" $ TyInt :->: (TyUnit :->: TyBool) - ) + (equalPrettyWidth 10 "Int ->\nUnit ->\nBool" $ TyInt :->: (TyUnit :->: TyBool)) , testCase "Function of function left" - ( equalPrettyWidth 20 "(Int -> Unit) ->\nBool" $ (TyInt :->: TyUnit) :->: TyBool - ) + (equalPrettyWidth 20 "(Int -> Unit) ->\nBool" $ (TyInt :->: TyUnit) :->: TyBool) , testCase "density (two nested products) with nested indentation" ( equalPrettyWidth 20 "(\n (Int * Int) * (\n Int * Int\n )\n) -> Cmd Int" $ @@ -218,23 +196,22 @@ "tydef" [ testCase "tydef alias" $ equalPrettyLine "tydef X = Int end" $ - TTydef "X" (Forall [] TyInt) Nothing (TConst Noop) + TTydef "X" (mkTrivPoly TyInt) Nothing (TConst Noop) , testCase "tydef Maybe" $ equalPrettyLine "tydef Maybe a = Unit + a end" $ - TTydef "Maybe" (Forall ["a"] (TyUnit :+: TyVar "a")) Nothing (TConst Noop) + TTydef "Maybe" (mkQPoly (TyUnit :+: TyVar "a")) Nothing (TConst Noop) , testCase "tydef multi-arg" $ equalPrettyLine "tydef Foo a b c d = Unit + ((a * b) + ((c -> d) * a)) end" $ TTydef "Foo" - ( Forall - ["a", "b", "c", "d"] + ( mkQPoly (TyUnit :+: (TyVar "a" :*: TyVar "b") :+: ((TyVar "c" :->: TyVar "d") :*: TyVar "a")) ) Nothing (TConst Noop) , testCase "consecutive tydef" $ equalPrettyLine "tydef X = Int end\n\ntydef Y = Bool end" $ - TTydef "X" (Forall [] TyInt) Nothing (TTydef "Y" (Forall [] TyBool) Nothing (TConst Noop)) + TTydef "X" (mkTrivPoly TyInt) Nothing (TTydef "Y" (mkTrivPoly TyBool) Nothing (TConst Noop)) ] , testGroup "recursive types" diff --git a/test/unit/TestQQ.hs b/test/unit/TestQQ.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestQQ.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Unit tests for quasiquoting +module TestQQ where + +import Swarm.Language.Parser.QQ +import Swarm.Language.Syntax +import Swarm.Pretty +import Test.Tasty +import Test.Tasty.HUnit + +testQQ :: TestTree +testQQ = + testGroup + "quasiquoters" + [ testCase "basic untyped AST quasiquote" $ + assertEqual + "numeric literal" + [astQ| 3 |] + (Syntax' (SrcLoc 1 2) (TInt 3) mempty ()) + , testCase "antiquoting for untyped AST quasiquotes" $ + let t = [astQ| 3 + 6 |] + in assertEqual + "foo" + (prettyText [astQ| def x : Int -> Cmd Bool = \x. pure (x == $syn:t) end |]) + (prettyText [astQ| def x : Int -> Cmd Bool = \x. pure (x == 3 + 6) end |]) + ] + +-- Note, they are not equal as ASTs because the SrcLoc +-- annotations differ. diff --git a/test/unit/TestRepl.hs b/test/unit/TestRepl.hs --- a/test/unit/TestRepl.hs +++ b/test/unit/TestRepl.hs @@ -8,6 +8,7 @@ import Data.String (fromString) import Data.Text (Text) +import Swarm.Game.Tick (TickNumber (..)) import Swarm.TUI.Model.Repl import Test.Tasty import Test.Tasty.HUnit @@ -89,3 +90,9 @@ toT = fromString . show addInOutInt :: Int -> REPLHistory -> REPLHistory addInOutInt i = addREPLItem (mkREPLOutput $ toT i <> ":Int") . addREPLItem (mkREPLSubmission $ toT i) + +mkREPLSubmission :: Text -> REPLHistItem +mkREPLSubmission = REPLHistItem (REPLEntry Submitted) (TickNumber 0) + +mkREPLOutput :: Text -> REPLHistItem +mkREPLOutput = REPLHistItem REPLOutput (TickNumber 0) diff --git a/test/unit/TestRequirements.hs b/test/unit/TestRequirements.hs --- a/test/unit/TestRequirements.hs +++ b/test/unit/TestRequirements.hs @@ -13,8 +13,10 @@ import Swarm.Language.Context qualified as Ctx import Swarm.Language.Pipeline import Swarm.Language.Requirements.Analysis (requirements) -import Swarm.Language.Requirements.Type (ReqCtx, Requirements, capReqs) +import Swarm.Language.Requirements.Type (ReqCtx, Requirements, capReqs, devReqs) +import Swarm.Language.Syntax.Constants (Const (Move)) import Swarm.Language.Syntax.Util (eraseS) +import Swarm.Language.Types (emptyTDCtx) import Test.Tasty import Test.Tasty.HUnit import TestUtil (check) @@ -26,7 +28,7 @@ [ testGroup "Basic capabilities" [ testCase "solar panel" $ "noop" `requiresCap` CPower - , testCase "move" $ "move" `requiresCap` CMove + , testCase "move" $ "move" `requiresCap` CExecute Move , testCase "lambda" $ "\\x. x" `requiresCap` CLambda , testCase "inl" $ "inl 3" `requiresCap` CSum , testCase "cap from type" $ "inl () : rec t. Unit + t" `requiresCap` CRectype @@ -36,15 +38,23 @@ [ testCase "global var requirement does not apply to local var (#1914)" $ checkReqCtx "def m = move end; def y = \\m. log (format m) end" - (maybe False ((CMove `S.notMember`) . capReqs) . Ctx.lookup "y") + (maybe False ((CExecute Move `S.notMember`) . capReqs) . Ctx.lookup "y") ] + , testGroup + "use" + [ testCase "literal argument to use (#1301)" $ + "use \"key\"" `requiresDev` "key" + ] ] checkReqCtx :: Text -> (ReqCtx -> Bool) -> Assertion checkReqCtx code expect = check code (expect . extractReqCtx) checkRequirements :: Text -> (Requirements -> Bool) -> Assertion -checkRequirements code expect = check code (expect . requirements mempty mempty . eraseS) +checkRequirements code expect = check code (expect . requirements emptyTDCtx mempty . eraseS) requiresCap :: Text -> Capability -> Assertion requiresCap code cap = checkRequirements code ((cap `S.member`) . capReqs) + +requiresDev :: Text -> Text -> Assertion +requiresDev code dev = checkRequirements code ((dev `S.member`) . devReqs)