diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,102 @@ # Revision history for swarm +## **0.6.0.0** - 2024-07-15 + +Some of the highlights of this release include native Windows support, +customizable keybindings, type synonyms and equirecursive types, and a +prototype tournament server +([#1798](https://github.com/swarm-game/swarm/pull/1798)) where players +can upload their solutions to challenge scenarios. See below for a +more detailed list (or see the [complete list of git +commits](https://github.com/swarm-game/swarm/commits/main/?since=2023-11-01)). + +Aside from the more visible changes listed below, this release cycle saw a *lot* of internal refactoring. +For example, we finished splitting the codebase into a number of +independent sublibraries and split several large modules into smaller +modules. + +### Community + +* New [Discord server](https://discord.gg/kp8MuSgkPw)! + +### Breaking changes + +* Types are now required to start with an uppercase letter ([#1583](https://github.com/swarm-game/swarm/pull/1583)) + * Use `swarm format --v0.5` to convert old code. + +### Bugfixes + +* Variables in a local monadic binder escape to outer scopes + ([#681](https://github.com/swarm-game/swarm/issues/681); fixed by [#1928](https://github.com/swarm-game/swarm/pull/1928)) + +### New Features + +#### Language + +* `volume` command measuring the enclosed area around a given location + ([#1747](https://github.com/swarm-game/swarm/pull/1747)) +* `sow` command for planting growing entities that spread ([#1817](https://github.com/swarm-game/swarm/pull/1817)) +* Type synonyms ([#1865](https://github.com/swarm-game/swarm/pull/1865)) +* Recursive types ([#1894](https://github.com/swarm-game/swarm/pull/1894)) +* Entity tags and related commands ([#1635](https://github.com/swarm-game/swarm/pull/1635)) +* `meetAll` command now returns a list ([#1999](https://github.com/swarm-game/swarm/pull/1999)) + +#### Entities + recipes + +* New `lens` entity and recipe for `detonator` ([#1876](https://github.com/swarm-game/swarm/pull/1876)) +* `infinite improbability drive` device enabling `teleport` command + ([#1724](https://github.com/swarm-game/swarm/pull/1724)) +* Recipes for `rolex`, `olfactometer`, `dozer blade`, and `hourglass` entities + ([#2028](https://github.com/swarm-game/swarm/pull/2028), [#2025](https://github.com/swarm-game/swarm/pull/2025)) + +#### New scenarios + +* Beekeeping scenario ([#1599](https://github.com/swarm-game/swarm/pull/1599)) +* Fishing scenario ([#1628](https://github.com/swarm-game/swarm/pull/1628)) +* Dim sum restaurant ([#1686](https://github.com/swarm-game/swarm/pull/1686)) +* Gallery scenario ([#1760](https://github.com/swarm-game/swarm/pull/1760)) +* Snake automata ([#1699](https://github.com/swarm-game/swarm/pull/1699)) + +#### Scenario mechanics and authoring improvements + +* Path caching, for more efficient repeated use of the `path` command ([#1595](https://github.com/swarm-game/swarm/pull/1595)) +* Render any map to PNG ([#1632](https://github.com/swarm-game/swarm/pull/1632)) +* Extensible terrain ([#1775](https://github.com/swarm-game/swarm/pull/1775)) +* Spreadable plant growth ([#1817](https://github.com/swarm-game/swarm/pull/1817)) +* Exercising commands can consume entities ([#1777](https://github.com/swarm-game/swarm/pull/1777)) +* Recognize built structures ([#1579](https://github.com/swarm-game/swarm/pull/1579)) +* Test for point-to-point connectivity ([#1721](https://github.com/swarm-game/swarm/pull/1721)) +* Validate palettes ([#1938](https://github.com/swarm-game/swarm/pull/1938)), map shape ([#1935](https://github.com/swarm-game/swarm/pull/1935)), subworld references ([#1875](https://github.com/swarm-game/swarm/pull/1875)) + +#### UI enhancements + +* Fix REPL type display ([#1610](https://github.com/swarm-game/swarm/pull/1610)) +* Handle backword kill word event in REPL ([#1861](https://github.com/swarm-game/swarm/pull/1861)) +* Make log error messages ephemeral ([#1877](https://github.com/swarm-game/swarm/pull/1877)) +* Pretty print code blocks according to widget size ([#1897](https://github.com/swarm-game/swarm/pull/1897)) +* Automatically insert matching close brackets at REPL ([#1953](https://github.com/swarm-game/swarm/pull/1953)) +* Highlight only the part of the REPL input indicated as the location + of an error ([#1957](https://github.com/swarm-game/swarm/pull/1957)) +* Popups for new achievements, recipes, and commands + ([#2027](https://github.com/swarm-game/swarm/pull/2027)) +* Save current REPL input with down arrow + ([#2000](https://github.com/swarm-game/swarm/pull/2000)) +* Customizable keybindings ([#1979](https://github.com/swarm-game/swarm/pull/1979)) + +#### Command line options + +* `format` subcommand now tries to preserve comments ([#1845](https://github.com/swarm-game/swarm/pull/1845)) +* Add `format --v0.5` option to port code from older syntax ([#1851](https://github.com/swarm-game/swarm/pull/1851)) +* `keybindings` subcommand for displaying and initializing keybinding + configuration ([#1979](https://github.com/swarm-game/swarm/pull/1979)) +* `docs recipes` subcommand now takes `--forward` and `--next` flags + for filtering the output edges ([#2033](https://github.com/swarm-game/swarm/pull/2033)) + +### Building/packaging + +* Add Windows build to CI ([#1974](https://github.com/swarm-game/swarm/pull/1974)) +* Native Windows support ([#1617](https://github.com/swarm-game/swarm/pull/1617)) + ## **0.5.0.0** - 2023-11-01 ### Bugfixes diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Brent Yorgey 2021-2022 +Copyright Brent Yorgey and other contributors 2021-2024 SPDX-License-Identifier: BSD-3-Clause All rights reserved. @@ -14,7 +14,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Swarm team nor the names of other + * Neither the name of Brent Yorgey nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -6,46 +6,37 @@ -- SPDX-License-Identifier: BSD-3-Clause module Main where +import Control.Monad (when) import Data.Foldable qualified -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack) -import Data.Text qualified as T -import Data.Text.IO qualified as Text +import Data.Text.IO qualified as T import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) import Options.Applicative -import Prettyprinter -import Prettyprinter.Render.Text qualified as RT import Swarm.App (appMain) -import Swarm.Doc.Gen (EditorType (..), GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs) -import Swarm.Game.World.Render (printScenarioMap, renderScenarioMap) +import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) +import Swarm.Language.Format import Swarm.Language.LSP (lspMain) -import Swarm.Language.Parse (readTerm) -import Swarm.Language.Pretty (ppr) +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.Util ((?)) import Swarm.Version import Swarm.Web (defaultPort) -import System.Console.Terminal.Size qualified as Term -import System.Exit (exitFailure) import System.IO (hPrint, stderr) import Text.Read (readMaybe) gitInfo :: Maybe GitInfo -gitInfo = either (const Nothing) Just ($$tGitInfoCwdTry) +gitInfo = either (const Nothing) Just $$tGitInfoCwdTry commitInfo :: String commitInfo = case gitInfo of Nothing -> "" Just git -> " (" <> giBranch git <> "@" <> take 10 (giHash git) <> ")" -type Width = Int - data CLI = Run AppOpts - | Format Input (Maybe Width) - | DocGen GenerateDocs - | RenderMap FilePath + | -- | Print list of bindings, optionally initializing the INI configuration file. + ListKeybinding Bool KeybindingPrint + | Format FormatConfig | LSP | Version @@ -53,11 +44,10 @@ cliParser = subparser ( mconcat - [ command "format" (info (Format <$> format <*> optional widthOpt <**> helper) (progDesc "Format a file")) - , command "generate" (info (DocGen <$> docgen <**> helper) (progDesc "Generate docs")) - , command "map" (info (RenderMap <$> strArgument (metavar "FILE")) (progDesc "Render a scenario world map.")) + [ command "format" (info (Format <$> parseFormat) (progDesc "Format a file")) , command "lsp" (info (pure LSP) (progDesc "Start the LSP")) , command "version" (info (pure Version) (progDesc "Get current and upstream version.")) + , command "keybindings" (info (ListKeybinding <$> initKeybindingConfig <*> printKeyMode <**> helper) (progDesc "List the keybindings")) ] ) <|> Run @@ -73,54 +63,38 @@ <*> pure gitInfo ) where - format :: Parser Input - format = - (Stdin <$ switch (long "stdin" <> help "Read code from stdin")) - <|> (File <$> strArgument (metavar "FILE")) - widthOpt :: Parser Width + 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") - docgen :: Parser GenerateDocs - docgen = - subparser . mconcat $ - [ command "recipes" (info (pure RecipeGraph) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes") - , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords") - , command "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 "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage") - , command "endpoints" (info (pure WebAPIEndpoints) $ progDesc "Generate markdown Web API documentation.") - ] - editor :: Parser (Maybe EditorType) - editor = - Data.Foldable.asum - [ pure Nothing - , Just VSCode <$ switch (long "code" <> help "Generate for the VS Code editor") - , Just Emacs <$ switch (long "emacs" <> help "Generate for the Emacs editor") - ] - address :: Parser PageAddress - address = - let replace a b = T.unpack . T.replace a b . T.pack - opt n = - fmap (fromMaybe "") . optional $ - option - str - ( long n - <> metavar "ADDRESS" - <> help ("Set the address of " <> replace "-" " " n <> ". Default no link.") - ) - in PageAddress <$> opt "entities-page" <*> opt "commands-page" <*> opt "capabilities-page" <*> opt "recipes-page" - cheatsheet :: Parser (Maybe SheetType) - cheatsheet = - Data.Foldable.asum - [ pure Nothing - , Just Entities <$ switch (long "entities" <> help "Generate entities page (uses data from entities.yaml)") - , Just Recipes <$ switch (long "recipes" <> help "Generate recipes page (uses data from recipes.yaml)") - , Just Capabilities <$ switch (long "capabilities" <> help "Generate capabilities page (uses entity map)") - , Just Commands <$ switch (long "commands" <> help "Generate commands page (uses constInfo, constCaps and inferConst)") - , Just Scenario <$ switch (long "scenario" <> help "Generate scenario schema page") - ] + 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 $ @@ -161,47 +135,35 @@ <> fullDesc ) -data Input = Stdin | File FilePath - -getInput :: Input -> IO Text -getInput Stdin = Text.getContents -getInput (File fp) = Text.readFile fp - -showInput :: Input -> Text -showInput Stdin = "(input)" -showInput (File fp) = pack fp - --- | Utility function to validate and format swarm-lang code -formatFile :: Input -> Maybe Width -> IO () -formatFile input mWidth = do - content <- getInput input - case readTerm content of - Right Nothing -> Text.putStrLn "" - Right (Just ast) -> do - mWindow <- Term.size - let mkOpt w = LayoutOptions (AvailablePerLine w 1.0) - let opt = - fmap mkOpt mWidth - ? fmap (\(Term.Window _h w) -> mkOpt w) mWindow - ? defaultLayoutOptions - Text.putStrLn . RT.renderStrict . layoutPretty opt $ ppr ast - Left e -> do - Text.hPutStrLn stderr $ showInput input <> ":" <> e - exitFailure - 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 - DocGen g -> generateDocs g - Format fo w -> formatFile fo w - RenderMap mapPath -> printScenarioMap =<< renderScenarioMap mapPath + 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 new file mode 100644 --- /dev/null +++ b/app/Swarm/App.hs @@ -0,0 +1,153 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/doc/Main.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Main where + +import Data.Foldable qualified +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Options.Applicative +import Swarm.Doc.Gen (EdgeFilter (..), GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs) +import Swarm.Doc.Keyword (EditorType (..)) + +cliParser :: Parser GenerateDocs +cliParser = + subparser $ + mconcat + [ command "recipes" (info (RecipeGraph <$> edgeFilter <**> helper) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes") + , 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 "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage") + ] + where + editor :: Parser (Maybe EditorType) + editor = + Data.Foldable.asum + [ pure Nothing + , Just VSCode <$ switch (long "code" <> help "Generate for the VS Code editor") + , Just Emacs <$ switch (long "emacs" <> help "Generate for the Emacs editor") + , Just Vim <$ switch (long "vim" <> help "Generate for the Vim editor") + ] + edgeFilter :: Parser EdgeFilter + edgeFilter = + Data.Foldable.asum + [ pure NoFilter + , FilterForward <$ switch (long "forward" <> help "Show only forward edges") + , FilterNext <$ switch (long "next" <> help "Show only edges to next group") + ] + address :: Parser PageAddress + address = + let replace a b = T.unpack . T.replace a b . T.pack + opt n = + fmap (fromMaybe "") . optional $ + option + str + ( long n + <> metavar "ADDRESS" + <> help ("Set the address of " <> replace "-" " " n <> ". Default no link.") + ) + in PageAddress <$> opt "entities-page" <*> opt "commands-page" <*> opt "capabilities-page" <*> opt "recipes-page" + cheatsheet :: Parser SheetType + cheatsheet = + Data.Foldable.asum + [ flag' Entities (long "entities" <> help "Generate entities page (uses data from entities.yaml)") + , flag' Terrain (long "terrain" <> help "Generate terrain page (uses data from terrains.yaml)") + , flag' Recipes (long "recipes" <> help "Generate recipes page (uses data from recipes.yaml)") + , flag' Capabilities (long "capabilities" <> help "Generate capabilities page (uses entity map)") + , flag' Commands (long "commands" <> help "Generate commands page (uses constInfo, constCaps and inferConst)") + , flag' CommandMatrix (long "matrix" <> help "Generate commands matrix page") + , flag' Scenario (long "scenario" <> help "Generate scenario schema page") + ] + +cliInfo :: ParserInfo GenerateDocs +cliInfo = + info + (cliParser <**> helper) + ( header "Swarm docs" + <> progDesc "Generate swarm documentation." + <> fullDesc + ) + +main :: IO () +main = generateDocs =<< execParser cliInfo diff --git a/app/scene/Main.hs b/app/scene/Main.hs new file mode 100644 --- /dev/null +++ b/app/scene/Main.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Main where + +import Options.Applicative +import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..)) +import Swarm.Game.World.Render (FailureMode (..), OuputFormat (..), RenderOpts (..), doRenderCmd) + +data CLI + = RenderMap FilePath RenderOpts + +cliParser :: Parser CLI +cliParser = + RenderMap <$> strArgument (metavar "SCENARIO") <*> subOpts + where + sizeOpts = + AreaDimensions + <$> 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") + + subOpts = + RenderOpts + <$> seed + <*> 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) + seed = optional $ option auto (long "seed" <> short 's' <> metavar "INT" <> help "Seed to use for world generation") + +cliInfo :: ParserInfo CLI +cliInfo = + info + (cliParser <**> helper) + ( header "Swarm scene" + <> progDesc "Render a scenario world map." + <> fullDesc + ) + +main :: IO () +main = do + cli <- execParser cliInfo + case cli of + RenderMap mapPath opts -> doRenderCmd opts mapPath diff --git a/app/tournament/Main.hs b/app/tournament/Main.hs new file mode 100644 --- /dev/null +++ b/app/tournament/Main.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Main where + +import Control.Monad.Trans.Reader (runReaderT) +import Data.Maybe (fromMaybe) +import Data.Yaml (decodeFileThrow) +import Database.SQLite.Simple (execute_, withConnection) +import Network.Wai.Handler.Warp (Port) +import Options.Applicative +import Swarm.Game.State (Sha1 (..)) +import Swarm.Web.Tournament +import Swarm.Web.Tournament.Database.Query +import Swarm.Web.Tournament.Type (UserAlias (..)) + +data AppOpts = AppOpts + { userWebPort :: Maybe Port + -- ^ Explicit port on which to run the web API + , gameGitVersion :: Sha1 + , deploymentEnv :: DeploymentEnvironment + } + +webPort :: Parser (Maybe Int) +webPort = + optional $ + option + auto + ( long "port" + <> metavar "PORT" + <> help ("Set the web service port (or disable it with 0). Default to " <> show defaultPort <> ".") + ) + +gameVersion :: Parser Sha1 +gameVersion = + Sha1 + <$> option + str + ( long "version" + <> metavar "VERSION" + <> help "Set the git version of the game" + ) + +parseRunningLocally :: Parser DeploymentEnvironment +parseRunningLocally = + flag + ProdDeployment + (LocalDevelopment $ UserAlias "local-user") + (long "local" <> help "Running locally for development") + +cliParser :: Parser AppOpts +cliParser = AppOpts <$> webPort <*> gameVersion <*> parseRunningLocally + +cliInfo :: ParserInfo AppOpts +cliInfo = + info + (cliParser <**> helper) + ( header "Swarm tournament" + <> progDesc "Hosts a tournament server." + <> fullDesc + ) + +main :: IO () +main = do + opts <- execParser cliInfo + + creds <- case deploymentEnv opts of + LocalDevelopment _ -> return $ GitHubCredentials "" "" + ProdDeployment -> decodeFileThrow "swarm-github-app-credentials.yaml" + + webMain + (AppData (gameGitVersion opts) creds persistenceFunctions (deploymentEnv opts)) + (fromMaybe defaultPort $ userWebPort opts) + where + persistenceFunctions = + PersistenceLayer + { scenarioStorage = + ScenarioPersistence + { lookupCache = withConn lookupScenarioSolution + , storeCache = withConn insertScenario + , getContent = withConn lookupScenarioContent + } + , solutionStorage = + ScenarioPersistence + { lookupCache = withConn lookupSolutionSubmission + , storeCache = withConn insertSolutionSubmission + , getContent = withConn lookupSolutionContent + } + , authenticationStorage = + AuthenticationStorage + { usernameFromCookie = withConn getUsernameFromCookie + , cookieFromUsername = withConn insertCookie + } + } + where + withConn f x = + withConnection databaseFilename $ \conn -> do + execute_ conn "PRAGMA foreign_keys = ON;" + runReaderT (f x) conn diff --git a/data/about.txt b/data/about.txt --- a/data/about.txt +++ b/data/about.txt @@ -2,7 +2,7 @@ For a full list of contributors, see https://github.com/swarm-game/swarm/graphs/contributors. Join the community! -IRC: #swarm on libera.chat +Discord: https://discord.gg/kp8MuSgkPw Wiki: https://github.com/swarm-game/swarm/wiki Interested in contributing to Swarm? All are welcome! See diff --git a/data/entities.yaml b/data/entities.yaml --- a/data/entities.yaml +++ b/data/entities.yaml @@ -3,1457 +3,1292 @@ attr: plant char: 'T' description: - - | - A tall, living entity made of a tough cellular material called "wood". - They regrow after being harvested and are an important raw ingredient used - in making many different devices. - properties: [portable, growable, opaque, combustible] - growth: [500, 600] - combustion: - ignition: 0.01 - duration: [80, 120] - product: ash - -- name: ash - display: - attr: rock - char: '#' - description: - - | - Burned-out remnants of combustion. - properties: [portable] - -- name: branch - display: - attr: wood - char: 'y' - description: - - A branch cut from a tree. It's as if the tree had to make a decision - and was exploring two options. - properties: [portable] - -- name: log - display: - attr: wood - char: 'l' - description: - - A wooden log, obtained by harvesting a tree and cutting off its branches. - properties: [portable, combustible] - combustion: - ignition: 0.05 - duration: [40, 80] - product: ash - -- name: board - display: - attr: wood - char: 'w' - description: - - A wooden board, made by cutting a log into pieces. - properties: [portable, combustible] - combustion: - ignition: 0.2 - duration: [20, 40] - product: ash - -- name: workbench - display: - attr: wood - char: 'π' - description: - - A plain wooden workbench, providing space to make other - things using the `make` command. - - | - Example: - ``` - make "log" - ``` - properties: [portable] - capabilities: [make] - -- name: paper - display: - attr: snow - char: '■' - description: - - A flat material made of pressed and dried wood fibers, - used as a surface on which to inscribe symbols. - properties: [portable, combustible] - combustion: - ignition: 0.5 - duration: [10, 20] - product: ash - -- name: PhD thesis - display: - attr: snow - char: 'P' - description: - - Perhaps writing one of these will help gain the trust and respect of - the native inhabitants. - properties: [portable] - -- name: rock - display: - attr: rock - char: 'o' - description: - - A medium-sized rock, picked up from the ground or created by drilling. - Can be ground into sand or used to build a simple furnace, among other things. - properties: [portable] - -- name: handle - display: - attr: device - char: 'h' - description: - - Ergonomic affordance for manipulating objects. Also grants the "setname" capability, allowing one - to assign a "handle" to robots. - properties: [portable] - capabilities: [setname] - -- name: lodestone - display: - attr: iron - char: 'o' - description: - - A medium-sized rock... that looks a little different. - It seems to react to iron and surprisingly also to naturally growing bits. - properties: [portable] - capabilities: [negation] - -- name: beaglepuss - display: - attr: rubber - char: 'B' - description: - - Iconic novelty disguise. Renders one either completely inconspicuous, or the opposite. - properties: [portable] - capabilities: [appear] - -- name: boulder - display: - attr: rock - char: '@' - description: - - A very large, impassable rock. A drill can be used to get rid of it and turn it into smaller rocks. - properties: [unwalkable] - -- name: mountain - display: - attr: snow - char: 'A' - description: - - A mountain. Can be tunneled through with a drill, but it takes time. - properties: [unwalkable, opaque] - -- name: mountain tunnel - display: - attr: snow - char: 'Å' - priority: 11 - description: - - A tunnel in a mountain through which anything can freely move. - properties: [] - -- name: copper ore - display: - attr: copper - char: 'C' - description: - - Raw copper ore, useful for making wires, pipes, and other metal things. - Patches of copper ore can be found on the surface, but are quickly exhausted. - - Scanners seem to indicate larger quantities of copper could be found beneath some of the - mountains, but those would require a drill to access and mine. - properties: [portable] - -- name: copper mine - display: - attr: copper' - char: 'Å' - priority: 11 - description: - - A copper vein that can be actively mined to produce copper ore. - properties: [] - -- name: copper wire - display: - attr: copper - char: '|' - description: - - Copper wire is very good at conducting electricity and useful for - making various types of circuits and machines. - properties: [portable] - -- name: strange loop - display: - attr: copper - char: '8' - description: - - Two copper wires twisted together in a strange shape that loops - back on itself. It must be useful for something... - properties: [portable] - capabilities: [recursion] - -- name: copper pipe - display: - attr: copper - char: 'I' - description: - - A pipe made out of a thin sheet of copper. Great for transmitting - water or steam. - properties: [portable] - -- name: iron plate - display: - attr: iron - char: '■' - description: - - Worked iron suitable for crafting resilient tools. - - It also possess some electro-magnetic properties. - properties: [portable] - -- name: iron gear - display: - attr: iron - char: '*' - description: - - An iron gear, suitable for constructing larger, more powerful - machinery than a wooden gear. - properties: [portable] - -- name: iron ore - display: - attr: iron - char: 'F' - description: - - Raw iron ore. Used to create more resilient tools than copper. - - It can only be mined by drilling in the mountains. - properties: [portable] - -- name: iron mine - display: - attr: iron' - char: 'Å' - priority: 11 - description: - - An iron vein that can be actively mined to produce iron ore. - properties: [] - -- name: quartz - display: - attr: quartz - char: 'Q' - description: - - Raw quartz crystals. Useful for creating devices like clocks, and - can be processed to extract silicon. - - It can only be mined by drilling in the mountains. - properties: [portable] - -- name: quartz mine - display: - attr: quartz - char: 'Å' - priority: 11 - description: - - A quartz vein that can be actively mined to produce quartz. - properties: [] - -- name: silicon - display: - attr: quartz - char: 'S' - description: - - Extracted by processing quartz at high temperatures, silicon can - be used to construct integrated circuits. - properties: [portable] - -- name: deep mine - display: - attr: rock - char: 'Å' - priority: 11 - description: - - A deep mine that yields rare and wonderful treasures to those who are patient. - - But be careful lest you delve too greedily and too deep. - properties: [] - -- name: silver - display: - attr: silver - char: '•' - description: - - A shiny, metallic substance, noted for its high reflectivity when polished. - properties: [portable] - -- name: gold - display: - attr: gold - char: '•' - description: - - A shiny, metallic substance, with applications in specialized electronics. - - It also seems to be highly valued by local aliens. - properties: [portable] - -- name: mithril - display: - attr: silver - char: 'M' - description: - - Mithril can be beaten like copper, and polished like glass. One - can also make of it a metal, light and yet harder than tempered - steel. Its beauty is like to that of common silver, but the beauty - of mithril does not tarnish or grow dim. - properties: [portable] - -- name: furnace - display: - attr: fire - char: '#' - description: - - A furnace can be used to turn metal ore into various useful products. - properties: [portable] - -- name: big furnace - display: - attr: fire - char: '#' - description: - - A big furnace can get even hotter than a normal furnace, and can be used - to process quartz into silicon. - properties: [portable] - -- name: small motor - display: - attr: entity - char: 'm' - description: - - A motor is useful for making devices that can turn when electric - current is applied. - - This one is rather small, but surprisingly efficient. - properties: [portable] - -- name: big motor - display: - attr: entity - char: 'M' - description: - - A motor is useful for making devices that can turn when electric - current is applied. - - This one is huge and could be used to construct powerful machinery. - properties: [portable] - -- name: flower - display: - attr: flower - char: '*' - description: - - A beautiful flower that grows wild in local meadows. It is not clear - what it might be useful for, but it looks nice. - properties: [portable, growable] - growth: [30, 50] - -- name: cotton - display: - attr: silver - char: 'i' - description: - - A plant with tufts of soft fibers that can be harvested and used - to make things, including sheets of material that the local - aliens like to drape over their bodies. - properties: [portable, growable, combustible] - growth: [100, 800] - combustion: - ignition: 0.1 - duration: [20, 40] - product: ash - -- name: linotype - display: - attr: silver - char: 't' - description: - - Employs hot lead typesetting to arrange glyphs into a mold for printing. - - | - An equipped `linotype`{=entity} device enables the `format` command: - ``` - format : a -> text - ``` - which can turn any value into a suitable text representation. - properties: [portable] - capabilities: [format] - -- name: Elmer's glue - display: - attr: snow - char: 'g' - description: - - Polyvinyl acetate. Popular adhesive for crafting. Of dubious nutritional value. - - | - Facilitates the concatenation of text values. - - | - The infix operator `++ : text -> text -> text`{=snippet} - can be used to concatenate two text values. For example, - - | - "Number of widgets: " ++ format numWidgets - properties: [portable] - capabilities: [concat] - -- name: caliper - display: - attr: silver - char: 'C' - description: - - Simple, yet accurate measuring device. Can determine the length of a text value. - - | - ``` - chars : text -> int - ``` - computes the number of characters in a `text`{=type} value. - properties: [portable] - capabilities: [charcount] - -- name: wedge - display: - attr: silver - char: 'v' - description: - - A simple machine for the textually-inclined; plain but effective. - - | - An equipped `wedge`{=entity} enables the `split` command: - ``` - split : int -> text -> text * text - ``` - splits a `text`{=type} value into two pieces, one before the given index and one after. - properties: [portable] - capabilities: [split] - -- name: string - display: - attr: silver - char: '~' - description: - - A long, flexible device for transferring either force or - information, made of twisted cotton fibers. Multiple strings can - also be woven into larger configurations such as cloth or nets. - - | - An equipped `string`{=entity} device enables several commands for working with - `text`{=type} values: - - | - `format : a -> text` can turn any value into a suitable text - representation. - - | - The infix operator `++ : text -> text -> text`{=snippet} - can be used to concatenate two text values. For example, - - | - ``` - let numWidgets = 42 - in "Number of widgets: " ++ format numWidgets - ``` - - | - `chars : text -> int` computes the number of characters in a - `text`{=type} value. - - | - `split : int -> text -> text * text` splits a `text`{=type} value into - two pieces, one before the given index and one after. - properties: [portable] - capabilities: [format, concat, charcount, split] - -- name: decoder ring - display: - attr: silver - char: 'O' - description: - - | - A handy lookup table for converting from characters to numeric codes and - back, shaped for some reason into a ring. When equipped, it - enables two functions: - - | - `charAt : int -> text -> int` returns the numeric code of the - character at a specific index in a (0-indexed) `text`{=type} value. - - | - `toChar : int -> text` creates a singleton (length-1) `text`{=type} - value containing a character with the given numeric code. - properties: [portable] - capabilities: [code] - -- name: lambda - display: - attr: flower - char: 'λ' - description: - - A wild lambda. They are somewhat rare, but regrow when picked. Lambdas - are delicious when cooked into curry. - - Lambdas can also be used to create functions. For example, - - | - ``` - def thrice : cmd unit -> cmd unit = \c. c;c;c end - ``` - - defines the function `thrice`{=snippet} which repeats a command three times. - properties: [portable, growable] - growth: [100, 200] - capabilities: [lambda] - -- name: curry - display: - attr: flower - char: 'C' - description: - - Delicious curry cooked from wild lambdas. - properties: [portable] - -- name: water - display: - attr: water - char: ' ' - description: - - Liquid dihydrogen monoxide, which seems to be plentiful on this planet. - properties: [portable, infinite, liquid] - -- name: wavy water - display: - attr: water - char: '~' - description: - - A wavy section of water. The same as normal water, but with more waves. - properties: [portable, infinite, liquid] - yields: water - -- name: boat - display: - attr: wood - char: 'B' - description: - - A robot with a boat equipped can float on top of water without drowning. - - | - **NOTE:** most devices are automatically equipped on robots that - will require them; but this doesn't work in the case of boats since floating is not - associated with any particular command. To manually ensure a boat is equipped on - a robot, just add the special command `require "boat"` to the robot's program. - properties: [portable] - capabilities: [float] - -- name: sand - display: - attr: sand - char: '█' - description: - - A substance composed mostly of tiny rocks and mineral particles that can be - used in a furnace to make glass. You can often find it near water, or - make it yourself by grinding up rocks. - properties: [portable] - -- name: glass - display: - attr: entity - char: '□' - description: - - A pane of a brittle, clear substance, made from melting sand in a furnace. - properties: [portable] - -- name: LaTeX - display: - attr: flower - char: '$' - description: - - A naturally occurring substance derived from trees, useful for producing - rubber and for typesetting mathematical documents. - properties: [portable, growable] - growth: [2000, 3000] - -- name: rubber - display: - attr: rubber - char: '%' - description: - - A flexible, durable material made from LaTeX. - properties: [portable] - -- name: bit (0) - display: - attr: entity - char: '0' - description: - - A bit is used to represent the smallest possible amount of information. - Useful for constructing various information-processing devices, as well as drills. - properties: [portable, growable] - growth: [200, 400] - -- name: bit (1) - display: - attr: entity - char: '1' - description: - - A bit is used to represent the smallest possible amount of information. - Useful for constructing various information-processing devices, as well as drills. - properties: [portable, growable] - growth: [200, 400] - -- name: pixel (R) - display: - attr: red - char: '.' - description: - - A tiny picture element, used either to emit or detect red light. - properties: [portable, growable] - growth: [1000, 1500] - -- name: pixel (G) - display: - attr: green - char: '.' - description: - - A tiny picture element, used either to emit or detect green light. - properties: [portable, growable] - growth: [1000, 1500] - -- name: pixel (B) - display: - attr: blue - char: '.' - description: - - A tiny picture element, used either to emit or detect blue light. - properties: [portable, growable] - growth: [1000, 1500] - -- name: camera - display: - attr: device - char: '@' - description: - - A camera is a device for capturing images. - properties: [portable] - -- name: circuit - display: - attr: plant - char: '#' - description: - - | - A circuit is needed for constructing various "smart" devices. - properties: [portable] - -- name: drill bit - display: - attr: entity - char: '!' - description: - - A drill bit is the most important component of a drill, and must be made - out of two bits of opposite parity, for strength. - properties: [portable] - -- name: box - display: - attr: wood - char: '□' - description: - - A wooden box. It can hold things or be used as housing for other devices. - properties: [portable] - -- name: wooden gear - display: - attr: wood - char: '*' - description: - - A wooden gear. Not quite as strong or versatile as an iron gear, but easy to produce. - properties: [portable] - -- name: teeter-totter - display: - attr: wood - char: '/' - description: - - A rotating board apparently popular with young aliens. Perhaps it - could also be used as a primitive balance scale. - properties: [portable] - -- name: Linux - display: - attr: entity - char: 'L' - description: - - A copy of the Linux operating system. - properties: [portable] - -- name: gold coin - display: - char: '©' - attr: gold - description: - - A small round shaped piece of gold metal that the aliens pass between - each other occasionaly. - - Besides staying shiny it does not appear to have practical use. - properties: [portable] - -############################################################ -### Utility ################################################ -############################################################ - -- 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: 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] - -############################################################ -### Devices ################################################ -############################################################ - -- name: bitcoin - display: - char: '₿' - attr: gold - description: - - A beautiful round shaped piece of metal that seems to be of great value - to the aliens on this planet. - - Just like the bit it has two sides and when you flip it, it lands perfectly - randomly on one of the sides. - properties: [portable] - capabilities: [random] - -- name: treads - plural: treads - display: - attr: device - char: '%' - description: - - Equipping treads on a robot allows it to move and turn. - - The `move` command moves the robot forward one unit. - - | - For example to move two units: - - | - `move; move;` - - The `turn` command takes a direction as an argument, which - can be either absolute (north, west, east, south) or relative - (left, right, forward, back, down). - - | - Example: - - | - `move; turn left; move; turn right` - capabilities: [move, turn] - properties: [portable] - -- name: tank treads - plural: tank treads - display: - attr: device - char: '%' - description: - - Tank treads work like treads, but are large enough to move even heavy robots around. - capabilities: [move, turn, moveheavy] - properties: [portable] - -- name: tape drive - display: - attr: device - char: '%' - description: - - A `tape drive`{=entity} allows you to `backup`; that is, to drive in reverse. - capabilities: [backup] - properties: [portable] - -- name: dozer blade - display: - attr: silver - char: '/' - description: - - A broad, sturdy surface that can be attached to a robot and used to `push` objects. - - | - `push : cmd unit` will advance the robot and the entity in front of it forward by one step. - properties: [portable] - capabilities: [push] - -- name: grabber - display: - attr: device - char: '<' - description: - - A grabber arm is an all-purpose, hydraulically controlled device that can - manipulate other items and robots via the `grab`, `place`, and `give` - commands. - - The `grab` command takes no arguments; it simply grabs whatever is - available, and also returns the name of the grabbed thing as a string. - It raises an exception if run in a cell that does not contain an item. - - The `place` command takes one argument, the name of the item to - place. The item is removed from the robot's inventory and placed - in the robot's current cell (which must be empty). Raises an - exception if the operation fails. - - "The `give` command takes two arguments: the actor to - give an item to (which can be at most 1 cell away), and the name - of the item to give. Raises an exception if the operation fails." - capabilities: [grab, give, place] - properties: [portable] - -- name: fast grabber - display: - attr: device - char: '≪' - description: - - A fast grabber is an improved version of the basic grabber - not only - can it `grab`, `place`, and `give`, it can also `swap`. - - The `swap` command allows the robot to execute grab and place at the - same time so that the location where the robot is standing does not - become empty. - - You can use this to prevent failures where multiple robots - are trying to grab, place or scan a given location. - - In addition you retain the capability to use the `atomic` command, - with which you can implement other commands that are safe when - run in parallel. - capabilities: [grab, swap, give, place, atomic] - properties: [portable] - -- name: binoculars - display: - attr: device - char: 'B' - description: - - Allows one to `scout` for other robots - capabilities: [recondir] - properties: [portable] - -- name: welder - display: - attr: device - char: 'f' - description: - - | - A welder can be used to affix other gadgets to one's robot, providing - the `equip` and `unequip` commands. - - | - The `equip` command takes one argument: the name of the device to equip. - Raises an exception if the device is not in your inventory. - - | - The `unequip` command takes one argument: the name of the device to unequip. - Raises an exception if the device is not equipped. - capabilities: [equip, unequip] - properties: [portable] - -- name: harvester - display: - attr: device - char: '≤' - description: - - A harvester can be used via the `harvest` command, which is - almost identical to the `grab` command. The big difference - is that some entities, when harvested instead of grabbed, - leave behind a seed which will eventually grow into another copy - of the original entity. - - For entities which do not grow, `harvest` behaves exactly the same - as `grab`. - capabilities: [grab, harvest, place] - properties: [portable] - -- name: toolkit - display: - attr: device - char: 'Ѣ' - description: - - "A toolkit can be used, via the `salvage` command, to take apart old robots." - - "`salvage` takes no arguments. It looks for an inactive - robot (one which is not currently running a program) in the - current cell. If an inactive robot is found, its log (if any) is - downloaded and it is dismantled, transferring its knowledge, devices, and inventory to the - robot running `salvage`. If no inactive robots are found in the - current cell, `salvage` does nothing." - capabilities: [salvage] - properties: [portable] - -- name: solar panel - display: - attr: device - char: '#' - description: - - An extremely efficient solar panel, capable of generating sufficient power - from ambient starlight alone. A robot powered by one of these can operate any time, - including on cloudy days and at night. - capabilities: [power] - properties: [portable] - -- name: drill - display: - attr: device - char: '!' - description: - - A drill allows robots to `drill` through rocks and mountains (with - e.g. `drill forward`), and extract resources from mines (with - `drill down`). - capabilities: [drill] - properties: [portable] - -- name: metal drill - display: - attr: iron - char: '!' - description: - - A metal drill allows robots to drill through rocks and mountains, - and extract resources from mines, faster than a regular drill. - - A metal drill is also able to drill deeper than a regular drill. Thus, some resources - are only reachable using a metal drill. - capabilities: [drill] - properties: [portable] - -- name: typewriter - display: - attr: device - char: 'Д' - description: - - A typewriter is used to inscribe symbols on paper, thus reifying pure, platonic - information into a physical form. - properties: [portable] - -- name: 3D printer - display: - attr: device - char: '3' - description: - - A 3D printer gives you the capability of printing more robots! You - can access the 3D printer via the `build` command. - - 'Example:' - - | - ``` - build {move; grab; turn back; move; give base "tree"} - ``` - - | - builds a robot to get the tree on the cell to the - north (if there is one) and bring it back to the base. The `build` command - always returns a reference to the newly constructed robot. For example, - - | - ``` - r <- build {move}; view r - ``` - - | - builds a robot and then views it. - - properties: [portable] - capabilities: [build] - -- name: dictionary - display: - attr: device - char: 'D' - - description: - - | - A dictionary allows a robot to remember definitions and reuse them - later. You can access this ability with either a `def`{=snippet} command, - which creates a name for an expression or command that is - available from then on, or with a `let`{=snippet} expression, which names an - expression or command locally within another expression. - - | - ``` - def m2 : cmd unit = move; move end - ``` - - | - ``` - let x : int = 3 in x^2 + 2*x + 1 - ``` - - The type annotations in `def`{=snippet} are optional. - - properties: [portable] - capabilities: [env] - -- name: branch predictor - display: - attr: device - char: 'y' - description: - - | - A branch predictor is a device which allows a robot to interpret - conditional expressions. The syntax for a conditional expression - is `if` followed by three arguments: a boolean test and then - two delayed expressions (i.e. expressions in curly braces) of the same type. - - 'Example:' - - | - ``` - let x = 2 in - if (x > 3) {move} {turn right; move} - ``` - properties: [portable] - capabilities: [cond] - -- name: detonator - display: - attr: fire - char: '*' - description: - - An explosive device which can be used to self-destruct, via the - `selfdestruct` command. Immediately vaporizes the robot and any - inventory it is carrying. Can be useful, say, if you are sending - out some exploratory robots and don't want them cluttering up the - world once they are done. - properties: [portable] - capabilities: [selfdestruct] - -- name: life support system - display: - attr: device - char: 'Ж' - description: - - A state-of-the-art life support system which maintains the - particular temperature and mixture of gases you need to survive. - It uses a sophisticated recirculating system and can run pretty - much indefinitely. Unfortunately, the atmosphere outside is - severely toxic (why do the inhabitants of this planet need so much - nitrogen!?), so you'll have to stay inside for now. - properties: [portable] - -- name: scanner - display: - 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`." - properties: [portable] - capabilities: [scan, sensefront, sensehere] - -- name: olfactometer - display: - char: 'N' - description: - - An electronic "nose" that can tell how far away something is. - - | - `sniff : text -> cmd int` returns the distance to the nearest specified entity. - properties: [portable] - capabilities: [detectdistance] - -- name: flash memory - display: - attr: device - char: '§' - description: - - "A compact, non-volatile memory device, capable of storing - up to 8 pZ of data." - - "Flash memory can be used as a component of other devices. In addition, - a flash memory device can be used to reprogram other robots using the - `reprogram` command." - - "The robot being reprogrammed must be idle, and must possess enough capabilities to run the new command; - otherwise reprogramming will fail." - properties: [portable] - capabilities: [reprogram] - -- name: mirror - display: - attr: device - char: 'U' - description: - - "With a mirror, robots can reflect on themselves and see their own name." - - "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: [portable] - capabilities: [whoami] - -- name: logger - display: - attr: device - char: 'l' - description: - - "Allows a robot to generate and store messages for later viewing, - using the `log` command, which takes a string. Log messages are - also automatically generated by uncaught exceptions." - properties: [portable] - capabilities: [log] - -- name: hearing aid - display: - attr: device - char: '@' - description: - - "Allows a robot to hear anything being said nearby." - - "Simply having this device equipped will automatically - add messages said by nearby actors to this robot's log, - assuming it has a logger equipped." - - "That way you can view any heard message later either in - the logger or the message window." - - "To wait for a message and get the string value, use:" - - | - ``` - l <- listen; log $ "I have waited for someone to say " ++ l - ``` - properties: [portable] - capabilities: [listen] - -- name: counter - display: - attr: device - char: 'C' - description: - - | - A counter enables the command `count : text -> cmd int`, - which counts how many occurrences of an entity are currently - in the inventory. This is an upgraded version of the `has` - command, which returns a bool instead of an int and does - not require any special device. - properties: [portable] - capabilities: [count] - -- name: calculator - display: - attr: device - char: '+' - description: - - "A calculator allows a robot to do basic arithmetic calculations: - addition, subtraction, multiplication, division, and - exponentiation." - properties: [portable] - capabilities: [arith] - -- name: ADT calculator - display: - attr: device - char: '±' - description: - - | - A calculator with Advanced Display Technology (an attached - typewriter that can print out the results). For some reason, in - addition to the usual arithmetic on numbers, an ADT calculator can - also do arithmetic on types! After all, the helpful typewritten manual - explains, a type is just a collection of values, and a finite collection - of values is just a fancy number. For example, the type `bool`{=type} is - just a fancy version of the number 2, where the two things happen to be - labelled `false` and `true`. There are also types `unit`{=type} and - `void`{=type} that correspond to 1 and 0, respectively. - - | - The product of two types is a type of pairs, since, for example, - 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`. - - | - 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, - and there are `2 + 3 == 5` such values. For working with sums of - types, the ADT calculator provides the injection functions `inl : - a -> a + b` and `inr : b -> a + b`, as well as the case analysis - function `case : (a + b) -> (a -> c) -> (b -> c) -> c`. For - example, `case (inl 3) (\x. 2*x) (\y. 3*y) == 6`, and `case (inr - 3) (\x. 2*x) (\y. 3*y) == 9`. - - properties: [portable] - capabilities: [arith, sum, prod] - -- name: compass - display: - attr: device - char: 'N' - description: - - | - A compass gives a robot the ability to orient using the cardinal - directions north, south, west, and east. For example: - - | - `turn west; move; turn north` - - | - It also enables the `heading : cmd dir` command, which returns the - robot's current heading. For example, the following code moves - east and then restores the same heading as before: - - | - `d <- heading; turn east; move; turn d` - properties: [portable] - capabilities: [orient] - -- name: clock - display: - attr: device - char: '0' - description: - - A clock is a device for keeping track of time. It enables the `wait` and `time` commands. - - | - `time : cmd int` returns the current time, measured in game ticks since the beginning of the game. - - | - `wait : int -> cmd unit` causes a robot to sleep for a specified amount of time (measured in game ticks). - properties: [portable] - capabilities: [timeabs, timerel] - -- name: hourglass - display: - attr: device - char: '8' - description: - - An hourglass can measure the relative passage of time. It enables the `wait` command. - - | - `wait : int -> cmd unit` causes a robot to sleep for a specified amount of time (measured in game ticks). - properties: [portable] - capabilities: [timerel] - -- name: rolex - display: - char: R - attr: silver - description: - - Enables robots to use the `watch` command. - - | - `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: [portable] - capabilities: [wakeself] - -- name: comparator - display: - attr: device - char: '>' - description: - - "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: [portable] - capabilities: [compare] - -- name: I/O cable - display: - attr: device - char: 'Ю' - description: - - An I/O cable can be used to communicate with adjacent actors. - properties: [portable] - -- name: rubber band - display: - attr: device - char: 'O' - description: - - "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 ()} {} - ``` - - "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 ()} {}) - ``` - - properties: [portable] - capabilities: [atomic] - -- name: net - display: - attr: silver - char: '#' - description: - - A net is a device woven out of many strings. With a net - equipped, you can use the `try` command to catch errors. For example - - | - ``` - try {move} {turn left} - ``` - - will attempt to move, but if that fails, turn left instead. - properties: [portable] - capabilities: [try] - -- name: antenna - display: - attr: silver - char: 'Y' - description: - - A device for transforming electric current into radio waves, and - vice versa. Antennas can be used to increase the viable range - over which you can communicate with your robots. - - | - Antennas can also be used to locate nearby actors, by bouncing radio - waves off them and listening for the echo. This capability can be - accessed via two commands: - - | - `meet : cmd (unit + actor)` tries to locate a - nearby actor (a robot, or... something else?) up to one cell away. - It returns a reference to the nearest actor, or a unit value if - none are found. - - | - `meetAll : (b -> actor -> cmd b) -> b -> cmd b` runs a command on - every nearby actor (other than oneself), folding over the results - to compute a final result of type `b`{=type}. For example, if - `x`{=snippet}, `y`{=snippet}, and `z`{=snippet} - are nearby actors, then `meetAll f b0`{=snippet} is equivalent to - `b1 <- f b0 x; b2 <- f b1 y; f b2 z`{=snippet}. - properties: [portable] - capabilities: [meet] - -- name: GPS receiver - display: - attr: device - char: 'G' - description: - - | - A GPS receiver triangulates your current (x,y) coordinates from - some convenient satellite signals, - enabling the command `whereami : cmd (int * int)`. - properties: [portable] - capabilities: [senseloc] - -- name: tweezers - display: - attr: device - char: 'V' - description: - - | - Sometimes small, self-reproducing creatures get stuck inside a robot's - relays, preventing it from executing properly. Tweezers are - useful for removing such pests, and for inspecting robots' detailed - inner workings. - properties: [portable] - capabilities: [debug] - -- name: victrola - display: - attr: device - char: 'Q' - description: - - | - A device for reading and writing data on circular platters made of - a soft plastic material. The stylus must be made of a - hard and durable material, with a special tip that relies on - quantum effects to extract high-density information. - - | - Also allows manipulating composite values consisting of a - collection of named fields. For example, `[x = 2, y = "hi"]` - is a value of type `[x : int, y : text]`{=type}. Individual fields - can be projected using dot notation. For example, - `let r = [y="hi", x=2] in r.x` has the value `2`. The order - of the fields does not matter. - properties: [portable] - capabilities: [record] - -- name: quantum dot - display: - attr: gold - char: '.' - description: - - | - A nanoscale semiconductor particle with a wide range of - applications. - properties: [portable] - -- name: 'key' - display: - attr: gold - char: 'k' - description: - - A versatile item, with uses such as opening - locked doors, entering input, and retrieving stored values. - properties: [portable] - -- name: keyboard - display: - attr: device - char: 'K' - description: - - A small device with multiple keys, adapted for your unique anatomy. - - | - `installKeyHandler : text -> (key -> cmd unit) -> cmd unit` - installs a custom handler function that can be activated to - respond to keyboard inputs typed at the REPL. - - | - `key : text -> key` constructs values of type `key`{=type}, for - example `key "Down"` or `key "C-S-x"`. - properties: [portable] - capabilities: [handleinput] - -- name: halting oracle - display: - attr: device - char: '?' - description: - - A device to solve the halting problem. When asked if a - particular robot program will halt, it always answers YES. - And it is always correct... or else! - - | - Enables the command `halt : actor -> cmd unit` which takes - a robot as an argument and, if it is up to one cell away, - cancels its currently running program (if any). In creative mode, - there is no distance limitation. - properties: [portable] - capabilities: [halt] + - | + A tall, living entity made of a tough cellular material called "wood". + They regrow after being harvested and are an important raw ingredient used + in making many different devices. + properties: [pickable, growable, opaque, combustible] + growth: [500, 600] + combustion: + ignition: 0.01 + duration: [80, 120] + product: ash +- name: ash + display: + attr: rock + char: '#' + description: + - | + Burned-out remnants of combustion. + properties: [pickable] +- name: branch + display: + attr: wood + char: 'y' + description: + - A branch cut from a tree. It's as if the tree had to make a decision and was exploring two options. + properties: [pickable] +- name: log + display: + attr: wood + char: 'l' + description: + - A wooden log, obtained by harvesting a tree and cutting off its branches. + properties: [pickable, combustible] + combustion: + ignition: 0.05 + duration: [40, 80] + product: ash +- name: board + display: + attr: wood + char: 'w' + description: + - A wooden board, made by cutting a log into pieces. + properties: [pickable, combustible] + combustion: + ignition: 0.2 + duration: [20, 40] + product: ash +- name: workbench + display: + attr: wood + char: 'π' + description: + - A plain wooden workbench, providing space to make other things using the `make` command. + - | + Example: + ``` + make "log" + ``` + properties: [pickable] + capabilities: [make] +- name: paper + display: + attr: snow + char: '■' + description: + - A flat material made of pressed and dried wood fibers, used as a surface on which to inscribe symbols. + properties: [pickable, combustible] + combustion: + ignition: 0.5 + duration: [10, 20] + product: ash +- name: PhD thesis + display: + attr: snow + char: 'P' + description: + - Perhaps writing one of these will help gain the trust and respect of the native inhabitants. + properties: [pickable] +- name: rock + display: + attr: rock + char: 'o' + description: + - A medium-sized rock, picked up from the ground or created by drilling. Can be ground into sand or used to build a simple furnace, among other things. + properties: [pickable] +- name: handle + display: + attr: device + char: 'h' + description: + - Ergonomic affordance for manipulating objects. Also grants the "setname" capability, allowing one to assign a "handle" to robots. + properties: [pickable] + capabilities: [setname] +- name: lodestone + display: + attr: iron + char: 'o' + 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] +- name: beaglepuss + display: + attr: rubber + char: 'B' + description: + - Iconic novelty disguise. Renders one either completely inconspicuous, or the opposite. + properties: [pickable] + capabilities: [appear] +- name: boulder + display: + attr: rock + char: '@' + description: + - A very large, impassable rock. A drill can be used to get rid of it and turn it into smaller rocks. + properties: [unwalkable] +- name: mountain + display: + attr: snow + char: 'A' + description: + - A mountain. Can be tunneled through with a drill, but it takes time. + properties: [unwalkable, opaque] +- name: mountain tunnel + display: + attr: snow + char: 'Å' + priority: 11 + description: + - A tunnel in a mountain through which anything can freely move. + properties: [] +- name: copper ore + display: + attr: copper + char: 'C' + description: + - Raw copper ore, useful for making wires, pipes, and other metal things. Patches of copper ore can be found on the surface, but are quickly exhausted. + - Scanners seem to indicate larger quantities of copper could be found beneath some of the mountains, but those would require a drill to access and mine. + properties: [pickable] +- name: copper mine + display: + attr: copper' + char: 'Å' + priority: 11 + description: + - A copper vein that can be actively mined to produce copper ore. + properties: [] +- name: copper wire + display: + attr: copper + char: '|' + description: + - Copper wire is very good at conducting electricity and useful for making various types of circuits and machines. + properties: [pickable] +- name: strange loop + display: + attr: copper + char: '8' + description: + - Two copper wires twisted together in a strange shape that loops back on itself. It must be useful for something... + properties: [pickable] + capabilities: [recursion] +- name: copper pipe + display: + attr: copper + char: 'I' + description: + - A pipe made out of a thin sheet of copper. Great for transmitting water or steam. + properties: [pickable] +- name: iron plate + display: + attr: iron + char: '■' + description: + - Worked iron suitable for crafting resilient tools. + - It also possess some electro-magnetic properties. + properties: [pickable] +- name: iron gear + display: + attr: iron + char: '*' + description: + - An iron gear, suitable for constructing larger, more powerful machinery than a wooden gear. + properties: [pickable] +- name: iron ore + display: + attr: iron + char: 'F' + description: + - Raw iron ore. Used to create more resilient tools than copper. + - It can only be mined by drilling in the mountains. + properties: [pickable] +- name: iron mine + display: + attr: iron' + char: 'Å' + priority: 11 + description: + - An iron vein that can be actively mined to produce iron ore. + properties: [] +- name: quartz + display: + attr: quartz + char: 'Q' + description: + - Raw quartz crystals. Useful for creating devices like clocks, and can be processed to extract silicon. + - It can only be mined by drilling in the mountains. + properties: [pickable] +- name: quartz mine + display: + attr: quartz + char: 'Å' + priority: 11 + description: + - A quartz vein that can be actively mined to produce quartz. + properties: [] +- name: silicon + display: + attr: quartz + char: 'S' + description: + - Extracted by processing quartz at high temperatures, silicon can be used to construct integrated circuits. + properties: [pickable] +- name: deep mine + display: + attr: rock + char: 'Å' + priority: 11 + description: + - A deep mine that yields rare and wonderful treasures to those who are patient. + - But be careful lest you delve too greedily and too deep. + properties: [] +- name: silver + display: + attr: silver + char: '•' + description: + - A shiny, metallic substance, noted for its high reflectivity when polished. + properties: [pickable] +- name: gold + display: + attr: gold + char: '•' + description: + - A shiny, metallic substance, with applications in specialized electronics. + - It also seems to be highly valued by local aliens. + properties: [pickable] +- name: mithril + display: + attr: silver + char: 'M' + description: + - Mithril can be beaten like copper, and polished like glass. One can also make of it a metal, light and yet harder than tempered steel. Its beauty is like to that of common silver, but the beauty of mithril does not tarnish or grow dim. + properties: [pickable] +- name: furnace + display: + attr: fire + char: '#' + description: + - A furnace can be used to turn metal ore into various useful products. + properties: [pickable] +- name: big furnace + display: + attr: fire + char: '#' + description: + - A big furnace can get even hotter than a normal furnace, and can be used to process quartz into silicon. + properties: [pickable] +- name: small motor + display: + attr: entity + char: 'm' + description: + - A motor is useful for making devices that can turn when electric current is applied. + - This one is rather small, but surprisingly efficient. + properties: [pickable] +- name: big motor + display: + attr: entity + char: 'M' + description: + - A motor is useful for making devices that can turn when electric current is applied. + - This one is huge and could be used to construct powerful machinery. + properties: [pickable] +- name: flower + display: + attr: flower + char: '*' + description: + - A beautiful flower that grows wild in local meadows. It is not clear what it might be useful for, but it looks nice. + properties: [pickable, growable] + growth: [30, 50] +- name: tea plant + display: + attr: plant + char: 't' + description: + - Camellia sinensis. + properties: [pickable, growable] + growth: [5000, 6000] + yields: tea leaves +- name: cup of tea + display: + attr: sand + char: 'u' + description: + - A nice hot cup of tea. + properties: [pickable] +- name: tea leaves + display: + attr: plant + char: 'l' + description: + - Leaves picked from a tea plant. They give off a nice smell when crushed. + properties: [pickable] +- name: cotton + display: + attr: silver + char: 'i' + description: + - A plant with tufts of soft fibers that can be harvested and used to make things, including sheets of material that the local aliens like to drape over their bodies. + properties: [pickable, growable, combustible] + growth: [100, 800] + combustion: + ignition: 0.1 + duration: [20, 40] + product: ash +- name: linotype + display: + attr: silver + char: 't' + description: + - Employs hot lead typesetting to arrange glyphs into a mold for printing. + - | + An equipped `linotype`{=entity} device enables the `format` command: + ``` + format : a -> Text + ``` + which can turn any value into a suitable text representation. + properties: [pickable] + capabilities: [format] +- name: Elmer's glue + display: + attr: snow + char: 'g' + description: + - Polyvinyl acetate. Popular adhesive for crafting. Of dubious nutritional value. + - | + Facilitates the concatenation of text values. + - | + The infix operator `++ : Text -> Text -> Text`{=snippet} + can be used to concatenate two `Text`{=type} values. For example, + - | + ``` + let numWidgets = 42 + in "Number of widgets: " ++ format numWidgets + ``` + properties: [pickable] + capabilities: [concat] +- name: caliper + display: + attr: silver + char: 'C' + description: + - Simple, yet accurate measuring device. Can determine the length of a text value. + - | + ``` + chars : Text -> Int + ``` + computes the number of characters in a `Text`{=type} value. + properties: [pickable] + capabilities: [charcount] +- name: wedge + display: + attr: silver + char: 'v' + description: + - A simple machine for the textually-inclined; plain but effective. + - | + An equipped `wedge`{=entity} enables the `split` command: + ``` + split : Int -> Text -> Text * Text + ``` + splits a `Text`{=type} value into two pieces, one before the given index and one after. + properties: [pickable] + capabilities: [split] +- name: string + display: + attr: silver + char: '~' + description: + - A long, flexible device for transferring either force or information, made of twisted cotton fibers. Multiple strings can also be woven into larger configurations such as cloth or nets. + - | + An equipped `string`{=entity} device enables several commands for working with + `Text`{=type} values: + - | + `format : a -> Text` can turn any value into a suitable text + representation. + - | + The infix operator `++ : Text -> Text -> Text`{=snippet} + can be used to concatenate two text values. For example, + - | + ``` + let numWidgets = 42 + in "Number of widgets: " ++ format numWidgets + ``` + - | + `chars : Text -> Int` computes the number of characters in a + `Text`{=type} value. + - | + `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] +- name: decoder ring + display: + attr: silver + char: 'O' + description: + - | + A handy lookup table for converting from characters to numeric codes and + back, shaped for some reason into a ring. When equipped, it + enables two functions: + - | + `charAt : Int -> Text -> Int` returns the numeric code of the + character at a specific index in a (0-indexed) `Text`{=type} value. + - | + `toChar : Int -> Text` creates a singleton (length-1) `Text`{=type} + value containing a character with the given numeric code. + properties: [pickable] + capabilities: [code] +- name: lambda + display: + attr: flower + char: 'λ' + description: + - A wild lambda. They are somewhat rare, but regrow when picked. Lambdas are delicious when cooked into curry. + - Lambdas can also be used to create functions. For example, + - | + ``` + def thrice : Cmd Unit -> Cmd Unit = \c. c;c;c end + ``` + - defines the function `thrice`{=snippet} which repeats a command three times. + properties: [pickable, growable] + growth: [100, 200] + capabilities: [lambda] +- name: curry + display: + attr: flower + char: 'C' + description: + - Delicious curry cooked from wild lambdas. + properties: [pickable] +- name: water + display: + attr: water + char: ' ' + description: + - Liquid dihydrogen monoxide, which seems to be plentiful on this planet. + properties: [pickable, infinite, liquid] +- 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] + yields: water +- name: boat + display: + attr: wood + char: 'B' + description: + - A robot with a boat equipped can float on top of water without drowning. + - | + **NOTE:** most devices are automatically equipped on robots that + will require them; but this doesn't work in the case of boats since floating is not + associated with any particular command. To manually ensure a boat is equipped on + a robot, just add the special command `require "boat"` to the robot's program. + properties: [pickable] + capabilities: [float] +- name: sand + display: + attr: sand + char: '█' + description: + - A substance composed mostly of tiny rocks and mineral particles that can be used in a furnace to make glass. You can often find it near water, or make it yourself by grinding up rocks. + properties: [pickable] +- name: glass + display: + attr: entity + char: '□' + description: + - A pane of a brittle, clear substance, made from melting sand in a furnace. + properties: [pickable] +- name: lens + display: + attr: entity + char: 'O' + description: + - A polished, rounded piece of glass, capable of focusing rays of light. + properties: [pickable] +- name: LaTeX + display: + attr: flower + char: '$' + description: + - A naturally occurring substance derived from trees, useful for producing rubber and for typesetting mathematical documents. + properties: [pickable, growable] + growth: [2000, 3000] +- name: rubber + display: + attr: rubber + char: '%' + description: + - A flexible, durable material made from LaTeX. + properties: [pickable] +- name: bit (0) + display: + attr: entity + char: '0' + description: + - A bit is used to represent the smallest possible amount of information. Useful for constructing various information-processing devices, as well as drills. + properties: [pickable, growable] + growth: [200, 400] +- name: bit (1) + display: + attr: entity + char: '1' + description: + - A bit is used to represent the smallest possible amount of information. Useful for constructing various information-processing devices, as well as drills. + properties: [pickable, growable] + growth: [200, 400] +- name: pixel (R) + display: + attr: red + char: '.' + description: + - A tiny picture element, used either to emit or detect red light. + properties: [pickable, growable] + growth: [1000, 1500] +- name: pixel (G) + display: + attr: green + char: '.' + description: + - A tiny picture element, used either to emit or detect green light. + properties: [pickable, growable] + growth: [1000, 1500] +- name: pixel (B) + display: + attr: blue + char: '.' + description: + - A tiny picture element, used either to emit or detect blue light. + properties: [pickable, growable] + growth: [1000, 1500] +- name: camera + display: + attr: device + char: '@' + description: + - A camera is a device for capturing images. + properties: [pickable] +- name: circuit + display: + attr: plant + char: '#' + description: + - | + A circuit is needed for constructing various "smart" devices. + properties: [pickable] +- name: blueprint + display: + attr: blue + char: 'B' + description: + - This enables the `structure` 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. + - | + `floorplan : Text -> Cmd (Int * Int)` + - Gets the dimensions of a structure template. + properties: [pickable] + capabilities: [structure] +- name: drill bit + display: + attr: entity + char: '!' + description: + - A drill bit is the most important component of a drill, and must be made out of two bits of opposite parity, for strength. + properties: [pickable] +- name: box + display: + attr: wood + char: '□' + description: + - A wooden box. It can hold things or be used as housing for other devices. + properties: [pickable] +- name: wooden gear + display: + attr: wood + char: '*' + description: + - A wooden gear. Not quite as strong or versatile as an iron gear, but easy to produce. + properties: [pickable] +- name: teeter-totter + display: + attr: wood + char: '/' + description: + - A rotating board apparently popular with young aliens. Perhaps it could also be used as a primitive balance scale. + properties: [pickable] +- name: Linux + display: + attr: entity + char: 'L' + description: + - A copy of the Linux operating system. + properties: [pickable] +- name: gold coin + display: + char: '©' + attr: gold + description: + - A small round shaped piece of gold metal that the aliens pass between each other occasionaly. + - Besides staying shiny it does not appear to have practical use. + properties: [pickable] +############################################################ +### Utility ################################################ +############################################################ +- 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: 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] +############################################################ +### Devices ################################################ +############################################################ +- name: bitcoin + display: + char: '₿' + attr: gold + description: + - A beautiful round shaped piece of metal that seems to be of great value to the aliens on this planet. + - Just like the bit it has two sides and when you flip it, it lands perfectly randomly on one of the sides. + properties: [pickable] + capabilities: [random] +- name: treads + plural: treads + display: + attr: device + char: '%' + description: + - Equipping treads on a robot allows it to move and turn. + - The `move` command moves the robot forward one unit. + - | + For example to move two units: + - | + `move; move;` + - The `turn` command takes a direction as an argument, which can be either absolute (north, west, east, south) or relative (left, right, forward, back, down). + - | + Example: + - | + `move; turn left; move; turn right` + capabilities: [move, turn] + properties: [pickable] +- name: tank treads + plural: tank treads + display: + attr: device + char: '%' + description: + - Tank treads work like treads, but are large enough to move even heavy robots around. + capabilities: [move, turn, moveheavy] + properties: [pickable] +- name: tape drive + display: + attr: device + char: '%' + description: + - A `tape drive`{=entity} allows you to `backup`; that is, to drive in reverse. + capabilities: [backup] + properties: [pickable] +- name: dozer blade + display: + attr: silver + char: '/' + description: + - A broad, sturdy surface that can be attached to a robot and used to `push` objects. + - | + `push : Cmd Unit` will advance the robot and the entity in front of it forward by one step. + properties: [pickable] + capabilities: [push] +- name: grabber + display: + attr: device + char: '<' + description: + - A grabber arm is an all-purpose, hydraulically controlled device that can manipulate other items and robots via the `grab`, `place`, and `give` commands. + - The `grab` command takes no arguments; it simply grabs whatever is available, and also returns the name of the grabbed thing as a string. It raises an exception if run in a cell that does not contain an item. + - The `place` command takes one argument, the name of the item to place. The item is removed from the robot's inventory and placed in the robot's current cell (which must be empty). Raises an exception if the operation fails. + - "The `give` command takes two arguments: the `Actor`{=type} to give an item to (which can be at most 1 cell away), and the name of the item to give. Raises an exception if the operation fails." + capabilities: [grab, give, place] + properties: [pickable] +- name: fast grabber + display: + attr: device + char: '≪' + description: + - A fast grabber is an improved version of the basic grabber - not only can it `grab`, `place`, and `give`, it can also `swap`. + - The `swap` command allows the robot to execute grab and place at the same time so that the location where the robot is standing does not become empty. + - You can use this to prevent failures where multiple robots are trying to grab, place or scan a given location. + - In addition you retain the capability to use the `atomic` command, with which you can implement other commands that are safe when run in parallel. + capabilities: [grab, swap, give, place, atomic] + properties: [pickable] +- name: binoculars + display: + attr: device + char: 'B' + description: + - Allows one to `scout` for other robots + capabilities: [recondir] + properties: [pickable] +- name: welder + display: + attr: device + char: 'f' + description: + - | + A welder can be used to affix other gadgets to one's robot, providing + the `equip` and `unequip` commands. + - | + The `equip` command takes one argument: the name of the device to equip. + Raises an exception if the device is not in your inventory. + - | + The `unequip` command takes one argument: the name of the device to unequip. + Raises an exception if the device is not equipped. + capabilities: [equip, unequip] + properties: [pickable] +- name: harvester + display: + attr: device + char: '≤' + description: + - A harvester can be used via the `harvest` command, which is almost identical to the `grab` command. The big difference is that some entities, when harvested instead of grabbed, leave behind a seed which will eventually grow into another copy of the original entity. + - For entities which do not grow, `harvest` behaves exactly the same as `grab`. + capabilities: [grab, harvest, place] + properties: [pickable] +- name: toolkit + display: + attr: device + char: 'Ѣ' + description: + - "A toolkit can be used, via the `salvage` command, to take apart old robots." + - "`salvage` takes no arguments. It looks for an inactive robot (one which is not currently running a program) in the current cell. If an inactive robot is found, its log (if any) is downloaded and it is dismantled, transferring its knowledge, devices, and inventory to the robot running `salvage`. If no inactive robots are found in the current cell, `salvage` does nothing." + capabilities: [salvage] + properties: [pickable] +- name: solar panel + display: + attr: device + char: '#' + description: + - An extremely efficient solar panel, capable of generating sufficient power from ambient starlight alone. A robot powered by one of these can operate any time, including on cloudy days and at night. + capabilities: [power] + properties: [pickable] +- name: drill + display: + attr: device + char: '!' + description: + - A drill allows robots to `drill` through rocks and mountains (with e.g. `drill forward`), and extract resources from mines (with `drill down`). + capabilities: [drill] + properties: [pickable] +- name: metal drill + display: + attr: iron + char: '!' + description: + - A metal drill allows robots to drill through rocks and mountains, and extract resources from mines, faster than a regular drill. + - A metal drill is also able to drill deeper than a regular drill. Thus, some resources are only reachable using a metal drill. + capabilities: [drill] + properties: [pickable] +- name: typewriter + display: + attr: device + char: 'Д' + description: + - A typewriter is used to inscribe symbols on paper, thus reifying pure, platonic information into a physical form. + properties: [pickable] +- name: 3D printer + display: + attr: device + char: '3' + description: + - A 3D printer gives you the capability of printing more robots! You can access the 3D printer via the `build` command. + - 'Example:' + - | + ``` + build {move; grab; turn back; move; give base "tree"} + ``` + - | + builds a robot to get the tree on the cell to the + north (if there is one) and bring it back to the base. The `build` command + always returns a reference to the newly constructed robot. For example, + - | + ``` + r <- build {move}; view r + ``` + - | + builds a robot and then views it. + properties: [pickable] + capabilities: [build] +- name: dictionary + display: + attr: device + char: 'D' + description: + - | + A dictionary allows a robot to remember definitions and reuse them + later. You can access this ability with either a `def`{=snippet} command, + which creates a name for an expression or command that is + available from then on, or with a `let`{=snippet} expression, which names an + expression or command locally within another expression. + - | + ``` + def m2 : Cmd Unit = move; move end + ``` + - | + ``` + let x : Int = 3 in x^2 + 2*x + 1 + ``` + - The type annotations in `def`{=snippet} are optional. + properties: [pickable] + capabilities: [env] +- name: branch predictor + display: + attr: device + char: 'y' + description: + - | + A branch predictor is a device which allows a robot to interpret + conditional expressions. The syntax for a conditional expression + is `if` followed by three arguments: a boolean test and then + two delayed expressions (i.e. expressions in curly braces) of the same type. + - 'Example:' + - | + ``` + let x = 2 in + if (x > 3) {move} {turn right; move} + ``` + properties: [pickable] + capabilities: [cond] +- name: detonator + display: + attr: fire + char: '*' + description: + - An explosive device which can be used to self-destruct, via the `selfdestruct` command. Immediately vaporizes the robot and any inventory it is carrying. Can be useful, say, if you are sending out some exploratory robots and don't want them cluttering up the world once they are done. + properties: [pickable] + capabilities: [selfdestruct] +- name: life support system + display: + attr: device + char: 'Ж' + description: + - A state-of-the-art life support system which maintains the particular temperature and mixture of gases you need to survive. It uses a sophisticated recirculating system and can run pretty much indefinitely. Unfortunately, the atmosphere outside is severely toxic (why do the inhabitants of this planet need so much nitrogen!?), so you'll have to stay inside for now. + properties: [pickable] +- name: scanner + display: + 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`." + properties: [pickable] + capabilities: [scan, sensefront, sensehere] +- name: olfactometer + display: + char: 'N' + description: + - An electronic "nose" that can tell how far away something is. + - | + `sniff : Text -> Cmd Int` returns the distance to the nearest specified entity. + properties: [pickable] + capabilities: [detectdistance] +- name: flash memory + display: + attr: device + char: '§' + description: + - "A compact, non-volatile memory device, capable of storing up to 8 pZ of data." + - "Flash memory can be used as a component of other devices. In addition, a flash memory device can be used to reprogram other robots using the `reprogram` command." + - "The robot being reprogrammed must be idle, and must possess enough capabilities to run the new command; otherwise reprogramming will fail." + properties: [pickable] + capabilities: [reprogram] +- name: mirror + display: + attr: device + char: 'U' + description: + - "With a mirror, robots can reflect on themselves and see their own name." + - "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] +- name: logger + display: + attr: device + char: 'l' + description: + - "Allows a robot to generate and store messages for later viewing, using the `log` command, which takes a string. Log messages are also automatically generated by uncaught exceptions." + properties: [pickable] + capabilities: [log] +- name: hearing aid + display: + attr: device + char: '@' + description: + - "Allows a robot to hear anything being said nearby." + - "Simply having this device equipped will automatically add messages said by nearby actors to this robot's log, assuming it has a logger equipped." + - "That way you can view any heard message later either in the logger or the message window." + - "To wait for a message and get the string value, use:" + - | + ``` + l <- listen; log $ "I have waited for someone to say " ++ l + ``` + properties: [pickable] + capabilities: [listen] +- name: counter + display: + attr: device + char: 'C' + description: + - | + A counter enables the command `count : Text -> Cmd Int`, + which counts how many occurrences of an entity are currently + in the inventory. This is an upgraded version of the `has` + command, which returns a `Bool`{=type} instead of an `Int`{=type} and does + not require any special device. + properties: [pickable] + capabilities: [count] +- name: calculator + display: + attr: device + char: '+' + description: + - "A calculator allows a robot to do basic arithmetic calculations: addition, subtraction, multiplication, division, and exponentiation." + properties: [pickable] + capabilities: [arith] +- name: ADT calculator + display: + attr: device + char: '±' + description: + - | + A calculator with Advanced Display Technology (an attached + typewriter that can print out the results). For some reason, in + addition to the usual arithmetic on numbers, an ADT calculator can + also do arithmetic on types! After all, the helpful typewritten manual + explains, a type is just a collection of values, and a finite collection + of values is just a fancy number. For example, the type `Bool`{=type} is + just a fancy version of the number 2, where the two things happen to be + labelled `false` and `true`. There are also types `Unit`{=type} and + `Void`{=type} that correspond to 1 and 0, respectively. + - | + The product of two types is a type of pairs, since, for example, + 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`. + - | + 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, + and there are `2 + 3 == 5` such values. For working with sums of + types, the ADT calculator provides the injection functions `inl : + a -> a + b` and `inr : b -> a + b`, as well as the case analysis + function `case : (a + b) -> (a -> c) -> (b -> c) -> c`. For + 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] +- name: hyperloop + display: + attr: device + char: '∞' + description: + - | + Is it a calculator with a strange antenna? A strange loop with + a built-in calculator? Who can say? A `hyperloop`{=entity} + gives you the ability to create recursive types: the type + `rec t. T(t)`{=snippet} (where `T(t)`{=snippet} is some type + containing `t`{=type}) is the type `t`{=type} such that + `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] +- name: compass + display: + attr: device + char: 'N' + description: + - | + A compass gives a robot the ability to orient using the cardinal + directions north, south, west, and east. For example: + - | + `turn west; move; turn north` + - | + It also enables the `heading : Cmd Dir` command, which returns the + robot's current heading. For example, the following code moves + east and then restores the same heading as before: + - | + `d <- heading; turn east; move; turn d` + properties: [pickable] + capabilities: [orient] +- name: clock + display: + attr: device + char: '0' + description: + - A clock is a device for keeping track of time. It enables the `wait` and `time` commands. + - | + `time : Cmd Int` returns the current time, measured in game ticks since the beginning of the game. + - | + `wait : Int -> Cmd Unit` causes a robot to sleep for a specified amount of time (measured in game ticks). + properties: [pickable] + capabilities: [timeabs, timerel] +- name: hourglass + display: + attr: device + char: '8' + description: + - An hourglass can measure the relative passage of time. It enables the `wait` command. + - | + `wait : Int -> Cmd Unit` causes a robot to sleep for a specified amount of time (measured in game ticks). + properties: [pickable] + capabilities: [timerel] +- name: rolex + display: + char: R + attr: silver + description: + - Enables robots to use the `watch` and `wait` commands. + - | + `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] +- name: comparator + display: + attr: device + char: '>' + description: + - "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] +- name: I/O cable + display: + attr: device + char: 'Ю' + description: + - An I/O cable can be used to communicate with adjacent actors. + properties: [pickable] +- name: rubber band + display: + attr: device + char: 'O' + description: + - "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 ()} {} + ``` + - "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 ()} {}) + ``` + properties: [pickable] + capabilities: [atomic] +- name: net + display: + attr: silver + char: '#' + description: + - A net is a device woven out of many strings. With a net equipped, you can use the `try` command to catch errors. For example + - | + ``` + try {move} {turn left} + ``` + - will attempt to move, but if that fails, turn left instead. + properties: [pickable] + capabilities: [try] +- name: antenna + display: + attr: silver + char: 'Y' + description: + - A device for transforming electric current into radio waves, and vice versa. Antennas can be used to increase the viable range over which you can communicate with your robots. + - | + Antennas can also be used to locate nearby actors, by bouncing radio + waves off them and listening for the echo. This capability can be + accessed via two commands: + - | + `meet : Cmd (Unit + Actor)` tries to locate a + nearby actor (a robot, or... something else?) up to one cell away. + It returns a reference to the nearest actor, or a unit value if + none are found. + - | + `meetAll : Cmd (rec l. Unit + Actor * l)` returns a list of + all the nearby actors other than oneself. + properties: [pickable] + capabilities: [meet] +- name: GPS receiver + display: + attr: device + char: 'G' + description: + - | + A GPS receiver triangulates your current (x,y) coordinates from + some convenient satellite signals, + enabling the command `whereami : Cmd (Int * Int)`. + properties: [pickable] + capabilities: [senseloc] +- name: tweezers + display: + attr: device + char: 'V' + description: + - | + Sometimes small, self-reproducing creatures get stuck inside a robot's + relays, preventing it from executing properly. Tweezers are + useful for removing such pests, and for inspecting robots' detailed + inner workings. + properties: [pickable] + capabilities: [debug] +- name: victrola + display: + attr: device + char: 'Q' + description: + - | + A device for reading and writing data on circular platters made of + a soft plastic material. The stylus must be made of a + hard and durable material, with a special tip that relies on + quantum effects to extract high-density information. + - | + Also allows manipulating composite values consisting of a + collection of named fields. For example, `[x = 2, y = "hi"]` + is a value of type `[x : Int, y : Text]`{=type}. Individual fields + can be projected using dot notation. For example, + `let r = [y="hi", x=2] in r.x` has the value `2`. The order + of the fields does not matter. + properties: [pickable] + capabilities: [record] +- name: quantum dot + display: + attr: gold + char: '.' + description: + - | + A nanoscale semiconductor particle with a wide range of + applications. + properties: [pickable] +- name: 'key' + display: + attr: gold + char: 'k' + description: + - A versatile item, with uses such as opening locked doors, entering input, and retrieving stored values. + properties: [pickable] +- name: keyboard + display: + attr: device + char: 'K' + description: + - A small device with multiple keys, adapted for your unique anatomy. + - | + `installKeyHandler : Text -> (Key -> Cmd Unit) -> Cmd Unit` + installs a custom handler function that can be activated to + respond to keyboard inputs typed at the REPL. + - | + `key : Text -> Key` constructs values of type `Key`{=type}, for + example `key "Down"` or `key "C-S-x"`. + properties: [pickable] + capabilities: [handleinput] +- name: halting oracle + display: + attr: device + char: '?' + description: + - A device to solve the halting problem. When asked if a particular robot program will halt, it always answers YES. And it is always correct... or else! + - | + Enables the command `halt : Actor -> Cmd Unit` which takes + a robot as an argument and, if it is up to one cell away, + cancels its currently running program (if any). In creative mode, + there is no distance limitation. + properties: [pickable] + capabilities: [halt] +- name: atomic vector plotter + display: + attr: device + char: 'A' + description: + - A plot device for plotting interstellar and intermolecular atomic vector gradients. + properties: [pickable] +- name: infinite improbability drive + display: + attr: device + char: 'I' + description: + - | + Enables the `teleport` command, which takes as arguments an + `Actor`{=type} and a location in the form of a pair of + coordinates, and teleports the given actor to the specified + coordinates (and may also have some improbable side effects). + properties: [pickable] + capabilities: [teleport] diff --git a/data/recipes.yaml b/data/recipes.yaml --- a/data/recipes.yaml +++ b/data/recipes.yaml @@ -3,847 +3,799 @@ ######################################### - in: - - [1, tree] + - [1, tree] out: - - [2, branch] - - [1, log] - + - [2, branch] + - [1, log] - in: - - [1, log] + - [1, log] out: - - [4, board] - + - [4, board] - in: - - [1, log] - - [8, water] + - [1, log] + - [8, water] out: - - [8, paper] - + - [8, paper] - in: - - [32, paper] - - [1, flash memory] + - [32, paper] + - [1, flash memory] out: - - [1, dictionary] - + - [1, dictionary] - in: - - [256, paper] - - [1, LaTeX] + - [256, paper] + - [1, LaTeX] required: - - [1, big furnace] + - [1, big furnace] out: - - [1, PhD thesis] + - [1, PhD thesis] time: 65536 - - in: - - [1, log] + - [1, log] out: - - [1, logger] - + - [1, logger] - in: - - [1, board] - - [2, branch] + - [1, board] + - [2, branch] out: - - [1, workbench] - + - [1, workbench] - in: - - [2, branch] + - [2, branch] out: - - [1, branch predictor] - + - [1, branch predictor] - in: - - [6, board] + - [6, board] out: - - [1, box] - + - [1, box] - in: - - [5, board] + - [5, board] out: - - [1, boat] - + - [1, boat] - in: - - [2, board] + - [2, board] out: - - [1, wooden gear] - + - [1, wooden gear] - in: - - [1, board] - - [2, wooden gear] + - [1, board] + - [2, wooden gear] out: - - [1, teeter-totter] - + - [1, teeter-totter] - in: - - [1, teeter-totter] - - [2, copper wire] + - [1, teeter-totter] + - [2, copper wire] out: - - [1, comparator] - + - [1, comparator] - in: - - [2, board] - - [2, wooden gear] - - [1, box] + - [2, board] + - [2, wooden gear] + - [1, box] out: - - [1, harvester] - + - [1, harvester] - in: - - [1, circuit] - - [1, board] - - [8, wooden gear] + - [1, circuit] + - [1, board] + - [8, wooden gear] out: - - [1, typewriter] - + - [1, typewriter] ######################################### ## BITS ## ######################################### - - in: - - [1, bit (0)] - - [1, bit (1)] + - [1, bit (0)] + - [1, bit (1)] out: - - [1, drill bit] - + - [1, drill bit] - in: - - [1, bit (0)] + - [1, bit (0)] out: - - [1, bit (1)] + - [1, bit (1)] required: - - [1, lodestone] - + - [1, lodestone] - in: - - [1, bit (1)] + - [1, bit (1)] out: - - [1, bit (0)] + - [1, bit (0)] required: - - [1, lodestone] - + - [1, lodestone] - in: - - [8, bit (0)] - - [8, bit (1)] + - [8, bit (0)] + - [8, bit (1)] out: - - [1, flash memory] - + - [1, flash memory] - in: - - [1, flash memory] - - [8, wooden gear] + - [1, flash memory] + - [8, wooden gear] out: - - [1, counter] - + - [1, counter] ######################################### ## STONE ## ######################################### - - in: - - [1, boulder] + - [1, boulder] out: - - [3, rock] + - [3, rock] required: - - [1, drill] + - [1, drill] time: 9 weight: 3 - - in: - - [1, boulder] + - [1, boulder] out: - - [4, rock] + - [4, rock] required: - - [1, drill] + - [1, drill] time: 9 weight: 1 - - in: - - [1, boulder] + - [1, boulder] out: - - [3, rock] + - [3, rock] required: - - [1, metal drill] + - [1, metal drill] time: 3 weight: 3 - - in: - - [1, boulder] + - [1, boulder] out: - - [4, rock] + - [4, rock] required: - - [1, metal drill] + - [1, metal drill] time: 3 weight: 3 - - in: - - [1, rock] + - [1, rock] out: - - [4, sand] + - [4, sand] required: - - [1, drill] + - [1, drill] time: 9 - - in: - - [1, rock] + - [1, rock] out: - - [4, sand] + - [4, sand] required: - - [1, metal drill] + - [1, metal drill] time: 3 - - in: - - [1, mountain] + - [1, mountain] out: - - [8, rock] - - [1, mountain tunnel] + - [8, rock] + - [1, mountain tunnel] required: - - [1, drill] + - [1, drill] time: 90 weight: 16 - - in: - - [1, mountain] + - [1, mountain] out: - - [8, lodestone] - - [4, iron ore] - - [1, mountain tunnel] + - [8, lodestone] + - [4, iron ore] + - [1, mountain tunnel] required: - - [1, drill] + - [1, drill] time: 90 weight: 1 - - in: - - [1, mountain] + - [1, mountain] out: - - [16, rock] - - [1, mountain tunnel] + - [16, rock] + - [1, mountain tunnel] required: - - [1, metal drill] + - [1, metal drill] time: 9 - weight: 160 - + weight: 34 - in: - - [1, mountain] + - [1, mountain] out: - - [16, lodestone] - - [8, iron ore] - - [1, mountain tunnel] + - [16, lodestone] + - [8, iron ore] + - [1, mountain tunnel] required: - - [1, metal drill] + - [1, metal drill] time: 9 - weight: 10 - + weight: 2 - in: - - [5, rock] + - [5, rock] out: - - [1, furnace] - + - [1, furnace] - in: - - [10, rock] - - [10, solar panel] + - [100, rock] + - [10, solar panel] out: - - [1, big furnace] - + - [1, big furnace] ######################################### ## METAL ## ######################################### - ## VEINS - - in: - - [1, mountain] + - [1, mountain] out: - - [1, copper mine] - - [1, copper ore] + - [1, copper mine] + - [1, copper ore] required: - - [1, drill] + - [1, drill] time: 42 weight: 2 - - in: - - [1, mountain] + - [1, mountain] out: - - [1, iron mine] - - [1, iron ore] + - [1, iron mine] + - [1, iron ore] required: - - [1, drill] + - [1, drill] time: 64 weight: 2 - - in: - - [1, mountain] + - [1, mountain] out: - - [1, quartz mine] - - [1, quartz] + - [1, quartz mine] + - [1, quartz] required: - - [1, drill] + - [1, drill] time: 64 weight: 1 - - in: - - [1, mountain] + - [1, mountain] out: - - [1, copper mine] - - [1, copper ore] + - [1, copper mine] + - [1, copper ore] required: - - [1, metal drill] + - [1, metal drill] time: 6 - weight: 10 - + weight: 5 - in: - - [1, mountain] + - [1, mountain] out: - - [1, iron mine] - - [1, iron ore] + - [1, iron mine] + - [1, iron ore] required: - - [1, metal drill] + - [1, metal drill] time: 7 - weight: 10 - + weight: 5 - in: - - [1, mountain] + - [1, mountain] out: - - [1, quartz mine] - - [1, quartz] + - [1, quartz mine] + - [1, quartz] required: - - [1, metal drill] + - [1, metal drill] time: 7 - weight: 10 - + weight: 3 ## MINES - - in: - - [1, copper mine] + - [1, copper mine] out: - - [1, copper ore] - - [1, copper mine] + - [1, copper ore] + - [1, copper mine] required: - - [1, drill] + - [1, drill] time: 42 weight: 9 - - in: - - [1, copper mine] + - [1, copper mine] out: - - [2, rock] - - [1, copper mine] + - [2, rock] + - [1, copper mine] required: - - [1, drill] + - [1, drill] time: 42 - - in: - - [1, iron mine] + - [1, iron mine] out: - - [1, iron ore] - - [1, iron mine] + - [1, iron ore] + - [1, iron mine] required: - - [1, drill] + - [1, drill] time: 64 weight: 9 - - in: - - [1, iron mine] + - [1, iron mine] out: - - [2, rock] - - [1, iron mine] + - [2, rock] + - [1, iron mine] required: - - [1, drill] + - [1, drill] time: 64 - - in: - - [1, quartz mine] + - [1, quartz mine] out: - - [1, quartz] - - [1, quartz mine] + - [1, quartz] + - [1, quartz mine] required: - - [1, drill] + - [1, drill] time: 64 weight: 9 - - in: - - [1, quartz mine] + - [1, quartz mine] out: - - [2, rock] - - [1, quartz mine] + - [2, rock] + - [1, quartz mine] required: - - [1, drill] + - [1, drill] time: 64 - - in: - - [1, copper mine] + - [1, copper mine] out: - - [1, copper ore] - - [1, copper mine] + - [1, copper ore] + - [1, copper mine] required: - - [1, metal drill] + - [1, metal drill] time: 6 - - in: - - [1, iron mine] + - [1, iron mine] out: - - [1, iron ore] - - [1, iron mine] + - [1, iron ore] + - [1, iron mine] required: - - [1, metal drill] + - [1, metal drill] time: 7 - - in: - - [1, quartz mine] + - [1, quartz mine] out: - - [1, quartz] - - [1, quartz mine] + - [1, quartz] + - [1, quartz mine] required: - - [1, metal drill] + - [1, metal drill] time: 7 - ## SMELTING - - in: - - [1, copper ore] - - [1, log] + - [1, copper ore] + - [1, log] out: - - [10, copper wire] + - [10, copper wire] required: - - [1, furnace] - + - [1, furnace] - in: - - [1, copper ore] - - [1, log] + - [1, copper ore] + - [1, log] out: - - [2, copper pipe] + - [2, copper pipe] required: - - [1, furnace] - + - [1, furnace] - in: - - [1, iron ore] - - [2, log] + - [1, iron ore] + - [2, log] out: - - [2, iron plate] + - [2, iron plate] required: - - [1, furnace] - + - [1, furnace] - in: - - [1, copper ore] + - [1, copper ore] out: - - [10, copper wire] + - [10, copper wire] required: - - [1, big furnace] - + - [1, big furnace] - in: - - [1, copper ore] + - [1, copper ore] out: - - [2, copper pipe] + - [2, copper pipe] required: - - [1, big furnace] - + - [1, big furnace] - in: - - [1, iron ore] + - [1, iron ore] out: - - [2, iron plate] + - [2, iron plate] required: - - [1, big furnace] - + - [1, big furnace] - in: - - [1, iron plate] + - [2, iron plate] out: - - [1, lodestone] + - [1, dozer blade] +- in: + - [1, iron plate] + out: + - [1, lodestone] required: - - [2, lodestone] + - [2, lodestone] time: 64 - ## TOOLS - - in: - - [1, iron plate] + - [1, iron plate] out: - - [2, iron gear] - + - [2, iron gear] - in: - - [1, iron plate] - - [1, water] - - [1, box] + - [1, iron plate] + - [1, water] + - [1, box] out: - - [1, compass] + - [1, compass] required: - - [1, lodestone] - + - [1, lodestone] - in: - - [32, wooden gear] - - [6, copper wire] + - [32, wooden gear] + - [6, copper wire] out: - - [1, small motor] - + - [1, small motor] - in: - - [16, iron gear] - - [6, copper wire] + - [16, iron gear] + - [6, copper wire] out: - - [1, big motor] - + - [1, big motor] - in: - - [1, box] - - [1, drill bit] - - [1, small motor] + - [1, box] + - [1, drill bit] + - [1, small motor] out: - - [1, drill] - + - [1, drill] - in: - - [1, box] - - [3, drill bit] - - [1, big motor] + - [1, box] + - [3, drill bit] + - [1, big motor] out: - - [1, metal drill] - + - [1, metal drill] - in: - - [1, box] - - [2, board] - - [4, copper pipe] - - [2, iron plate] - - [2, rubber] + - [1, box] + - [2, board] + - [4, copper pipe] + - [2, iron plate] + - [2, rubber] out: - - [1, toolkit] - + - [1, toolkit] - in: - - [2, small motor] - - [8, iron plate] - - [2, rubber] + - [2, small motor] + - [8, iron plate] + - [2, rubber] out: - - [1, treads] - + - [1, treads] - in: - - [4, big motor] - - [64, iron plate] - - [16, rubber] + - [4, big motor] + - [64, iron plate] + - [16, rubber] required: - - [1, welder] + - [1, welder] out: - - [1, tank treads] - + - [1, tank treads] - in: - - [2, copper pipe] - - [2, iron gear] - - [1, iron plate] - - [1, water] - - [1, small motor] + - [2, copper pipe] + - [2, iron gear] + - [1, iron plate] + - [1, water] + - [1, small motor] out: - - [1, grabber] - + - [1, grabber] - in: - - [2, grabber] - - [1, rubber band] + - [2, grabber] + - [1, rubber band] out: - - [1, fast grabber] - + - [1, fast grabber] - in: - - [2, copper wire] - - [1, copper pipe] - - [1, iron plate] - - [1, I/O cable] + - [2, copper wire] + - [1, copper pipe] + - [1, iron plate] + - [1, I/O cable] out: - - [1, welder] - + - [1, welder] - in: - - [1, copper pipe] + - [1, copper pipe] out: - - [1, handle] + - [1, handle] required: - - [1, welder] - + - [1, welder] - in: - - [4, circuit] - - [1, iron plate] - - [3, copper pipe] - - [16, iron gear] + - [4, circuit] + - [1, iron plate] + - [3, copper pipe] + - [16, iron gear] out: - - [1, 3D printer] - + - [1, 3D printer] - in: - - [1, gold] + - [1, gold] out: - - [8, gold coin] + - [8, gold coin] required: - - [1, furnace] - + - [1, furnace] - in: - - [1, gold] + - [1, gold] out: - - [8, gold coin] + - [8, gold coin] required: - - [1, big furnace] - + - [1, big furnace] - in: - - [1, gold coin] - - [1, bit (1)] - - [1, bit (0)] + - [1, gold coin] + - [1, bit (1)] + - [1, bit (0)] required: - - [1, metal drill] + - [1, metal drill] out: - - [1, bitcoin] - + - [1, bitcoin] - in: - - [2, silver] - - [2, copper wire] + - [2, silver] + - [2, copper wire] out: - - [1, antenna] - + - [1, antenna] - in: - - [1, antenna] - - [1, clock] - - [1, circuit] - - [1, compass] + - [1, antenna] + - [1, clock] + - [1, circuit] + - [1, compass] out: - - [1, GPS receiver] - + - [1, GPS receiver] - in: - - [1, iron plate] + - [1, iron plate] out: - - [1, tweezers] - + - [1, tweezers] ## MAGIC - - in: - - [2, copper wire] + - [2, copper wire] out: - - [1, strange loop] - + - [1, strange loop] - in: - - [2, copper pipe] - - [4, copper wire] - - [1, paper] - - [1, lodestone] + - [2, copper pipe] + - [4, copper wire] + - [1, paper] + - [1, lodestone] out: - - [2, hearing aid] - - + - [2, hearing aid] ######################################### ## QUARTZ + SILICON ## ######################################### - - in: - - [4, quartz] + - [4, quartz] out: - - [1, silicon] + - [1, silicon] required: - - [1, big furnace] - + - [1, big furnace] - in: - - [1, quartz] - - [32, iron gear] - - [1, glass] + - [1, quartz] + - [32, iron gear] + - [1, glass] out: - - [1, clock] - + - [1, clock] - in: - - [4, silicon] - - [1, strange loop] - - [16, copper wire] - - [8, bit (0)] - - [8, bit (1)] + - [1, clock] + - [1, scanner] out: - - [1, circuit] - + - [1, rolex] +- in: + - [4, silicon] + - [1, strange loop] + - [16, copper wire] + - [8, bit (0)] + - [8, bit (1)] + out: + - [1, circuit] ######################################### ## DEEP MINES ## ######################################### - - in: - - [1, mountain] + - [1, mountain] out: - - [1, deep mine] + - [1, deep mine] required: - - [1, metal drill] + - [1, metal drill] time: 512 weight: 1 - - in: - - [1, deep mine] + - [1, deep mine] out: - - [1, copper ore] - - [1, deep mine] + - [1, copper ore] + - [1, deep mine] required: - - [1, metal drill] + - [1, metal drill] time: 64 weight: 1000 - - in: - - [1, deep mine] + - [1, deep mine] out: - - [1, iron ore] - - [1, deep mine] + - [1, iron ore] + - [1, deep mine] required: - - [1, metal drill] + - [1, metal drill] time: 64 weight: 500 - - in: - - [1, deep mine] + - [1, deep mine] out: - - [1, silver] - - [1, deep mine] + - [1, silver] + - [1, deep mine] required: - - [1, metal drill] + - [1, metal drill] time: 64 weight: 50 - - in: - - [1, deep mine] + - [1, deep mine] out: - - [1, gold] - - [1, deep mine] + - [1, gold] + - [1, deep mine] required: - - [1, metal drill] + - [1, metal drill] time: 64 weight: 20 - - in: - - [1, deep mine] + - [1, deep mine] out: - - [1, mithril] - - [1, deep mine] + - [1, mithril] + - [1, deep mine] required: - - [1, metal drill] + - [1, metal drill] time: 64 weight: 1 - ######################################### ## PIXELS ## ######################################### - - in: - - [1, glass] - - [10, pixel (R)] - - [10, pixel (G)] - - [10, pixel (B)] + - [1, glass] + - [10, pixel (R)] + - [10, pixel (G)] + - [10, pixel (B)] out: - - [1, camera] - + - [1, camera] - in: - - [1, camera] - - [1, circuit] + - [1, camera] + - [1, circuit] out: - - [1, scanner] - + - [1, scanner] ######################################### ## SAND ## ######################################### - - in: - - [1, sand] + - [1, sand] out: - - [1, glass] + - [1, glass] required: - - [1, furnace] - + - [1, furnace] - in: - - [1, glass] - - [8, copper wire] + - [1, water] + - [1, copper pipe] + - [1, glass] out: - - [1, solar panel] + - [1, olfactometer] +- in: + - [1, sand] + out: + - [1, glass] required: - - [1, 3D printer] - + - [1, big furnace] - in: - - [1, counter] - - [1, solar panel] + - [2, board] + - [1, glass] + - [1, sand] out: - - [1, calculator] - + - [1, hourglass] - in: - - [1, calculator] - - [1, typewriter] - - [1, I/O cable] + - [1, glass] + - [1, mithril] out: - - [1, ADT calculator] - + - [1, lens] + required: + - [1, drill] - in: - - [1, glass] - - [1, silver] + - [1, glass] + - [8, copper wire] out: - - [1, mirror] - + - [1, solar panel] + required: + - [1, 3D printer] +- in: + - [1, counter] + - [1, solar panel] + out: + - [1, calculator] +- in: + - [1, calculator] + - [1, typewriter] + - [1, I/O cable] + out: + - [1, ADT calculator] +- in: + - [1, ADT calculator] + - [1, strange loop] + out: + - [1, hyperloop] +- in: + - [1, glass] + - [1, silver] + out: + - [1, mirror] ######################################### ## LAMBDA ## ######################################### - - in: - - [5, lambda] - - [1, water] + - [5, lambda] + - [1, water] out: - - [1, curry] - + - [1, curry] ######################################### ## LATEX ## ######################################### - - in: - - [1, LaTeX] - - [1, log] + - [1, LaTeX] + - [1, log] out: - - [1, rubber] + - [1, rubber] required: - - [1, furnace] - + - [1, furnace] - in: - - [8, copper wire] - - [1, rubber] + - [1, LaTeX] out: - - [1, I/O cable] - + - [1, rubber] + required: + - [1, big furnace] - in: - - [1, rubber] - - [1, strange loop] + - [8, copper wire] + - [1, rubber] out: - - [1, rubber band] - + - [1, I/O cable] - in: - - [1, rubber] - - [1, glass] - - [1, string] + - [1, rubber] + - [1, strange loop] out: - - [1, beaglepuss] - + - [1, rubber band] +- in: + - [1, rubber] + - [1, glass] + - [1, string] + out: + - [1, beaglepuss] ######################################### ## COTTON ## ######################################### - - in: - - [4, cotton] + - [4, cotton] out: - - [1, string] + - [1, string] required: - - [1, small motor] - + - [1, small motor] - in: - - [256, string] + - [256, string] out: - - [1, net] - + - [1, net] ######################################### ## MISC ## ######################################### - - in: - - [1, water] - - [1, silicon] + - [1, lens] + - [1, string] + - [10, curry] + out: + - [1, detonator] +- in: + - [1, water] + - [1, silicon] required: - - [50, solar panel] + - [50, solar panel] out: - - [1, quantum dot] - + - [1, quantum dot] - in: - - [1, small motor] - - [1, copper pipe] - - [1, mithril] - - [1, quantum dot] - - [1, iron plate] + - [1, small motor] + - [1, copper pipe] + - [1, mithril] + - [1, quantum dot] + - [1, iron plate] out: - - [1, victrola] - + - [1, victrola] - in: - - [1, iron plate] + - [1, iron plate] out: - - [4, key] - + - [4, key] - in: - - [1, board] - - [16, key] + - [1, board] + - [16, key] out: - - [1, keyboard] - + - [1, keyboard] - in: - - [1, branch predictor] - - [1, grabber] - - [1, toolkit] + - [1, branch predictor] + - [1, grabber] + - [1, toolkit] out: - - [1, halting oracle] + - [1, halting oracle] +- in: + - [1, tea leaves] + - [1, water] + required: + - [1, furnace] + out: + - [1, cup of tea] +- in: + - [1, rubber band] + - [1, typewriter] + - [1, compass] + - [1, counter] + out: + - [1, atomic vector plotter] +- in: + - [1, cup of tea] + - [5, bitcoin] + - [3, PhD thesis] + - [1, atomic vector plotter] + out: + - [1, infinite improbability drive] diff --git a/data/scenarios/00-ORDER.txt b/data/scenarios/00-ORDER.txt --- a/data/scenarios/00-ORDER.txt +++ b/data/scenarios/00-ORDER.txt @@ -8,3 +8,4 @@ Testing Vignettes Mechanics +World Examples 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 @@ -13,9 +13,12 @@ lights-out.yaml bucket-brigade.yaml wave.yaml +gallery.yaml wolf-goat-cabbage.yaml blender.yaml friend.yaml +pack-tetrominoes.yaml +dimsum.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 @@ -4,19 +4,14 @@ description: Make 2048! objectives: - goal: - - OK, OK, it's not really the same as the classic "2048" game. - However, your goal is still to make 2048! You start with a `1`{=entity} - which regrows immediately when - it is `harvest`ed, so if you plant it, you can get as many as you want. Your - job is to combine `1`{=entity}s in order to make a `2048`{=entity} - entity. - - "Hint: the `format` command can turn numbers into strings!" + - OK, OK, it's not really the same as the classic "2048" game. However, your goal is still to make 2048! You start with a `1`{=entity} which regrows immediately when it is `harvest`ed, so if you plant it, you can get as many as you want. Your job is to combine `1`{=entity}s in order to make a `2048`{=entity} entity. + - "Hint: the `format` command can turn numbers into strings!" condition: | try { as base {has "2048"} } { return false } solution: | - def makeN : int -> cmd unit = \n. + def makeN : Int -> Cmd Unit = \n. if (n == 1) {harvest; return ()} {makeN (n/2); makeN (n/2); make (format n)} @@ -29,135 +24,133 @@ attr: gold char: "#" description: - - This is a one. Maybe you can combine it with other ones - somehow. - properties: [growable, portable, infinite] + - This is a one. Maybe you can combine it with other ones somehow. + properties: [growable, pickable, infinite] - name: "2" display: attr: gold char: "#" description: - - This is a two. Maybe you can combine it with other twos - somehow. - properties: [portable] + - This is a two. Maybe you can combine it with other twos somehow. + properties: [pickable] - name: "4" display: attr: gold char: "#" description: - - This is a four. You get the idea. - properties: [portable] + - This is a four. You get the idea. + properties: [pickable] - name: "8" display: attr: gold char: "#" description: - - An eight. - properties: [portable] + - An eight. + properties: [pickable] - name: "16" display: attr: gold char: "#" description: - - A 16. - properties: [portable] + - A 16. + properties: [pickable] - name: "32" display: attr: gold char: "#" description: - - A 32. - properties: [portable] + - A 32. + properties: [pickable] - name: "64" display: attr: gold char: "#" description: - - A 64. - properties: [portable] + - A 64. + properties: [pickable] - name: "128" display: attr: gold char: "#" description: - - A 128. - properties: [portable] + - A 128. + properties: [pickable] - name: "256" display: attr: gold char: "#" description: - - A 256. - properties: [portable] + - A 256. + properties: [pickable] - name: "512" display: attr: gold char: "#" description: - - A 512. - properties: [portable] + - A 512. + properties: [pickable] - name: "1024" display: attr: gold char: "#" description: - - A 1024. - properties: [portable] + - A 1024. + properties: [pickable] - name: "2048" display: attr: gold char: "#" description: - - A 2048. - properties: [portable] + - A 2048. + properties: [pickable] recipes: - in: - - [2, "1"] + - [2, "1"] out: - - [1, "2"] + - [1, "2"] - in: - - [2, "2"] + - [2, "2"] out: - - [1, "4"] + - [1, "4"] - in: - - [2, "4"] + - [2, "4"] out: - - [1, "8"] + - [1, "8"] - in: - - [2, "8"] + - [2, "8"] out: - - [1, "16"] + - [1, "16"] - in: - - [2, "16"] + - [2, "16"] out: - - [1, "32"] + - [1, "32"] - in: - - [2, "32"] + - [2, "32"] out: - - [1, "64"] + - [1, "64"] - in: - - [2, "64"] + - [2, "64"] out: - - [1, "128"] + - [1, "128"] - in: - - [2, "128"] + - [2, "128"] out: - - [1, "256"] + - [1, "256"] - in: - - [2, "256"] + - [2, "256"] out: - - [1, "512"] + - [1, "512"] - in: - - [2, "512"] + - [2, "512"] out: - - [1, "1024"] + - [1, "1024"] - in: - - [2, "1024"] + - [2, "1024"] out: - - [1, "2048"] + - [1, "2048"] robots: - name: base - dir: [1,0] + dir: east display: attr: robot char: "Ω" 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 @@ -3,14 +3,14 @@ author: Ondřej Šebek description: A maze shaped like a cave. It only goes down or forward. objectives: -- goal: - - You are at the top of a cave that gradually descends until reaching a dead end. - - At its bottom is a great treasure. - - Luckily, the cave does not branch out, so it is easy to find the path to the treasure. - - Send a robot to the the item marked as '**!**'. You win once the robot `grab`s it. - condition: | - j <- robotNamed "judge"; - as j {has "goal"} + - goal: + - You are at the top of a cave that gradually descends until reaching a dead end. + - At its bottom is a great treasure. + - Luckily, the cave does not branch out, so it is easy to find the path to the treasure. + - Send a robot to the the item marked as '**!**'. You win once the robot `grab`s it. + condition: | + j <- robotNamed "judge"; + as j {has "goal"} solution: | def until = \p. \c. b <- p; if b {} {c; until p c} end; def fwd = until blocked move end; @@ -21,7 +21,7 @@ } robots: - name: base - dir: [0,1] + dir: north display: char: 'Ω' attr: robot @@ -42,7 +42,7 @@ - [50, grabber] - [0, goal] - name: judge - dir: [0,0] + dir: [0, 0] system: true program: | def until = \c. b <- c; if b {} {until c} end; @@ -55,15 +55,15 @@ char: █ attr: rock description: - - An impassable stone wall. + - An impassable stone wall. properties: [unwalkable, known] - name: goal display: char: '!' attr: device description: - - The place you're trying to reach! You win by executing `grab` on this item. - properties: [known, portable] + - The place you're trying to reach! You win by executing `grab` on this item. + properties: [known, pickable] world: dsl: | {ice} @@ -73,7 +73,7 @@ '~': [stone, water] '█': [stone, wall] '!': [stone, goal, judge] - upperleft: [0,0] + upperleft: [0, 0] map: | ██████████████████████████████ █Ω ████████ █████████████████ 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 @@ -3,15 +3,14 @@ author: Ondřej Šebek description: A maze shaped like a spiral, with a twist! objectives: -- goal: - - You find yourself in the middle of a large maze. - - It's straightforward to get out, but the path is long and dull. - - You need to send a robot to the goal square, labelled with an exclamation mark; - you win by `grab`bing the `goal`{=entity}. - - Beware! The winding corridors are wider then they look! - condition: | - j <- robotNamed "judge"; - as j {has "goal"} + - goal: + - You find yourself in the middle of a large maze. + - It's straightforward to get out, but the path is long and dull. + - You need to send a robot to the goal square, labelled with an exclamation mark; you win by `grab`bing the `goal`{=entity}. + - Beware! The winding corridors are wider then they look! + condition: | + j <- robotNamed "judge"; + as j {has "goal"} solution: | def until = \p. \c. b <- p; if b {} {c; until p c} end; def fwd = until blocked move end; @@ -22,7 +21,7 @@ } robots: - name: base - dir: [0,1] + dir: north display: char: 'Ω' attr: robot @@ -43,7 +42,7 @@ - [50, grabber] - [0, goal] - name: judge - dir: [0,0] + dir: [0, 0] system: true program: | def until = \c. b <- c; if b {} {until c} end; @@ -55,15 +54,15 @@ char: █ attr: rock description: - - An impassable stone wall. + - An impassable stone wall. properties: [unwalkable, known] - name: goal display: char: '!' attr: device description: - - The place you're trying to reach! You win by executing `grab` on this item. - properties: [known, portable] + - The place you're trying to reach! You win by executing `grab` on this item. + properties: [known, pickable] world: dsl: | {ice} @@ -72,7 +71,7 @@ ' ': [stone, null] '█': [stone, wall] '!': [stone, goal, judge] - upperleft: [0,0] + upperleft: [0, 0] map: | ████████████████████████████████████ ██ ██ 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 @@ -1,22 +1,17 @@ version: 1 name: Invisible maze author: Brent Yorgey -description: There is a maze, but it can't be seen, only sensed... can you - program a robot to navigate it successfully? +description: There is a maze, but it can't be seen, only sensed... can you program a robot to navigate it successfully? objectives: -- goal: - - There is a maze, but it can't be seen, only sensed... can you - program a robot to navigate it successfully? You need to get a robot - to the goal square, labelled with an exclamation mark; you win by `grab`bing - the `goal`{=entity}. - - In this challenge, it is guaranteed that the maze is a tree, that is, - there are no loops within the maze. - condition: | - try { - teleport self (27, -17); - b <- ishere "goal"; - return (not b) - } { return false } + - goal: + - There is a maze, but it can't be seen, only sensed... can you program a robot to navigate it successfully? You need to get a robot to the goal square, labelled with an exclamation mark; you win by `grab`bing the `goal`{=entity}. + - In this challenge, it is guaranteed that the maze is a tree, that is, there are no loops within the maze. + condition: | + try { + teleport self (27, -17); + b <- ishere "goal"; + return (not b) + } { return false } solution: | def tL = turn left end; def tR = turn right end; @@ -29,7 +24,7 @@ } robots: - name: base - dir: [0,1] + dir: north display: char: 'Ω' attr: robot @@ -55,15 +50,15 @@ display: invisible: true description: - - An invisible wall. + - An invisible wall. properties: [unwalkable, known] - name: goal display: char: '!' attr: device description: - - The place you're trying to reach! You win by executing `grab` on this item. - properties: [known, portable] + - The place you're trying to reach! You win by executing `grab` on this item. + properties: [known, pickable] world: dsl: | {grass} @@ -73,7 +68,7 @@ 'x': [grass, wall] '@': [grass, boulder] '!': [grass, goal] - upperleft: [-1,1] + upperleft: [-1, 1] map: | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @Ω........x...x..............@ 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 @@ -1,27 +1,22 @@ version: 1 name: Invisible, loopy maze author: Brent Yorgey -description: There is a maze, but it can't be seen, only sensed... can you - program a robot to navigate it successfully? +description: There is a maze, but it can't be seen, only sensed... can you program a robot to navigate it successfully? objectives: -- goal: - - There is a maze, but it can't be seen, only sensed... can you - program a robot to navigate it successfully? You need to get a robot - to the goal square, labelled with an exclamation mark; you win by `grab`bing - the `goal`{=entity}. - - In this challenge, you are NOT guaranteed that the maze is a tree, that is, - the maze may contain loops. - condition: | - try { - teleport self (27, -17); - b <- ishere "goal"; - return (not b) - } { return false } + - goal: + - There is a maze, but it can't be seen, only sensed... can you program a robot to navigate it successfully? You need to get a robot to the goal square, labelled with an exclamation mark; you win by `grab`bing the `goal`{=entity}. + - In this challenge, you are NOT guaranteed that the maze is a tree, that is, the maze may contain loops. + condition: | + try { + teleport self (27, -17); + b <- ishere "goal"; + return (not b) + } { return false } solution: | run "scenarios/Challenges/Mazes/loopy_maze_sol.sw" robots: - name: base - dir: [0,1] + dir: north display: char: 'Ω' attr: robot @@ -48,15 +43,15 @@ display: invisible: true description: - - An invisible wall. + - An invisible wall. properties: [unwalkable, known] - name: goal display: char: '!' attr: device description: - - The place you're trying to reach! You win by executing `grab` on this item. - properties: [known, portable] + - The place you're trying to reach! You win by executing `grab` on this item. + properties: [known, pickable] world: dsl: | {grass} @@ -66,7 +61,7 @@ 'x': [grass, wall] '@': [grass, boulder] '!': [grass, goal] - upperleft: [-1,1] + upperleft: [-1, 1] map: | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @.........x...x..............@ 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 @@ -1,3 +1,5 @@ +beekeeping.yaml capture.yaml powerset.yaml +fishing.yaml gated-paddock.yaml diff --git a/data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw b/data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw @@ -0,0 +1,298 @@ +// Spawns worker bees when structures are detected + +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; +def mod : Int -> Int -> Int = \a. \b. a - (a/b)*b end; +def abs = \n. if (n < 0) {-n} {n} end; +def min = \x. \y. if (x < y) {x} {y} end; + +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 mapTuple = \f. \t. + (f $ fst t, f $ snd t) + end; + +def negateTuple = \t. + mapTuple (\x. -x) t; + end; + +def subtractTuple = \t1. \t2. + sumTuples t1 $ negateTuple t2; + end; + +// Deprecated +def moveTuple = \tup. + let x = fst tup in + let y = snd tup in + turn $ if (x > 0) {east} {west}; + doN (abs x) move; + + turn $ if (y > 0) {north} {south}; + doN (abs y) move; + end; + +def randomDir = + r <- random 4; + return $ if (r == 1) {north} + $ elif (r == 2) {west} + $ elif (r == 3) {south} + $ else {east}; + end; + +def moveHorizontal = \maxDirect. \dist. + turn $ if (dist > 0) {east} {west}; + doN (min maxDirect $ abs dist) move; + end; + +def moveVertical = \maxDirect. \dist. + turn $ if (dist > 0) {north} {south}; + doN (min maxDirect $ abs dist) move; + end; + +def randomStep = + randDir <- randomDir; + turn randDir; + move; + end; + +def moveToward = \maxDirect. \goal. + + currLocOrig <- whereami; + if (currLocOrig == goal) {} { + + // Include some random motion + randomStep; + + currLoc <- whereami; + let delta = subtractTuple goal currLoc in + let x = fst delta in + let y = snd delta in + + moveHorizontal maxDirect x; + moveVertical maxDirect y; + + moveToward maxDirect goal; + } + end; + +def watchForHoneycombRemoval = \dist. + if (dist > 0) { + move; + honeycombHere <- ishere "honeycomb"; + if honeycombHere { + watch down; + } {}; + + watchForHoneycombRemoval $ dist - 1; + } {}; + end; + +/** +Tries to find an open cell to deposit +the honeycomb. Gives up when distance +threshold exceeded. +*/ +def depositHoneycomb = \dist. + if (dist < 5) { + emptyHere <- isempty; + if emptyHere { + place "honeycomb"; + } { + move; + depositHoneycomb $ dist + 1; + }; + } { + turn back; + watchForHoneycombRemoval dist; + + // Hibernate + wait 2000; + + // Alternative method to get rid of honeycomb + make "buzz"; + }; + end; + +def goToHive = \hiveLoc. + let depositLoc = (fst hiveLoc - 1, snd hiveLoc) in + moveToward 2 depositLoc; + turn north; + depositHoneycomb 0; + end; + +/** +Harvests an item when reached +*/ +def takeStepTowardItem = \item. + // NOTE: Max radius is hard-coded to 256 + // (see maxSniffRange in Syntax.hs) + direction <- chirp item; + if (direction == down) { + // Need a try block in case + // another bee gets here first + try { + harvest; + return (); + } {}; + } { + // Include some random motion + r <- random 4; + if (r == 0) { + randomStep; + } { + turn direction; + move; + }; + + takeStepTowardItem item; + } + 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; + } + ); + } { + 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); + } + ); + end; + +def mkBeeName = \structureLoc. + "bee" ++ format structureLoc; + end; + +def workerProgramInit = \beename. \hiveIdx. \structureLoc. + setname beename; + appear "B" (inl ()); + workerProgram hiveIdx structureLoc; + end; + +def createWorkerForStructure = \structureIdx. \fs. + // Build worker bee, assign ID, location + create "wax gland"; + create "proboscis"; + + create "ADT calculator"; + create "beaglepuss"; + create "bitcoin"; + create "branch predictor"; + create "comparator"; + create "compass"; + create "detonator"; + create "dictionary"; + create "fast grabber"; + create "GPS receiver"; + create "harvester"; + create "hourglass"; + create "lambda"; + create "net"; + create "rolex"; + create "scanner"; + create "strange loop"; + create "solar panel"; + create "treads"; + create "workbench"; + + teleport self $ snd fs; + let beename = mkBeeName (snd fs) in + build { + require 1 "wax gland"; + workerProgramInit beename structureIdx $ snd fs; + }; + return (); + 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; + + // 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; + }; + + associateAllHives (remainingCount - 1) (idx + 1); + ); + } {} + end; + +/** +Each tick, iterates through all hives, +and makes sure a "bee" robot is associated with +their location. +If a structure exists without such an association, +creates a bee named after the location. +*/ +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; + ); + + // Wait at least 1 tick so that we do not spin infinitely until + // we saturate our computation quota for the tick. + wait 1; + observeHives; + end; + +def go = + instant $ observeHives; + end; + +go; diff --git a/data/scenarios/Challenges/Ranching/_beekeeping/solution.sw b/data/scenarios/Challenges/Ranching/_beekeeping/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/_beekeeping/solution.sw @@ -0,0 +1,362 @@ +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 abs = \n. if (n < 0) {-n} {n} end; + +def sumTuples = \t1. \t2. + (fst t1 + fst t2, snd t1 + snd t2); + end; + +def mapTuple = \f. \t. + (f $ fst t, f $ snd t) + end; + +def negateTuple = \t. + mapTuple (\x. -x) t; + end; + +def subtractTuple = \t1. \t2. + sumTuples t1 $ negateTuple t2; + end; + +def moveTuple = \tup. + let x = fst tup in + let y = snd tup in + turn $ if (x > 0) {east} {west}; + doN (abs x) move; + + turn $ if (y > 0) {north} {south}; + doN (abs y) move; + end; + +def nextRow = \d. + intersperse 2 move $ turn d; + end; + +def harvestTrees = + turn back; + doN 14 move; + turn left; + + intersperse 4 (nextRow left;) ( + intersperse 15 move harvest; + nextRow right; + intersperse 15 move harvest; + ); + end; + +def slatRow = + let item = "honey frame" in + intersperse 3 move $ place item; + end; + +def buildHive = + // Make 16 boards + doN 4 (make "log"; make "board"); + + // Make 9 honey frames + doN 3 $ make "log"; + doN 3 (make "board"; make "honey frame"); + + doN 4 (intersperse 4 move (place "board"); turn right; move;); + turn right; + move; + + slatRow; + nextRow left; + slatRow; + nextRow right; + slatRow; + end; + +def moveToNextHive = + doN 7 move; + end; + +/* Makes 8 staves */ +def makeStaveBatch = + // 1 per tree + make "log"; + + // 4 per log + make "board"; + + // 2 per board + doN 4 $ make "stave"; + end; + +def buildCasks = \caskCount. + // 40 staves + doN 5 makeStaveBatch; + doN 4 $ make "steel hoop"; + doN caskCount $ make "cask"; + end; + +/* +Moves forward until finding objective +item, stops when a gap is reached. +*/ +def collectContiguous = \maxdist. \item. \hadFound. \dist. + if (dist <= maxdist) { + honeycombHere <- ishere item; + if honeycombHere { + grab; + move; + collectContiguous maxdist item true $ dist + 1; + } { + if hadFound { + return dist; + } { + move; + collectContiguous maxdist item false $ dist + 1; + } + } + } { + return dist; + } + end; + +def collectHoneycomb = + distTravelled <- collectContiguous 10 "honeycomb" false 0; + turn back; + doN distTravelled move; + end; + +def collectAllHoneycombs = \targetCount. + + honeycombHere <- ishere "honeycomb"; + if honeycombHere {} { + watch down; + wait 2000; + }; + + intersperse 4 (turn left; doN 9 move; turn left;) collectHoneycomb; + + currentCount <- count "honeycomb"; + if (currentCount < targetCount) { + turn right; + doN 27 move; + turn right; + + collectAllHoneycombs targetCount; + } { + return currentCount; + }; + end; + +def moveUntilBlocked = + thing <- scan forward; + let isBlocked = case thing (\_. false) (\x. x == "lakewater") in + if isBlocked {} { + move; + moveUntilBlocked; + } + end; + +def getLakewater = \caskCount. + turn right; + doN 2 move; + turn left; + doN 5 move; + turn right; + moveUntilBlocked; + + doN caskCount $ use "siphon" forward; + end; + +def pickRock = + isRock <- ishere "rock"; + if isRock { + grab; + return (); + } {}; + end; + +def collectRocks = + doN 22 move; + turn right; + doN 59 move; + turn left; + + doN 7 ( + intersperse 15 move pickRock; + nextRow right; + intersperse 15 move pickRock; + nextRow left; + ); + end; + +def makeTables = + + doN 18 (make "log"; make "board";); + doN 36 $ make "table"; + + turn right; + move; + turn right; + doN 2 move; + doN 9 (swap "table"; move); + doN 8 move; + doN 9 (swap "table"; move); + turn left; + doN 2 move; + turn left; + move; + doN 9 (swap "table"; move); + doN 8 move; + doN 9 (swap "table"; move); + end; + +def buildTavern = + + // x16 per rock = + doN 12 $ make "stone tile"; + + doN 2 ( + intersperse 30 move $ place "stone tile"; + nextRow left; + intersperse 30 move $ place "stone tile"; + nextRow right; + ); + intersperse 30 move $ place "stone tile"; + + makeTables; + + // hearth + nextRow right; + doN 12 move; + intersperse 4 move (make "hearth"; swap "hearth"); + turn right; + doN 6 move; + turn right; + intersperse 4 move (make "archway"; place "archway"); + nextRow right; + intersperse 4 move (make "archway"; place "archway"); + move; + + // Make enough logs for 70 wall pieces + doN 35 (make "log"; make "wall"); + + intersperse 14 move (place "wall"); + turn left; + doN 6 (move; place "wall"); + turn left; + doN 31 (move; place "wall";); + turn left; + doN 6 (move; place "wall"); + turn left; + doN 13 (move; place "wall"); + end; + +def combCollectionLoop = \targetCount. + + currentCount <- count "honeycomb"; + if (currentCount < targetCount) { + watch down; + wait 2000; + collectHoneycomb; + turn back; + combCollectionLoop targetCount; + } {} + end; + +def buildRobot = \targetCount. \meetingLoc. + + // Unpack the "botkit" + make "solar panel"; + + build { + require 8 "tree"; + buildHive; + + // Move to northwest corner + turn back; + doN 3 move; + turn left; + doN 4 move; + turn left; + + combCollectionLoop targetCount; + + currLoc <- whereami; + let delta = subtractTuple meetingLoc currLoc in + moveTuple delta; + + // Assume that the base has already arrived + // at the rendezvous point + honeycombCount <- count "honeycomb"; + doN honeycombCount $ give parent "honeycomb"; + }; + end; + +def placeHives = \targetCount. \meetingLoc. + buildRobot targetCount meetingLoc; + doN 38 move; + buildRobot targetCount meetingLoc; + doN 56 move; + turn right; + doN 15 move; + turn left; + buildRobot targetCount meetingLoc; + doN 2 move; + turn right; + doN 26 move; + turn left; + buildRobot targetCount meetingLoc; + end; + +def acceptHoneyDeliveries = + currentCount <- count "honeycomb"; + if (currentCount < 60) { + wait 32; + acceptHoneyDeliveries; + } { + // Use the "honey extractor" + doN currentCount $ make "honey"; + } + end; + +def go = + harvestTrees; + turn east; + doN 19 move; + + let meetingLoc = (0, -12) in + placeHives 15 meetingLoc; + + turn right; + + buildCasks 2; + getLakewater 2; + + turn right; + + collectRocks; + + doN 7 move; + turn left; + doN 80 move; + buildTavern; + + nextRow right; + + currLoc <- whereami; + let delta = subtractTuple meetingLoc currLoc in + moveTuple delta; + + acceptHoneyDeliveries; + doN 4 salvage; + + doN 2 $ make "mead"; + + end; + +go; 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 @@ -39,12 +39,9 @@ def countBlocked = \n. if (n > 0) { isBlocked <- blocked; - // This assignment has to happen before the recursive - // "countBlocked" call due to #1032 - let localBlockCount = boolToInt isBlocked in turn left; lastCount <- countBlocked $ n - 1; - return $ lastCount + localBlockCount; + return $ lastCount + boolToInt isBlocked; } { return 0; } diff --git a/data/scenarios/Challenges/Ranching/_fishing/hauler.sw b/data/scenarios/Challenges/Ranching/_fishing/hauler.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/_fishing/hauler.sw @@ -0,0 +1,90 @@ +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 isEnclosureFull = \idx. + foundBox <- structure "rubbish enclosure" idx; + case foundBox (\_. return false) (\enclosure. + let boxPos = snd enclosure in + + prevLoc <- whereami; + + dims <- floorplan "rubbish enclosure"; + teleport self boxPos; + + c <- density ((0, 0), dims); + let area = fst dims * snd dims in + let notFull = c < area in + + teleport self prevLoc; + return $ not notFull; + ); + end; + +def isEitherEnclosureFull = + full1 <- isEnclosureFull 0; + full2 <- isEnclosureFull 1; + return $ full1 || full2; + end; + +def tryGrab = + try { + grab; + return () + } {}; + end; + + +def turnAround = \d. + intersperse 2 move $ turn d; + end; + +def waitUntilEnclosureFull = + + isFull <- instant isEitherEnclosureFull; + if isFull { + // Drive down the road + turn south; + doN 13 move; + turn right; + doN 3 move; + turn right; + doN 2 move; + turn left; + + // North enclosure + intersperse 2 (turnAround left) $ intersperse 3 move tryGrab; + + intersperse 2 (doN 3 move) $ turn right; + + // South enclosure + intersperse 2 (turnAround right) $ intersperse 3 move tryGrab; + + turn left; + move; + + // Leave again + turn right; + doN 3 move; + turn left; + doN 13 move; + turn back; + } { + wait 10; + waitUntilEnclosureFull; + } + end; + +def go = + waitUntilEnclosureFull; + go; + end; + +go; diff --git a/data/scenarios/Challenges/Ranching/_fishing/shark.sw b/data/scenarios/Challenges/Ranching/_fishing/shark.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/_fishing/shark.sw @@ -0,0 +1,24 @@ +/** +Swims back and forth forever. +*/ + +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def swim = + appear "^" (inl ()); + doN 3 (move; wait 3); + turn back; + wait 15; + doN 3 (move; wait 3); + turn back; + appear " " (inl ()); + end; + +def go = + waitR <- random 100; + wait $ 50 + waitR; + swim; + go; + end; + +go; diff --git a/data/scenarios/Challenges/Ranching/_fishing/solution.sw b/data/scenarios/Challenges/Ranching/_fishing/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/_fishing/solution.sw @@ -0,0 +1,195 @@ +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 makeRoll = + make "nori"; + make "california roll"; + end; + +def checkIngredients = + hasTuna <- has "crab"; + hasSeaweed <- has "seaweed"; + return $ hasTuna && hasSeaweed; + end; + +def catchFish = \rod. + use rod forward; + ready <- checkIngredients; + if ready { + makeRoll; + } { + catchFish rod; + }; + end; + +def turnAround = \d. + intersperse 2 move $ turn d; + end; + +/* +Precondition: +At the top-right corner +*/ +def harvestRectangle = + intersperse 4 move $ harvest; return (); + turnAround left; + intersperse 4 move $ harvest; return (); + end; + +def harvestIngredients = + turn north; + doN 2 move; + turn left; + doN 3 move; + + intersperse 3 (turn right; doN 2 move; turn right;) harvestRectangle; + wait 400; + turn left; + doN 7 move; + turn left; + intersperse 3 (turn right; doN 2 move; turn right;) harvestRectangle; + + doN 6 move; + turn left; + move; + end; + +def getJunkItem = \idx. + result <- tagmembers "junk" idx; + let totalCount = fst result in + let member = snd result in + let nextIdx = idx + 1 in + + hasProhibited <- has member; + if hasProhibited { + return $ inr member; + } { + if (nextIdx < totalCount) { + getJunkItem nextIdx; + } { + return $ inl (); + } + } + end; + +def tryPlace = \item. + try { + place item; + } {}; + end; + +/** +Precondition: facing north in lower-left corner of enclosure + +Navigates a serpentine pattern through the space to +place items. +*/ +def placeSerpentine = \placeFunc. + placeFunc; + + move; + placeFunc; + + turn right; + + move; + placeFunc; + + turn right; + + move; + placeFunc; + + turn left; + + move; + placeFunc; + + turn left; + + move; + placeFunc; + + end; + +def returnToCorner = + turn back; + move; move; + turn right; + move; move; + turn right; + end; + +def unloadTrash = + try { + placeSerpentine ( + item <- getJunkItem 0; + case item (\_. fail "done") (\item. place item); + ); + watch down; + wait 1000; + + // Go back to corner + turn back; + move; + turn right; + move; move; + turn right; + + wait 50; + unloadTrash; + } {}; + end; + +def burnTires = + hasCarTire <- has "car tire"; + if hasCarTire { + + intersperse 2 move $ ( + placeSerpentine $ tryPlace "car tire"; + returnToCorner; + ignite forward; + + turn right; + move; move; + turn right; + ); + + wait 60; + move; + + burnTires; + } {} + end; + +def disposeTrash = + turn back; + doN 5 move; + turn left; + doN 11 move; + turn left; + move; + + burnTires; + + unloadTrash; + end; + +def go = + harvestIngredients; + let rod = "fishing tackle" in + make rod; + equip rod; + doN 16 $ catchFish rod; + disposeTrash; + end; + +go; 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 @@ -202,7 +202,7 @@ turn back; - let forever : cmd unit -> cmd unit = \c. c ; forever c in + let forever : Cmd Unit -> Cmd Unit = \c. c ; forever c in forever sweepAreaForWool; 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 @@ -36,7 +36,7 @@ def decideDirection = - let randdir : cmd dir = + let randdir : Cmd Dir = d <- random 4; return $ if (d == 0) { north @@ -62,8 +62,8 @@ } end; -let forever : cmd unit -> cmd unit = \c. c ; forever c in -let repeat : int -> cmd unit -> cmd unit = +let forever : Cmd Unit -> Cmd Unit = \c. c ; forever c in +let repeat : Int -> Cmd Unit -> Cmd Unit = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} in 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 @@ -2,7 +2,7 @@ def else = \t. t end // modulus function (%) -def mod : int -> int -> int = \i. \m. +def mod : Int -> Int -> Int = \i. \m. i - m * (i / m) end @@ -138,13 +138,9 @@ def naiveRandomStack = \valueFunc. \maxval. \bitmask. \n. val <- if (n > 1) { nextRandomVal <- getUnusedRandom maxval bitmask; - - // Recursion bug workaround (see #1032): - let blahNextRandomVal = nextRandomVal in - let newBitmask = bitmask + shiftLeft 1 nextRandomVal in naiveRandomStack valueFunc maxval newBitmask $ n - 1; - return blahNextRandomVal; + return nextRandomVal; } { // We're at the peak of the stack. // Now we unwind it. @@ -218,7 +214,7 @@ /** One-based ordinal of the item. */ -def getOrdinal : text -> cmd int = \item. +def getOrdinal : Text -> Cmd Int = \item. count item; end; diff --git a/data/scenarios/Challenges/Ranching/beekeeping.yaml b/data/scenarios/Challenges/Ranching/beekeeping.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/beekeeping.yaml @@ -0,0 +1,452 @@ +version: 1 +name: Beekeeping +author: Karl Ostmo +description: | + Bootstrap an organic *bee*verage industry. +creative: false +seed: 2 +attrs: + - name: bee + fg: '#ffff00' + bg: '#000000' + - name: water_cask + fg: '#4488ff' + bg: '#8B4513' + - name: mybase + fg: '#e0c0e0' + - name: iceblue + fg: '#ddddff' +objectives: + - teaser: Apiarist + goal: + - | + Build a `beehive`{=structure}. + - | + This will attract bees, which will gather + `nectar`{=entity} from nearby `wildflower`{=entity}s. + - | + Do not crowd hives; provide at least one cell margin + between them. + - | + Given that `wildflower`{=entity}s cannot be relocated, + judicious placement is essential for efficient + `honeycomb`{=entity} production. + condition: | + foundStructure <- structure "beehive" 0; + return $ case foundStructure (\_. false) (\_. true); + - teaser: Collect honeycomb + goal: + - | + Collect `honeycomb`{=entity} from the `beehive`{=structure}s. + - | + After gathering a certain amount of nectar, a bee will return + to its hive and place honeycomb alongside it. + A finite amount of honeycomb may be accumulated before the + bee becomes dormant. + condition: | + as base { + has "honeycomb" + } + - teaser: Cooper + goal: + - | + Make a `cask`{=entity}. + - | + Use local timber and your on-hand supply of iron material. + - | + You may `use "siphon" forward` when positioned in front of + a lake to fill a `cask`{=entity} with `lakewater`{=entity}. + condition: | + as base { + has "cask" + } + - teaser: Brewmeister + goal: + - | + Ferment 2 barrels of `mead`{=entity}. + condition: | + as base { + meadCount <- count "mead"; + return $ meadCount >= 2; + } + - teaser: Tavern keeper + optional: true + goal: + - | + Construct a `mead hall`{=structure}. + condition: | + foundStructure <- structure "mead hall" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + display: + attr: mybase + dir: east + devices: + - 3D printer + - blueprint + - branch predictor + - ADT calculator + - clock + - comparator + - compass + - counter + - dictionary + - fast grabber + - GPS receiver + - harvester + - hearing aid + - honey extractor + - keyboard + - lambda + - logger + - net + - rolex + - scanner + - siphon + - strange loop + - toolkit + - treads + - welder + - workbench + inventory: + - [20, iron plate] + - [4, botkit] + - name: queenbee + dir: east + system: true + display: + invisible: true + char: 'Q' + attr: bee + program: | + run "scenarios/Challenges/Ranching/_beekeeping/queenbee.sw" +solution: | + run "scenarios/Challenges/Ranching/_beekeeping/solution.sw" +structures: + - name: beehive + recognize: [north] + structure: + palette: + '-': [dirt, honey frame] + 'b': [dirt, board] + map: | + bbbbb + b---b + b---b + b---b + bbbbb + - name: mead hall + recognize: [north] + structure: + palette: + 'w': [dirt, wall] + 't': [dirt, table] + 'h': [dirt, hearth] + 'a': [dirt, archway] + '.': [stone, stone tile] + mask: 'x' + map: | + wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww + w.............hhhh.............w + w..ttttttttt........ttttttttt..w + w..............................w + w..ttttttttt........ttttttttt..w + w..............................w + wwwwwwwwwwwwwwaaaawwwwwwwwwwwwww + xxxxxxxxxxxxxxaaaaxxxxxxxxxxxxxx +entities: + - name: wildflower + display: + attr: flower + char: '*' + description: + - A delicate flower that grows wild in local meadows. Produces `nectar`{=entity} when `harvest`ed. + properties: [known, growable] + yields: nectar + growth: [80, 120] + - name: botkit + display: + attr: device + char: 'k' + description: + - All the essentials to equip your own "worker bee" + properties: [known, pickable] + - name: reed + display: + attr: plant + char: 'r' + description: + - Reeds, grow near water + properties: [known, pickable, growable] + - name: honeycomb + display: + char: 'x' + attr: gold + description: + - Product of bees that have consumed nectar + properties: [known, pickable] + - name: proboscis + display: + char: 'p' + attr: device + description: + - Senses direction to nectar-producing flowers + properties: [known, pickable] + capabilities: [detectdirection, structure] + - name: honey + display: + char: 'h' + attr: gold + description: + - Pure liquid honey + properties: [known, pickable] + - name: mead + display: + char: 'm' + description: + - Honey-based alcoholic beverage + properties: [known, pickable] + - name: honey extractor + display: + char: 'e' + attr: device + description: + - Device for extracting honey from the comb + properties: [known, pickable] + - name: buzz + display: + char: 'z' + description: + - Result of discarding surplus honeycomb + properties: [known, pickable] + - name: wax gland + display: + char: 'g' + description: + - Required to make honeycomb + properties: [known] + - name: nectar + display: + char: 'n' + attr: gold + description: + - Obtained from wildflowers + properties: [known, pickable] + - name: honey frame + display: + char: '-' + attr: iceblue + description: + - Internal component of a beehive + properties: [known, pickable] + - name: stave + display: + char: 'l' + attr: wood + description: + - Wooden plank comprising the sides of a cask + properties: [known, pickable] + - name: cask + display: + char: 'c' + attr: wood + description: + - Wooden barrel for liquids + properties: [known, pickable] + - name: water cask + display: + char: 'c' + attr: water_cask + description: + - Water-filled cask + properties: [known, pickable] + - name: lakewater + display: + attr: water + char: ' ' + description: + - Potable water from a lake + properties: [known, infinite, liquid] + - name: siphon + display: + char: 's' + attr: device + description: + - Used to fill a cask with water + properties: [known, pickable] + - name: steel hoop + display: + char: 'o' + attr: iron + description: + - Binds staves into a cask + properties: [known, pickable] + - name: wall + display: + char: 'w' + attr: wood + description: + - Outer walls of the building + properties: [known, unwalkable] + - name: table + display: + char: 't' + attr: wood + description: + - A segment of banquet table + properties: [known, pickable] + - name: hearth + display: + char: 'h' + attr: rock + description: + - Encloses a fire to warm the hall + properties: [known, unwalkable] + - name: archway + display: + char: 'a' + attr: rock + description: + - Grand entrance + properties: [known, pickable] + - name: stone tile + display: + char: '.' + attr: rock + description: + - Refined flooring + properties: [known, pickable] +recipes: + - in: + - [1, botkit] + out: + - [1, branch predictor] + - [1, ADT calculator] + - [1, blueprint] + - [1, clock] + - [1, comparator] + - [1, compass] + - [1, counter] + - [1, dictionary] + - [1, grabber] + - [1, GPS receiver] + - [1, harvester] + - [1, lambda] + - [1, logger] + - [1, net] + - [1, rolex] + - [1, scanner] + - [1, solar panel] + - [1, strange loop] + - [1, treads] + - [1, welder] + - [1, workbench] + - in: + - [1, board] + out: + - [3, honey frame] + - in: + - [1, rock] + out: + - [16, stone tile] + - in: + - [2, rock] + out: + - [1, hearth] + - in: + - [4, rock] + out: + - [1, archway] + - in: + - [2, board] + out: + - [1, table] + - in: + - [1, rock] + - [1, log] + out: + - [2, wall] + - in: + - [1, board] + out: + - [2, stave] + - in: + - [2, iron plate] + out: + - [1, steel hoop] + - in: + - [20, stave] + - [2, steel hoop] + out: + - [1, cask] + - in: + - [1, cask] + - [1, lakewater] + out: + - [1, water cask] + - [1, lakewater] + required: + - [1, siphon] + - in: + - [16, nectar] + out: + - [1, honeycomb] + required: + - [1, wax gland] + - in: + - [1, water cask] + - [30, honey] + out: + - [1, mead] + - in: + - [1, honeycomb] + out: + - [1, honey] + required: + - [1, honey extractor] + - in: + - [1, honeycomb] + out: + - [1, buzz] + required: + - [1, wax gland] +known: [tree, rock, board] +world: + dsl: | + let + flowerNoise = perlin seed 1 0.15 0.0, + stoneNoise = perlin (seed + 1) 1 0.05 0.0, + lakeNoise = perlin seed 1 0.02 0.0, + forestNoise = perlin seed 2 0.04 1.0, + + flowers = flowerNoise > 0.65, + rubble = stoneNoise > 0.8, + rock = stoneNoise > 0.9, + outerShore = -0.55 <= lakeNoise && lakeNoise < -0.5, + innerShore = lakeNoise < -0.55, + lakes = lakeNoise < -0.6, + trees = forestNoise > 0.8 + in + overlay + [ {grass} + , mask (flowers && (x - y) % 3 == 0) {wildflower} + , mask (rubble && (x + y) % 2 == 0) {rock} + , mask rock {rock} + , mask trees {tree} + , mask (outerShore && (x + y) % 2 == 0) {reed} + , mask innerShore {reed} + , mask lakes {lakewater} + ] + upperleft: [0, 0] + offset: false + palette: + 'B': [grass, erase, base] + 'Q': [grass, erase, queenbee] + '.': [grass, erase] + map: | + Q.... + ..... + ..B.. + ..... + ..... 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 @@ -72,7 +72,7 @@ }; robots: - name: base - dir: [1, 0] + dir: east devices: - 3D printer - branch predictor @@ -114,7 +114,7 @@ - [6, welder] - name: opponent system: true - dir: [0, 1] + dir: north display: char: P attr: pig @@ -122,21 +122,21 @@ program: | run "scenarios/Challenges/Ranching/_capture/opponent.sw" solution: | - run "scenarios/Challenges/Ranching/_capture/solution.sw" + run "scenarios/Challenges/Ranching/_capture/solution.sw" entities: - name: monolith display: char: '@' description: - - Pushable rock - properties: [known, unwalkable, portable] + - Pushable rock + properties: [known, unwalkable, pickable] capabilities: [push] - name: bacon display: attr: bacon char: 'Z' description: - - Odiferous constitution of pig + - Odiferous constitution of pig properties: [known] known: [flower, tree] world: @@ -160,4 +160,3 @@ ................ .B..*......@.... ................ - diff --git a/data/scenarios/Challenges/Ranching/fishing.yaml b/data/scenarios/Challenges/Ranching/fishing.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Ranching/fishing.yaml @@ -0,0 +1,544 @@ +version: 1 +name: Responsible Fishing +author: Karl Ostmo +description: | + Catch the appropriate seafood to make lunch. + + If you haul any trash out of the lake, you + must throw it away in the enclosures to the southeast. + No littering! +creative: false +seed: 0 +attrs: + - name: shark + bg: "#2040bb" +objectives: + - teaser: Hot rod + goal: + - | + `equip` your `fishing tackle`{=entity}, i.e. a rod and its accoutrements. + condition: | + as base { + equipped "fishing tackle"; + } + - teaser: Sushi chain + id: lots_of_sushi + goal: + - | + Make 16 `california roll`{=entity}s + condition: | + as base { + rollCount <- count "california roll"; + return $ rollCount >= 16; + } + prerequisite: made_sushi + - teaser: Sushi chef + id: made_sushi + goal: + - | + Make a `california roll`{=entity} + condition: | + as base { + has "california roll" + } + - teaser: Waste disposal + prerequisite: + logic: + and: + - lots_of_sushi + - not: littered + goal: + - | + Inventory must be free of all `junk`{=tag}. + - | + Dispose of `junk`{=tag} only in designated `rubbish enclosure`{=structure}s. + - | + Certain items can be burned to make room. + Good thing you brought your `torch`{=entity}! + - | + 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; + + checkProhibited 0; + - teaser: No littering + id: littered + hidden: true + optional: true + goal: + - | + You may dispose of `junk`{=tag} only in either of the designated `rubbish enclosure`{=structure}s. + - | + 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; + ); + end; + + def junkOutsideEnclosure = + result <- scan down; + case result (\_. return false) (\item. + isJunk <- hastag item "junk"; + if isJunk { + foundBox <- structure "rubbish enclosure" 0; + + case foundBox (\_. return false) (\enclosure. + + dims <- floorplan "rubbish enclosure"; + loc <- whereami; + + insideFirst <- locIsInsideEnclosure loc dims 0; + insideSecond <- locIsInsideEnclosure loc dims 1; + return $ not $ insideFirst || insideSecond; + ); + } { + return false; + }; + ); + end; + + // If a junk entity was placed on the ground, + // it will be in the same cell as the base robot. + as base { + junkOutsideEnclosure; + } +robots: + - name: base + dir: [1, 0] + devices: + - branch predictor + - ADT calculator + - hourglass + - comparator + - compass + - dictionary + - grabber + - harvester + - keyboard + - lambda + - logger + - net + - pawn star + - rolex + - scanner + - strange loop + - torch + - treads + - welder + - workbench + inventory: + - [1, branch] + - [1, string] + - [1, fish hook] + - [1, lead weight] + - name: hauler + dir: [1, 0] + system: true + display: + char: W + invisible: false + program: | + run "scenarios/Challenges/Ranching/_fishing/hauler.sw" + - name: shark + dir: [1, 0] + system: true + display: + char: ' ' + attr: shark + invisible: false + program: | + run "scenarios/Challenges/Ranching/_fishing/shark.sw" +solution: | + run "scenarios/Challenges/Ranching/_fishing/solution.sw" +structures: + - name: rubbish enclosure + recognize: [north, south] + structure: + palette: + 'j': [grass, concrete wall] + '.': [stone, null] + map: | + jjjjj + j...j + j...j +entities: + - name: concrete wall + display: + attr: rock + char: '-' + description: + - Enclosure for rubbish + properties: [known, unwalkable] + - name: lakewater + display: + attr: water + char: ' ' + description: + - Potable water from a lake + properties: [known, infinite, liquid] + - name: pawn star + display: + attr: gold + char: '*' + description: + - | + Can tell you if something is `junk`{=tag} + via the `hastag` command. E.g.: + - | + `hastag "car tire" "junk"` + - | + Also allows you to iterate over the list of junk, e.g.: + - | + `tagmembers "junk" 0` + capabilities: [hastag, tagmembers] + - name: torch + display: + attr: wood + char: 't' + description: + - Can set things on fire + properties: [known, pickable] + capabilities: [ignite] + - name: fishing tackle + display: + char: 'r' + attr: wood + description: + - A fishing rod equipped with hook, line and sinker. + - Use on `water`{=entity} to catch fish + properties: [known, pickable] + - name: lead weight + display: + char: 'w' + attr: device + description: + - Used as a fishing sinker + properties: [known, pickable] + - name: fish hook + display: + char: 'j' + attr: device + description: + - Use to catch fish + properties: [known, pickable] + - name: california roll + display: + char: 'c' + description: + - Delicious + properties: [known, pickable] + - name: rice + display: + char: 'i' + attr: plant + description: + - Perfect for sushi + properties: [known, pickable, growable] + - name: avocado + display: + char: 'A' + attr: plant + description: + - Perfect for sushi + properties: [known, pickable, growable] + - name: cucumber + display: + char: 'u' + attr: plant + description: + - Perfect for sushi + properties: [known, pickable, growable] + - name: tuna + display: + char: 't' + description: + - Edible fish + properties: [known, pickable] + - name: crab + display: + char: 'c' + description: + - Perfect for sushi + properties: [known, pickable] + - name: pufferfish + display: + char: 'p' + description: + - Poisonous + properties: [known, pickable] + - name: trout + display: + char: 't' + description: + - Good to eat + properties: [known, pickable] + - name: salmon + display: + char: 't' + description: + - Good to eat + properties: [known, pickable] + - name: oarfish + display: + char: 'r' + description: + - Too long + properties: [known, pickable] + - name: narwhal + display: + char: 'n' + description: + - Too big + properties: [known, pickable] + - name: marlin + display: + char: 'm' + description: + - Pointy + properties: [known, pickable] + - name: seaweed + display: + char: 'w' + description: + - Inedible...? + properties: [known, pickable] + - name: nori + display: + char: 'n' + description: + - Dried seaweed wrap for sushi rolls + properties: [known, pickable] + - name: car tire + display: + char: 'o' + description: + - Rubber waste. Flammable. + tags: [junk] + properties: [known, pickable, combustible] + combustion: + ignition: 0.5 + duration: [40, 80] + product: null + - name: kitchen sink + display: + char: 'i' + description: + - Everything but! + tags: [junk] + properties: [known, pickable] + - name: boot + display: + char: 'b' + description: + - A soggy, worn-out boot. + tags: [junk] + properties: [known, pickable] + - name: rusty bicycle + display: + char: '8' + description: + - Its riding days are over. + tags: [junk, metal] + properties: [known, pickable] +recipes: + - in: + - [1, lakewater] + out: + - [1, rusty bicycle] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, car tire] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 6 + - in: + - [1, lakewater] + out: + - [1, boot] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, kitchen sink] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, seaweed] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, tuna] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, salmon] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, narwhal] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, oarfish] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, trout] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, marlin] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, pufferfish] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, lakewater] + out: + - [1, crab] + - [1, lakewater] + required: + - [1, fishing tackle] + time: 10 + weight: 1 + - in: + - [1, seaweed] + out: + - [1, nori] + - in: + - [1, crab] + - [1, rice] + - [1, nori] + - [1, cucumber] + - [1, avocado] + out: + - [1, california roll] + - in: + - [1, branch] + - [1, fish hook] + - [1, string] + - [1, lead weight] + out: + - [1, fishing tackle] +known: [] +world: + 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] + 'w': [grass, lakewater] + 's': [grass, lakewater, shark] + 'A': [grass, avocado] + 'i': [grass, rice] + 'c': [grass, cucumber] + 'r': [dirt, erase] + 'h': [dirt, erase, hauler] + map: | + .........................h. + .........................r. + AAAA.....................r. + AAAA.......wwwwww........r. + ......B...wwwwwwww.......r. + iiii......wwswwwww.......r. + iiii.....wwwwwwwww.......r. + .........wwwwwwww........r. + cccc.......wwww..........r. + cccc.....................r. + .........................r. + .........................r. + .........................r. + ....................rrrrrr. + ........................... + ........................... + ........................... 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 @@ -191,7 +191,7 @@ prerequisite: feed_sheep robots: - name: base - dir: [0, 1] + dir: north devices: - treads - scanner @@ -221,11 +221,12 @@ invisible: false char: '@' system: true - dir: [0, 1] + dir: north inventory: - [4, wool] - unwalkable: - - gate + walkable: + never: + - gate program: | run "scenarios/Challenges/Ranching/_gated-paddock/meandering-sheep.sw"; entities: @@ -234,7 +235,7 @@ char: '#' description: - Keeps sheep in. And some other things out. - properties: [known, portable, unwalkable] + properties: [known, pickable, unwalkable] - name: post puller display: char: 'P' @@ -242,27 +243,27 @@ capabilities: [drill] description: - Good for dismantling fences. - properties: [known, portable] + properties: [known, pickable] - name: scrap wood display: char: '\' description: - Scrap wood. Can be reconditioned into boards. - properties: [known, portable] + properties: [known, pickable] - name: sweater display: attr: gold char: 'S' description: - A warm wool sweater. Just in time for winter! - properties: [known, portable] + properties: [known, pickable] - name: clover display: attr: flower char: '%' description: - A tasty stack for fluffy ruminants. - properties: [portable, growable] + properties: [pickable, growable] growth: [80, 100] - name: gate display: @@ -277,7 +278,7 @@ attr: rock description: - Facilitates swinging action. - properties: [known, portable] + properties: [known, pickable] - name: cabin display: char: Π @@ -287,7 +288,7 @@ properties: [known, unwalkable] - name: pier display: - char: 且 + char: H attr: rock description: - Docking area for ships @@ -297,19 +298,19 @@ char: '.' description: - A marker that can be put down and found again. Used only by judge robot. - properties: [portable] + properties: [pickable] - name: treaded breadcrumb display: char: 'x' description: - A marker that can be put down and found again (for a second time). Used only by judge robot. - properties: [portable] + properties: [pickable] - name: evaporator display: char: 'E' description: - A tool that allows clearing a water tile. Used only by judge robot. - properties: [portable] + properties: [pickable] capabilities: [drill] - name: wool display: @@ -317,13 +318,13 @@ attr: gold description: - A bundle of raw animal fiber. - properties: [portable] + properties: [pickable] - name: steam display: char: 'Z' description: - What's left after evaporating water. Used only by judge robot. - properties: [portable] + properties: [pickable] recipes: - in: - [2, board] 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 @@ -35,7 +35,7 @@ After you have done this, `place` the `bell`{=entity} anywhere, and then Bill will inspect your work. prerequisite: - not: wrong_anwser + not: wrong_anwser condition: | r <- robotnamed "setup"; as r {has "bit (1)"}; @@ -50,7 +50,7 @@ as r {has "bit (0)"}; robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor @@ -75,7 +75,7 @@ - treads - name: setup system: true - dir: [1, 0] + dir: east display: invisible: true inventory: @@ -90,15 +90,15 @@ program: | run "scenarios/Challenges/Ranching/_powerset/setup.sw" solution: | - run "scenarios/Challenges/Ranching/_powerset/solution.sw" + run "scenarios/Challenges/Ranching/_powerset/solution.sw" entities: - name: rocket skates display: attr: silver char: 's' description: - - Allows one to `stride` across multiple cells - properties: [known, portable] + - Allows one to `stride` across multiple cells + properties: [known, pickable] capabilities: [movemultiple] - name: bell display: @@ -106,7 +106,7 @@ attr: gold description: - A bell for Bill - properties: [known, portable] + properties: [known, pickable] - name: fruit picker display: char: 'P' @@ -127,7 +127,7 @@ attr: fruit0 description: - Dragonfruits - properties: [known, growable, portable] + properties: [known, growable, pickable] growth: [10, 10] - name: grape display: @@ -136,7 +136,7 @@ description: - Grapes growth: [10, 10] - properties: [known, growable, portable] + properties: [known, growable, pickable] - name: lemon display: char: 'Y' @@ -144,7 +144,7 @@ description: - Lemons growth: [10, 10] - properties: [known, growable, portable] + properties: [known, growable, pickable] - name: apple display: char: 'Y' @@ -152,7 +152,7 @@ description: - Apple growth: [10, 10] - properties: [known, growable, portable] + properties: [known, growable, pickable] - name: blueberry display: char: 'Y' @@ -160,7 +160,7 @@ description: - Blueberries growth: [10, 10] - properties: [known, growable, portable] + properties: [known, growable, pickable] - name: watermelon display: char: 'Y' @@ -168,7 +168,7 @@ description: - Watermelons growth: [10, 10] - properties: [known, growable, portable] + properties: [known, growable, pickable] - name: orange display: char: 'Y' @@ -176,7 +176,7 @@ description: - Oranges growth: [10, 10] - properties: [known, growable, portable] + properties: [known, growable, pickable] known: [sand] world: dsl: | @@ -184,7 +184,6 @@ upperleft: [-1, -1] offset: false palette: - '.': [grass] 'B': [grass, null, base] 'S': [grass, null, setup] map: | 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 @@ -31,7 +31,7 @@ as j {run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw"}; robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor @@ -84,7 +84,7 @@ - [25, y-tile-ordinal] - name: maintainer system: true - dir: [1, 0] + dir: east display: invisible: true attr: 'gold' @@ -118,7 +118,7 @@ run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw"; - name: setup system: true - dir: [1, 0] + dir: east display: invisible: true attr: 'iron' @@ -151,7 +151,7 @@ program: | run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw"; solution: | - run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw" + run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw" entities: - name: gradiator display: @@ -184,8 +184,8 @@ attr: silver char: '/' description: - - Facilitates pushing - properties: [known, portable] + - Facilitates pushing + properties: [known, pickable] capabilities: [push] - name: sliding-tile display: @@ -199,175 +199,175 @@ attr: oddtile description: - One - properties: [known, portable] + properties: [known, pickable] - name: b-tile display: char: 'b' attr: eventile description: - Two - properties: [known, portable] + properties: [known, pickable] - name: c-tile display: char: 'c' attr: oddtile description: - Three - properties: [known, portable] + properties: [known, pickable] - name: d-tile display: char: 'd' attr: eventile description: - Four - properties: [known, portable] + properties: [known, pickable] - name: e-tile display: char: 'e' attr: oddtile description: - Five - properties: [known, portable] + properties: [known, pickable] - name: f-tile display: char: 'f' attr: eventile description: - Six - properties: [known, portable] + properties: [known, pickable] - name: g-tile display: char: 'g' attr: oddtile description: - Seven - properties: [known, portable] + properties: [known, pickable] - name: h-tile display: char: 'h' attr: eventile description: - Eight - properties: [known, portable] + properties: [known, pickable] - name: i-tile display: char: 'i' attr: oddtile description: - Nine - properties: [known, portable] + properties: [known, pickable] - name: j-tile display: char: 'j' attr: eventile description: - Ten - properties: [known, portable] + properties: [known, pickable] - name: k-tile display: char: 'k' attr: oddtile description: - Eleven - properties: [known, portable] + properties: [known, pickable] - name: l-tile display: char: 'l' attr: eventile description: - Twelve - properties: [known, portable] + properties: [known, pickable] - name: m-tile display: char: 'm' attr: oddtile description: - Thirteen - properties: [known, portable] + properties: [known, pickable] - name: n-tile display: char: 'n' attr: eventile description: - Fourteen - properties: [known, portable] + properties: [known, pickable] - name: o-tile display: char: 'o' attr: oddtile description: - Fifteen - properties: [known, portable] + properties: [known, pickable] - name: p-tile display: char: 'p' attr: eventile description: - Sixteen - properties: [known, portable] + properties: [known, pickable] - name: q-tile display: char: 'q' attr: oddtile description: - Seventeen - properties: [known, portable] + properties: [known, pickable] - name: r-tile display: char: 'r' attr: eventile description: - Eighteen - properties: [known, portable] + properties: [known, pickable] - name: s-tile display: char: 's' attr: oddtile description: - Nineteen - properties: [known, portable] + properties: [known, pickable] - name: t-tile display: char: 't' attr: eventile description: - Twenty - properties: [known, portable] + properties: [known, pickable] - name: u-tile display: char: 'u' attr: oddtile description: - Twenty-one - properties: [known, portable] + properties: [known, pickable] - name: v-tile display: char: 'v' attr: eventile description: - Twenty-two - properties: [known, portable] + properties: [known, pickable] - name: w-tile display: char: 'w' attr: oddtile description: - Twenty-three - properties: [known, portable] + properties: [known, pickable] - name: x-tile display: char: 'x' attr: eventile description: - Twenty-four - properties: [known, portable] + properties: [known, pickable] - name: y-tile display: char: 'y' attr: oddtile description: - Twenty-five - properties: [known, portable] + properties: [known, pickable] - name: a-tile-ordinal display: char: 'a' 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 @@ -11,7 +11,7 @@ (n * (n + 1)) / 2 end; -def mod : int -> int -> int = \i.\m. +def mod : Int -> Int -> Int = \i.\m. i - m * (i / m); end @@ -46,7 +46,7 @@ teleport self newLoc; end; -def getOrdinal : text -> cmd int = \item. +def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -60,12 +60,8 @@ let idx = n - 1 in teleport self (idx/boardHeight, -(mod idx boardWidth)); valueHere <- getValueHere; - - // This reassignment has to happen before the - // recursive call due to #1032 - let valueHereBlah = valueHere in runningTotal <- getIndexesTotal boardWidth boardHeight $ n - 1; - return $ valueHereBlah + runningTotal; + return $ valueHere + runningTotal; } { return 0; } @@ -166,7 +162,7 @@ Precondition: Facing east at location (0, 0). */ -def iterateAllTiles : cmd unit -> cmd unit = \func. +def iterateAllTiles : Cmd Unit -> Cmd Unit = \func. let b = "border" in isOnBottomBorder <- itemIsHere b; if isOnBottomBorder {} { 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 @@ -8,7 +8,7 @@ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; -def mod : int -> int -> int = \i.\m. +def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end @@ -23,7 +23,7 @@ letter ++ "-tile"; end; -def getOrdinal : text -> cmd int = \item. +def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -112,7 +112,7 @@ Left is a Boolean indicating whether the tile has been drilled. Right is a valid tile entity name. */ -def scanValid : dir -> cmd (bool + text) = \d. +def scanValid : Dir -> Cmd (Bool + Text) = \d. maybeTileForward <- scan d; case maybeTileForward (\_. return $ inL false) 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 @@ -21,7 +21,7 @@ $ else {0}; end; -def mod : int -> int -> int = \i.\m. +def mod : Int -> Int -> Int = \i.\m. i - m * (i / m); end @@ -35,7 +35,7 @@ (fst t1 + fst t2, snd t1 + snd t2); end; -def getOrdinal : text -> cmd int = \item. +def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -60,7 +60,7 @@ return $ sumTuples negatedLoc absLoc; end; -def getRelativeRectangle : (int * int) * (int * int) -> cmd ((int * int) * (int * int)) = \corners. +def getRelativeRectangle : (Int * Int) * (Int * Int) -> Cmd ((Int * Int) * (Int * Int)) = \corners. myloc <- whereami; let negatedLoc = negateTuple myloc in return $ mapTuple (sumTuples negatedLoc) corners; 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 @@ -7,7 +7,7 @@ case x (\_. return false) (\found. return $ found == item); end; -def getOrdinal : text -> cmd int = \item. +def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -16,7 +16,7 @@ Returns a Left if we are non-monotonic. Otherwise returns the next expected value. */ -def isMonotonic : int -> cmd (unit + int) = \expectedVal. +def isMonotonic : Int -> Cmd (Unit + Int) = \expectedVal. maybeItem <- scan down; case maybeItem (\_. return $ inR expectedVal) // Cell was blank @@ -38,7 +38,7 @@ Precondition: Facing east at location (0, 0). */ -def loopMonotonicityCheck : int -> cmd bool = \expectedVal. +def loopMonotonicityCheck : Int -> Cmd Bool = \expectedVal. isOnBottomBorder <- itemIsHere "border"; if isOnBottomBorder { return true; 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 @@ -14,7 +14,7 @@ }; robots: - name: base - dir: [0, -1] + dir: south display: attr: gold devices: @@ -62,8 +62,8 @@ display: char: '@' description: - - Pushable rock - properties: [known, unwalkable, portable] + - Pushable rock + properties: [known, unwalkable, pickable] known: [mountain, water, flower] world: dsl: | 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 @@ -14,7 +14,7 @@ }; robots: - name: base - dir: [1, 0] + dir: east display: attr: gold devices: @@ -45,8 +45,8 @@ display: char: '@' description: - - Pushable rock - properties: [known, unwalkable, portable] + - Pushable rock + properties: [known, unwalkable, pickable] known: [mountain, water, flower] world: dsl: | 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 @@ -21,7 +21,7 @@ }; robots: - name: base - dir: [1, 0] + dir: east display: attr: gold devices: @@ -97,8 +97,8 @@ display: char: '@' description: - - Pushable rock - properties: [known, unwalkable, portable] + - Pushable rock + properties: [known, unwalkable, pickable] known: [mountain, water, flower] world: dsl: | diff --git a/data/scenarios/Challenges/Sokoban/_foresight/solution.sw b/data/scenarios/Challenges/Sokoban/_foresight/solution.sw --- a/data/scenarios/Challenges/Sokoban/_foresight/solution.sw +++ b/data/scenarios/Challenges/Sokoban/_foresight/solution.sw @@ -139,7 +139,7 @@ pushUntilBarrier; wait 4; - move; + moveUntilBlocked; doN 5 (turn left; moveUntilBlocked); turn right; 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 @@ -32,7 +32,7 @@ - name: base display: attr: bluish - dir: [0, 1] + dir: north devices: - branch predictor - ADT calculator @@ -70,28 +70,28 @@ - [5, strange loop] - [5, treads] solution: | - run "scenarios/Challenges/Sokoban/_foresight/solution.sw" + run "scenarios/Challenges/Sokoban/_foresight/solution.sw" entities: - name: monolith display: char: '@' attr: gold description: - - Pushable rock - properties: [known, unwalkable, portable] + - Pushable rock + properties: [known, unwalkable, pickable] - name: crate display: attr: wood char: '▪' description: - - Pushable crate - properties: [known, portable, unwalkable] + - Pushable crate + properties: [known, pickable, unwalkable] - name: wall display: attr: barrier char: '#' description: - - Unmovable barrier + - Unmovable barrier properties: [known, unwalkable] known: [mountain, water, 3D printer, flower] world: @@ -108,7 +108,6 @@ '@': [grass, monolith] 'c': [grass, crate] 'A': [grass, wall] - 'w': [dirt, water] 'x': [stone, erase] 'z': [dirt, erase] map: | 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 @@ -18,7 +18,7 @@ Distinguishes system bots from the base by name. Returns true if a bot has "met" the base. */ -def anyHasMetBase : int -> cmd bool = \idx. +def anyHasMetBase : Int -> Cmd Bool = \idx. try { bot <- robotnumbered idx; 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 @@ -4,7 +4,6 @@ end; def cycleCombos = \n. - wait 1; entityNorth <- scan north; let hasGate = case entityNorth (\_. false) (\x. x == "gate") in if hasGate { diff --git a/data/scenarios/Challenges/_dimsum/cook.sw b/data/scenarios/Challenges/_dimsum/cook.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_dimsum/cook.sw @@ -0,0 +1,24 @@ +def modifyCart = \cartType. \device. + result <- scan forward; + case result return (\item. + if (item == cartType) { + use device forward; + return (); + } { + return (); + }; + ); + end; + +def watchSpot = + watch forward; + wait 1000; + modifyCart "empty cart" "spatula"; + end; + +def go = + watchSpot; + go; + end; + +go; diff --git a/data/scenarios/Challenges/_dimsum/patron.sw b/data/scenarios/Challenges/_dimsum/patron.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_dimsum/patron.sw @@ -0,0 +1,24 @@ +def modifyCart = \cartType. \device. + result <- scan forward; + case result return (\item. + if (item == cartType) { + use device forward; + return (); + } { + return (); + }; + ); + end; + +def watchSpot = + watch forward; + wait 1000; + modifyCart "full cart" "fork"; + end; + +def go = + watchSpot; + go; + end; + +go; diff --git a/data/scenarios/Challenges/_dimsum/solution.sw b/data/scenarios/Challenges/_dimsum/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_dimsum/solution.sw @@ -0,0 +1,27 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def moveOne = + move; + move; + turn back; + push; + turn back; + end; + +def oneLap = + doN 4 ( + doN 8 moveOne; + turn right; + ); + end; + +def moveCartToDiagonal = + doN 16 oneLap; + end; + + +def go = + doN 4 moveCartToDiagonal; + 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 @@ -1,6 +1,6 @@ -def forever : cmd unit -> cmd unit = \c. c ; forever c end +def forever : Cmd Unit -> Cmd Unit = \c. c ; forever c end -def repeat : int -> cmd unit -> cmd unit = +def repeat : Int -> Cmd Unit -> Cmd Unit = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} end @@ -9,7 +9,7 @@ def abs = \n. if (n < 0) {-n} {n} end -def randdir : cmd dir = +def randdir : Cmd Dir = d <- random 4; return ( if (d == 0) {north} @@ -19,7 +19,7 @@ ) end -def chooseWait : cmd int = +def chooseWait : Cmd Int = t <- random (16*2); return (16 + t) end @@ -35,7 +35,7 @@ def disappointed = \cat. say "meow??"; cat end -def follow : cmd unit -> actor -> cmd unit = \cat. \r. +def follow : Cmd Unit -> Actor -> Cmd Unit = \cat. \r. rLoc <- as r {whereami}; myLoc <- whereami; let dx = fst rLoc - fst myLoc in diff --git a/data/scenarios/Challenges/_gallery/setup.sw b/data/scenarios/Challenges/_gallery/setup.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_gallery/setup.sw @@ -0,0 +1,161 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def isDivisibleBy = \dividend. \divisor. + (dividend / divisor) * divisor == dividend; + end; + +def isEven = \x. + isDivisibleBy x 2 + end; + +def getMissingBitRecursive = \bitmask. \idx. + if (idx > 0) { + if (isEven bitmask) { + idx + } { + getMissingBitRecursive (bitmask / 2) $ idx - 1; + } + } { + // The MSB was the missing bit. + 0; + } + end; + +/** +Returns the index of the right-most bit that is zero. +*/ +def getMissingBit = \bitmask. \maxIdx. + let val = getMissingBitRecursive bitmask maxIdx in + maxIdx - val; + end; + +/** +Performs a right bitshift of "x" by "n" places +*/ +def shiftRight = \x. \n. + x / (2^n); + end; + +/** +Performs a left bitshift of "x" by "n" places +*/ +def shiftLeft = \x. \n. + x * (2^n); + end; + +/** +Checks whether the bit at index "idx" is set in the "bitmask". +zero-based indexing; 0 is the LSB. +*/ +def isBitSet = \bitmask. \idx. + not $ isEven $ shiftRight bitmask idx; + end; + +/** +Repeatedly generate a random number until +we find one that's not in the bitmask. +*/ +def getUnusedRandom = \maxval. \bitmask. + nextRandomVal <- random maxval; + if (isBitSet bitmask nextRandomVal) { + getUnusedRandom maxval bitmask; + } { + return nextRandomVal; + } + end; + +/** +Use the `random` function to generate a random permuation of `n` contiguous values. +Uses a bitmask to ensure uniqueness. + +Fisher-Yates would be more efficient, but requires a physical array. +*/ +def naiveRandomStack = \valueFunc. \maxval. \bitmask. \n. + val <- if (n > 1) { + nextRandomVal <- getUnusedRandom maxval bitmask; + let newBitmask = bitmask + shiftLeft 1 nextRandomVal in + naiveRandomStack valueFunc maxval newBitmask $ n - 1; + return nextRandomVal; + } { + // We're at the peak of the stack. + // Now we unwind it. + + // Saves some time in generating the last number by inferring the + // only remaining possible choice. + let missingBit = getMissingBit bitmask maxval in + return missingBit; + }; + valueFunc val; + end; + +def getEntName = \idx. + result <- tagmembers "bust" idx; + return $ snd result; + end; + +def placeThing = \entIdx. + entName <- getEntName entIdx; + create entName; + place entName; + end; + +def placeEntByIndex = \bitIndex. + placeThing bitIndex; + move; + end; + +/* +Generates a constant-time lookup table from +name to ordinal for both the judge robot +and the base. + +The "baseExtraCount" gets carried over +across iterations to ensure the count for each +bust in the base's inventory increases monotonically. + +"idx" counts upwards. +*/ +def populateInventory = \baseCount. \idx. + + result <- tagmembers "bust" idx; + let total = fst result in + + if (idx < total) { + + let item = snd result in + + // Give copies to the base + baseExtras <- random 5; + let newBaseCount = 1 + baseCount + baseExtras in + doN newBaseCount ( + create item; + give base item; + ); + + // Keep copies for myself + doN (idx + 1) ( + create item; + ); + + populateInventory newBaseCount $ idx + 1; + } {}; + + end; + +def setup = + result <- tagmembers "bust" 0; + let totalCount = fst result in + + populateInventory 0 0; + + naiveRandomStack placeEntByIndex totalCount 0 totalCount; + turn back; + move; + create "bitcoin"; + end; + +def go = + instant setup; + end; + +go; diff --git a/data/scenarios/Challenges/_gallery/solution.sw b/data/scenarios/Challenges/_gallery/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_gallery/solution.sw @@ -0,0 +1,117 @@ +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +def countRow = \currentCount. + emptyHere <- isempty; + if emptyHere { + return currentCount; + } { + move; + countRow $ 1 + currentCount; + }; + end; + +def getOrdinal = \d. + maybeEntity <- scan d; + case maybeEntity (\nothing. return $ inL nothing) (\item. + myCount <- count item; + return $ inR myCount; + ); + end; + +/* +Precondition: +Facing west, just north of the row. +*/ +def moveToBeginning = + thingLeft <- scan left; + case thingLeft (\_. + turn back; + move; + ) (\_. + move; + moveToBeginning; + ); + end; + +def doSwap = + turn right; + push; + turn right; + move; + move; + turn back; + push; + move; + move; + turn right; + move; + turn right; + push; + turn left; + move; + turn right; + move; + turn right; + push; + move; + move; + turn right; + move; + end; + +/* +Precondition: +Standing just north of the eastern +member in the pair, and facing east. + +Postcondition: +Moved one space east from staring position +in the same orientation. +*/ +def swapAdjacent = \remainingSteps. \previousOrdinal. + thisOrdinal <- if (remainingSteps > 1) { + getOrdinal right; + } { + return $ inL (); + }; + + case thisOrdinal (\_. + turn back; + move; + moveToBeginning; + ) (\num. + let shouldSwap = num < previousOrdinal in + ordinal <- if shouldSwap { + doSwap; + return previousOrdinal; + } { + return num; + }; + move; + swapAdjacent (remainingSteps - 1) ordinal; + ); + end; + +def doLoop = \unsortedCount. + if (unsortedCount > 1) { + prevOrdinal <- getOrdinal right; + move; + case prevOrdinal return $ swapAdjacent unsortedCount; + doLoop $ unsortedCount - 1; + } {} + end; + +def go = + move; + move; + move; + totalCount <- countRow 0; + turn back; + doN totalCount move; + turn right; + move; + turn right; + doLoop totalCount; + end; + +go; 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 @@ -99,11 +99,11 @@ say $ snd tauntStage; } {}; - appear "o"; + appear "o" (inl ()); arrive width height; place dropping; - appear "G"; + appear "G" (inl ()); waitWhileHere dropping 150; go width height tauntIndex startingAmount dropping; } { 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 @@ -37,7 +37,7 @@ return isBlocked; end; -def chooseDirection : cmd dir = +def chooseDirection : Cmd Dir = leftBlocked <- checkLeftBlocked; rightBlocked <- checkRightBlocked; forwardBlocked <- isBlockedAhead; @@ -117,19 +117,6 @@ } end; -// Ghosts must implement teleporting logic themselves. -// Hard-codes location of the teleporter. -def checkNeedsTeleport = \offset. - currentLoc <- whereami; - if (fst currentLoc < -offset) { - teleport self (offset, snd currentLoc) - } { - if (fst currentLoc > offset) { - teleport self (-offset, snd currentLoc) - } {} - } - end; - startPos <- whereami; def go = @@ -138,7 +125,6 @@ teleport self startPos; } { move; - checkNeedsTeleport 11; newDirection <- chooseDirection; turn newDirection; go; 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 @@ -126,7 +126,7 @@ end; def invadeDen = - doN 14 move; + doN 13 move; turn right; doN 2 move; turn left; diff --git a/data/scenarios/Challenges/_hackman/teleport_monitor.sw b/data/scenarios/Challenges/_hackman/teleport_monitor.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_hackman/teleport_monitor.sw @@ -0,0 +1,22 @@ +/* Algorithm: +If, at any point, the base is more than two cells from its previous location, +it must have teleported. +*/ + +def abs = \n. if (n<0) {-n} {n} end; + +def getBasePos = + as base {whereami}; + end; + +def go = \lastBasePos. + wait 1; + curBasePos <- getBasePos; + let deltaX = abs(fst curBasePos - fst lastBasePos) in + if (deltaX > 1) { + create "bit (0)"; + } {go curBasePos}; + end; + +curBasePos <- getBasePos; +go curBasePos; diff --git a/data/scenarios/Challenges/_hackman/teleporter.sw b/data/scenarios/Challenges/_hackman/teleporter.sw deleted file mode 100644 --- a/data/scenarios/Challenges/_hackman/teleporter.sw +++ /dev/null @@ -1,41 +0,0 @@ -/* Algorithm: -If the player was previously on one side of me upon last inspection -and is now on top of me or on the other side, teleport them across -the map. -*/ - -def isBeyond = \func. - basePos <- as base { - whereami; - }; - return $ func $ fst basePos; - end; - -def observeAndTeleport = \criteriaFunc. \telporterPos. \wasExceeded. - currentlyExceeded <- isBeyond criteriaFunc; - - // Boundary was crossed - if (currentlyExceeded && not wasExceeded) { - teleport base (-(fst telporterPos), snd telporterPos); - create "bit (0)"; - } {}; - - observeAndTeleport criteriaFunc telporterPos currentlyExceeded; - end; - -def init = - telporterPos <- whereami; - let teleX = fst telporterPos in - let isWesternTeleporter = teleX < 0 in - - criteriaFunc <- if isWesternTeleporter { - return $ \baseX. baseX < teleX; - } { - return $ \baseX. baseX > teleX; - }; - - initiallyBeyond <- isBeyond criteriaFunc; - observeAndTeleport criteriaFunc telporterPos initiallyBeyond; - end; - -init; 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 @@ -42,12 +42,12 @@ end; def hanoi : - int -> // The number of disks in each column - int -> // Current column (basically offset of all columns) - int -> // The offset to first column - int -> // The offset to second column - int -> // The offset to third column - cmd int + Int -> // The number of disks in each column + Int -> // Current column (basically offset of all columns) + Int -> // The offset to first column + Int -> // The offset to second column + Int -> // The offset to third column + Cmd Int = \n. \o. \a. \b. \c. if (n == 0) {return o} { 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 @@ -7,7 +7,7 @@ end; // modulus function (%) -def mod : int -> int -> int = \i.\m. +def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end @@ -137,7 +137,7 @@ teleport self (0, snd curLoc - 1); end; -def shouldCorrectTile : (bool * bool) -> (bool * bool) -> cmd bool = \evenOverlaps. \isQuietTiles. +def shouldCorrectTile : (Bool * Bool) -> (Bool * Bool) -> Cmd Bool = \evenOverlaps. \isQuietTiles. if (evenOverlaps == isQuietTiles) { toggleLightHere; return true; @@ -189,13 +189,8 @@ return (0, 0); } { advanceRowViaTeleport; - - // This reassignment has to happen before the recursive - // "prepareBoardAllRows" call due to #1032 - let rowCommonCountFoo = rowCommonCount in totalCommonCount <- prepareBoardAllRows abortFunc boardWidth $ rowIdx - 1; - - return $ sumTuples rowCommonCountFoo totalCommonCount + return $ sumTuples rowCommonCount totalCommonCount } } { return (0, 0); @@ -220,7 +215,7 @@ return retval; end; -def analyzeSolvability : int -> int -> cmd (bool * bool) = \boardWidth. \boardHeight. +def analyzeSolvability : Int -> Int -> Cmd (Bool * Bool) = \boardWidth. \boardHeight. atLocation (0, 0) $ checkIsSolvable boardWidth boardHeight; 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 @@ -2,7 +2,7 @@ def else = \t. t end def abs = \n. if (n < 0) {-n} {n} end // modulus function (%) -def mod : int -> int -> int = \i.\m. +def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end @@ -17,7 +17,7 @@ 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. +def getQuadrant : (Int * Int) -> (Int * Int) -> Int = \baseLoc. \myLoc. let baseX = fst baseLoc in let baseY = snd baseLoc in @@ -53,7 +53,7 @@ $ else {0} end; -def getCurrentQuadrant : (int * int) -> cmd int = \myLoc. +def getCurrentQuadrant : (Int * Int) -> Cmd Int = \myLoc. baseLoc <- as base {whereami}; return $ getQuadrant baseLoc myLoc; end; @@ -80,7 +80,7 @@ means that the traversal number could get out of sync with the absolute quadrant index. */ -def monitorAngle : (int * int) -> int -> int -> int -> cmd unit = +def monitorAngle : (Int * Int) -> Int -> Int -> Int -> Cmd Unit = \myLoc. \targetQuadrantCount. \prevQuadrant. \quadrantTraversalCount. result <- instant $ checkNewQuadrant myLoc prevQuadrant quadrantTraversalCount; let currentQuadrant = fst result in diff --git a/data/scenarios/Challenges/_pack-tetrominoes/solution.sw b/data/scenarios/Challenges/_pack-tetrominoes/solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/_pack-tetrominoes/solution.sw @@ -0,0 +1,67 @@ +move; +place "j-tile"; +move; +place "j-tile"; +turn left; +move; +place "j-tile"; +move; +place "j-tile"; + +turn back; +move; move; +turn left; +move; + +place "t-tile"; +move; +place "t-tile"; +turn left; +move; +place "t-tile"; +turn back; +move; +turn left; +move; +place "t-tile"; + +turn back; +move; +move; +turn right; +move; + +place "z-tile"; +move; +place "z-tile"; +turn right; +move; +place "z-tile"; +turn left; +move; +place "z-tile"; + +turn left; +move; + +place "i-tile"; +move; +place "i-tile"; +move; +place "i-tile"; +move; +place "i-tile"; + +turn left; +move; + +place "q-tile"; +move; +turn left; +place "q-tile"; +move; +turn left; +place "q-tile"; +move; +turn left; +place "q-tile"; 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 @@ -153,7 +153,7 @@ return letterIndex; end; -def crossBack = \n. +def crossBack = \_n. currentLoc <- whereami; teleport self (0, snd currentLoc - 1); end; diff --git a/data/scenarios/Challenges/_word-search/verify-solution.sw b/data/scenarios/Challenges/_word-search/verify-solution.sw deleted file mode 100644 --- a/data/scenarios/Challenges/_word-search/verify-solution.sw +++ /dev/null @@ -1,183 +0,0 @@ -/** -Algorithm: -We only need to check the base's -current position: if we find three contiguous highlights, -then we know that the player has just completed their -third highlight. -*/ - -def whichOrdinal = - isC <- ishere "lowercase c"; - if (isC) { - return 0; - } { - isO <- ishere "lowercase o"; - if (isO) { - return 1; - } { - isW <- ishere "lowercase w"; - if (isW) { - return 2; - } { - return (-1); - } - } - } - end; - - -def whichHighlightedOrdinal = \str. - if (str == "lowercase c") { - return 0; - } { - if (str == "lowercase o") { - return 1; - } { - if (str == "lowercase w") { - return 2; - } { - return (-1); - } - } - } - end; - -def countConsecutive = \expectedOrdinal. \n. - - thisOrdinal <- whichOrdinal; - nextOrdinal <- if (thisOrdinal == expectedOrdinal) { - return $ expectedOrdinal + 1; - } { - return 0; - }; - - if (nextOrdinal == 3) { - return true; - } { - if (n > 1) { - move; - countConsecutive nextOrdinal $ n - 1; - } { - return false; - }; - }; - end; - -def checkBackAndForth = - - foundBackward <- countConsecutive 0 3; - if (foundBackward) { - return true; - } { - turn back; - countConsecutive 0 3; - } - end; - -def checkDirections = \n. - if (n > 0) { - wasFound <- checkBackAndForth; - if wasFound { - return true; - } { - turn left; - checkDirections $ n - 1; - } - } { - return false; - } - end; - -def isMarkedInDirection = \d. - scanResult <- scan d; - ordinalNum <- case scanResult - (\_. return (-1)) - whichHighlightedOrdinal; - return $ ordinalNum >= 0; - end; - -/** -It's possible we could be one cell away from -a marked cell after finishing, either due -to using a directional `drill` command instead of -`drill down`, or due to an apparent bug which -does not evaluate the goal condition between the -`drill` and a `move` command. -*/ -def moveToMarkedCell = \n. - if (n > 0) { - isMarkedAhead <- isMarkedInDirection forward; - if isMarkedAhead { - move; - return true; - } { - turn left; - moveToMarkedCell $ n - 1; - }; - } { - return false; - }; - end; - -/** -Orient ourselves such that -a marked cell is behind us. -*/ -def findMarkBehind = \n. - if (n > 0) { - isMarkedBehind <- isMarkedInDirection back; - if isMarkedBehind { - return true; - } { - turn left; - findMarkBehind $ n - 1; - }; - } { - return false; - }; - end; - -/** -The cell we're on might be in the middle of a word, -rather than the end. Determine the orientation of -the line, then move along it until reaching the end. - -Algorithm: -0. Assumption: we are currently on a marked cell. -1. Turn in all all four directions to `scan back` - for a second marked cell. Stop turning if - we encounter one. - If none found after 4 turns, abort. -2. `scan forward` to see if there is a marked cell in - the opposite direction. - `move` (foward) once if there is. Since the word - is only three cells long, this will be the other - end of it. -*/ -def moveToWordExtrema = - foundCellBehind <- findMarkBehind 4; - if foundCellBehind { - isMarkedAhead <- isMarkedInDirection forward; - if isMarkedAhead { - move; - } {}; - } {}; - end; - -def checkSoln = - isMarkedHere <- isMarkedInDirection down; - atMarkedCell <- if isMarkedHere { - return true; - } { - moveToMarkedCell 4; - }; - - if atMarkedCell { - moveToWordExtrema; - checkDirections 4; - } { - return false; - } - end; - -as base {checkSoln}; 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 @@ -57,7 +57,7 @@ bg: '#000000' robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - antenna @@ -78,7 +78,7 @@ inventory: - [5, paperclip] solution: | - run "scenarios/Challenges/_arbitrage/solution.sw" + run "scenarios/Challenges/_arbitrage/solution.sw" entities: - name: paperclip display: @@ -87,95 +87,95 @@ description: - An ubiquitous office accoutrement. - Practically worthless as a single unit. - properties: [known, portable] + properties: [known, pickable] - name: pinwheel display: char: 'P' attr: gold description: - Watch it spin. Wheee! - properties: [portable] + properties: [pickable] - name: stapler display: char: 'S' attr: red description: - A shiny red stapler - properties: [portable] + properties: [pickable] - name: toothbrush display: char: 'b' attr: blue description: - Brushy brushy - properties: [portable] + properties: [pickable] - name: Pez dispenser display: char: 'P' description: - Classic collectible toy. Absent its chalky candy. - properties: [portable] + properties: [pickable] - name: shoehorn display: char: 'h' description: - Handheld apparatus for donning snug footwear - properties: [portable] + properties: [pickable] - name: trivet display: char: 'v' description: - Protective silicone mat for hot cookware - properties: [portable] + properties: [pickable] - name: coffee mug display: char: 'c' description: - Caffeine conveyance - properties: [portable] + properties: [pickable] - name: toaster display: char: 'A' description: - Bread warmer-upper - properties: [portable] + properties: [pickable] - name: blender display: char: 'B' description: - Essential for smoothie preparation - properties: [portable] + properties: [pickable] - name: electric can opener display: char: 'B' description: - | For when you can't be bothered to manually open a can - properties: [portable] + properties: [pickable] - name: wok display: char: 'w' description: - One must wok before one can run. - properties: [portable] + properties: [pickable] - name: sous vide cooker display: char: 's' description: - trendy gourmet cooking appliance - properties: [portable] + properties: [pickable] - name: french press display: char: 'f' description: - plunger-based coffee maker - properties: [portable] + properties: [pickable] - name: stand mixer display: char: 'm' description: - whips, kneads, and mixes - properties: [portable] + properties: [pickable] - name: shopA display: char: 'A' 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 @@ -44,8 +44,8 @@ Distinguishes system bots from the base by name. Returns true if a bot has "met" the base. */ - def anyHasMetBase : int -> cmd bool = \idx. - + def anyHasMetBase : Int -> Cmd Bool = \idx. + try { bot <- robotnumbered idx; intermediate <- hasMetBase bot; @@ -63,7 +63,7 @@ anyHasMetBase 1; robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - binoculars @@ -87,7 +87,7 @@ - welder - name: cw_robot system: true - dir: [0, 1] + dir: north display: invisible: false char: 'X' @@ -96,7 +96,7 @@ run "scenarios/Challenges/_blender/patrol-clockwise.sw" - name: cw_robot_down system: true - dir: [0, -1] + dir: south display: invisible: false char: 'X' @@ -105,7 +105,7 @@ run "scenarios/Challenges/_blender/patrol-clockwise.sw" - name: ccw_robot system: true - dir: [0, 1] + dir: north display: invisible: false char: 'X' @@ -114,7 +114,7 @@ run "scenarios/Challenges/_blender/patrol-counter-clockwise.sw" - name: ccw_robot_down system: true - dir: [0, -1] + dir: south display: invisible: false char: 'X' @@ -151,7 +151,7 @@ attr: gold description: - used to unlock a door - properties: [known, portable] + properties: [known, pickable] capabilities: [drill] - name: bind gt display: @@ -173,7 +173,7 @@ attr: snow description: - The figurative jewel of category theory - properties: [known, portable] + properties: [known, pickable] recipes: - in: - [1, locked door] 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 @@ -87,13 +87,8 @@ - id: get_map teaser: Get the map goal: - - As a humble `peat`{=entity} farmer, you subsist in a simple cabin by the `bog`{=entity}. - Though long content with this ascetic lifestyle, recently the barren walls have - left you restless. Something is missing... - - "The majestic landscape that is your back yard is insufficient to distract you---not - even the ferocious, `lava`{=entity}-spewing volcano little more than a stone's throw from - your porch. - You are preoccupied by one task: to find the perfect household decoration." + - As a humble `peat`{=entity} farmer, you subsist in a simple cabin by the `bog`{=entity}. Though long content with this ascetic lifestyle, recently the barren walls have left you restless. Something is missing... + - "The majestic landscape that is your back yard is insufficient to distract you---not even the ferocious, `lava`{=entity}-spewing volcano little more than a stone's throw from your porch. You are preoccupied by one task: to find the perfect household decoration." - First, grab a `map`{=entity} to orient yourself. condition: | as base { @@ -104,19 +99,11 @@ prerequisite: get_map goal: - You study the `map`{=entity}. - - Glacier-bound mountains tower in the `east`, - a volcano oozes a river of `lava`{=entity} to the `north`, and beyond that lies a mountain lake, punctuated with islands - in the northwest. - Iron mines penetrate the base of the volcano. They could be useful, but how will you get there? - - A `jungle`{=entity} abuts the volcano, ensconcing an ancient ruin. - The map notes that bygone travelers have stashed tools among the northeasterly mountains to - blaze a path through the jungle. + - Glacier-bound mountains tower in the `east`, a volcano oozes a river of `lava`{=entity} to the `north`, and beyond that lies a mountain lake, punctuated with islands in the northwest. Iron mines penetrate the base of the volcano. They could be useful, but how will you get there? + - A `jungle`{=entity} abuts the volcano, ensconcing an ancient ruin. The map notes that bygone travelers have stashed tools among the northeasterly mountains to blaze a path through the jungle. - Your only neighbor, a `hemp`{=entity} farmer to the northwest, has evacuated since the sudden volcanic eruption. - - A disused quarry and clay pit flanks your cabin to the `west`, as does the familiar, swampy `bog`{=entity} to the `east`. - A highly-prized `flower`{=entity} is said to grow in the caves beyond the bog. - - Your mind is made up. You will pillage the ruins for treasure! Head to the ruins and `scan` them. - Ingenuity and endurance are your allies as you forge paths through varied obstacles. - Study your "recipes" for clues! + - A disused quarry and clay pit flanks your cabin to the `west`, as does the familiar, swampy `bog`{=entity} to the `east`. A highly-prized `flower`{=entity} is said to grow in the caves beyond the bog. + - Your mind is made up. You will pillage the ruins for treasure! Head to the ruins and `scan` them. Ingenuity and endurance are your allies as you forge paths through varied obstacles. Study your "recipes" for clues! condition: | as base { knows "temple"; @@ -126,8 +113,7 @@ prerequisite: find_temple goal: - "A note on the door says:" - - '"Greetings, intrepid traveler. Encircle this temple with the rare `flower`{=entity} of the southeastern - caves, and the treasure of this `temple`{=entity} shall be revealed."' + - '"Greetings, intrepid traveler. Encircle this temple with the rare `flower`{=entity} of the southeastern caves, and the treasure of this `temple`{=entity} shall be revealed."' - Plant a ring of flowers around the jungle temple. condition: | as base { @@ -145,7 +131,7 @@ }; robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor @@ -181,7 +167,7 @@ - [0, jungle] - name: flowercheck system: true - dir: [0, 1] + dir: north display: invisible: true devices: @@ -192,7 +178,7 @@ run "scenarios/Challenges/_bridge-building/flower-ring-check.sw" - name: platecheck system: true - dir: [0, 1] + dir: north display: invisible: true solution: | @@ -204,21 +190,21 @@ attr: 'magenta' description: - The map describes local points of interest, relative to your cabin. - properties: [portable, known] + properties: [pickable, known] - name: peat furnace display: char: 'F' attr: tan description: - Fueled by peat. - properties: [portable, known] + properties: [pickable, known] - name: clay display: char: 'c' attr: tan description: - Can be fired in a peat furnace into a vessel. - properties: [portable, known] + properties: [pickable, known] - name: lava display: char: 'w' @@ -232,21 +218,21 @@ attr: tan description: - A tiny, inconsequential rock. - properties: [known, portable] + properties: [known, pickable] - name: machete display: char: '/' attr: cyan description: - Easily cuts through jungle overgrowth. - properties: [known, portable] + properties: [known, pickable] - name: painted plate display: char: 'o' attr: obsidian description: - Limited edition 1978 collectible Helix the Cat ornamental hand-painted dinner plate. - properties: [known, portable] + properties: [known, pickable] - name: oven mitts display: char: 'm' @@ -286,7 +272,7 @@ attr: silver description: - Can break hard objects - properties: [known, portable] + properties: [known, pickable] - name: granite mountain display: char: 'A' @@ -312,35 +298,35 @@ char: 'L' description: - Can be used to traverse down a cliff. - properties: [known, portable] + properties: [known, pickable] - name: hemp display: char: 'h' attr: plant description: - Can be used to make rope - properties: [known, portable, growable] + properties: [known, pickable, growable] - name: flimsy board display: char: 'b' attr: wood description: - Board made from a soft log. Has poor rigidity. - properties: [known, portable] + properties: [known, pickable] - name: soft log display: char: 'l' attr: wood description: - Log made from a palm tree. A bit flexible. - properties: [known, portable] + properties: [known, pickable] - name: coconut display: char: 'c' attr: wood description: - Spherical, buoyant husk - properties: [known, portable] + properties: [known, pickable] - name: floating boardwalk display: char: '▒' @@ -354,7 +340,7 @@ attr: wood description: - Burnable plant material - properties: [known, portable] + properties: [known, pickable] - name: peat bog display: char: 'b' @@ -388,14 +374,14 @@ char: 'c' description: - An empty crucible. Can carry lava. - properties: [known, portable] + properties: [known, pickable] - name: lava-filled crucible display: char: 'C' attr: lavaBG description: - Crucible filled with lava - properties: [known, portable] + properties: [known, pickable] - name: quarry display: char: 'Q' @@ -450,13 +436,13 @@ char: 'r' description: - An empty container for rubble. - properties: [known, portable] + properties: [known, pickable] - name: rubble-filled skip display: char: 'R' description: - An full container of rubble. Can be dumped in the water as fill to form a causeway. - properties: [known, portable] + properties: [known, pickable] - name: causeway display: char: '▒' @@ -468,14 +454,14 @@ char: 'k' description: - Tank with nothing in it - properties: [known, portable] + properties: [known, pickable] - name: water-filled tank display: char: 'K' attr: blueBG description: - Tank filled with water - properties: [known, portable] + properties: [known, pickable] - name: obsidian path display: char: '`' @@ -489,14 +475,14 @@ attr: obsidian description: - Dislodged fragment of obsidian - properties: [known, portable] + properties: [known, pickable] - name: palm tree display: char: 'P' attr: beach description: - Palm tree. - properties: [known, portable, growable] + properties: [known, pickable, growable] recipes: - in: - [8, clay] 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 @@ -10,7 +10,7 @@ char: 'Ω' attr: robot heavy: true - dir: [0, 1] + dir: north devices: - 3D printer - ADT calculator @@ -35,7 +35,7 @@ - [1, treads] - name: hauler system: true - dir: [-1, 0] + dir: west devices: - furnace display: @@ -46,7 +46,7 @@ run "scenarios/Challenges/_bucket-brigade/hauler.sw" - name: powerplant system: true - dir: [1, 0] + dir: east display: invisible: false char: '▒' @@ -70,10 +70,8 @@ as base {has "coal lump"} - goal: - Your base got some coal! - - Now fashion more of it into a "coal briquette", and place it - so that the hauler (=) can pick it up. - - The hauler will periodically stop at the base - to check if a load is available. + - Now fashion more of it into a "coal briquette", and place it so that the hauler (=) can pick it up. + - The hauler will periodically stop at the base to check if a load is available. condition: | hauler <- robotnamed "hauler"; as hauler {has "coal briquette"} @@ -86,7 +84,7 @@ char: 'x' description: - A powerful machine designed to remove overburden in mining operations. - properties: [known, portable] + properties: [known, pickable] capabilities: [drill] - name: lignite mine display: @@ -100,31 +98,31 @@ char: 'c' description: - Primitive, sooty fuel. - properties: [known, portable] + properties: [known, pickable] - name: coal briquette display: char: 'q' description: - A compressed, convenient form of coal for consumption and transport. - properties: [known, portable] + properties: [known, pickable] - name: briquette press display: char: 'P' description: - A device to compress coal lumps into briquettes. - properties: [known, portable] + properties: [known, pickable] - name: energy display: char: 'E' description: - The result of burning a coal briquettte. - properties: [portable] + properties: [pickable] - name: repro kit display: char: 'k' description: - Kit that can be unpacked into everything a robot needs to reproduce. - properties: [known, portable] + properties: [known, pickable] recipes: - in: - [1, repro kit] @@ -174,8 +172,6 @@ - [1, energy] required: - [1, furnace] - - known: [boulder, lignite mine] seed: 0 world: 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 @@ -4,9 +4,8 @@ description: In this quirky challenge, you move as the chess knight piece. Can you capture the enemy king? objectives: - goal: - - Robots can use the `move` command to move. - But they only `turn` in cardinal directions. - - You are special. You are a knight. + - Robots can use the `move` command to move. But they only `turn` in cardinal directions. + - You are special. You are a knight. - Go forth and capture the King! condition: | try { @@ -19,8 +18,8 @@ move; move; move; turn right; move; turn left; move; robots: - name: horse - loc: [0,0] - dir: [2,-1] + loc: [0, 0] + dir: [2, -1] devices: - treads - logger @@ -28,8 +27,8 @@ display: char: '♘' - name: king - loc: [7,-6] - dir: [0,0] + loc: [7, -6] + dir: [0, 0] display: char: '♚' known: [water] 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 @@ -22,7 +22,7 @@ as base {has "bitcoin"}; robots: - name: base - dir: [1, 0] + dir: east display: invisible: false devices: @@ -44,13 +44,13 @@ - treads - name: lockbot system: true - dir: [1, 0] + dir: east display: invisible: true program: | run "scenarios/Challenges/_combo-lock/setup.sw" solution: | - run "scenarios/Challenges/_combo-lock/solution.sw" + run "scenarios/Challenges/_combo-lock/solution.sw" entities: - name: gate display: @@ -81,25 +81,25 @@ properties: [known] recipes: - in: - - [1, "dial (R)"] + - [1, "dial (R)"] out: - - [1, "dial (G)"] + - [1, "dial (G)"] required: - - [1, drill] + - [1, drill] time: 0 - in: - - [1, "dial (G)"] + - [1, "dial (G)"] out: - - [1, "dial (B)"] + - [1, "dial (B)"] required: - - [1, drill] + - [1, drill] time: 0 - in: - - [1, "dial (B)"] + - [1, "dial (B)"] out: - - [1, "dial (R)"] + - [1, "dial (R)"] required: - - [1, drill] + - [1, drill] time: 0 known: [boulder, water, bitcoin] world: diff --git a/data/scenarios/Challenges/dimsum.yaml b/data/scenarios/Challenges/dimsum.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/dimsum.yaml @@ -0,0 +1,157 @@ +version: 1 +name: Dim sum +creative: false +description: Serve restaurant patrons with the dim sum cart. +objectives: + - goal: + - It is the grand opening of Sigma (Σ), the hot new dim sum restaurant in town. You are the solitary wait staff. + - It seems that the manager went a bit overboard on furniture; there are dozens of `table`{=entity}s, but hardly any room to walk! + - Serve the blue patron with a `full cart`{=entity} (f) of food, twice. + - The `empty cart`{=entity} (e) must be `push`ed to the northwest corner for the cook to load it with food. + condition: | + p <- robotnamed "patron"; + as p { + foodCount <- count "food"; + return $ foodCount >= 2; + } +solution: | + run "scenarios/Challenges/_dimsum/solution.sw" +robots: + - name: base + dir: [1, 0] + devices: + - branch predictor + - ADT calculator + - compass + - comparator + - dictionary + - grabber + - lambda + - logger + - net + - scanner + - strange loop + - treads + - dozer blade + - name: cook + dir: [0, -1] + system: false + display: + invisible: false + attr: red + devices: + - ADT calculator + - branch predictor + - comparator + - dictionary + - lambda + - logger + - rolex + - scanner + - spatula + program: | + run "scenarios/Challenges/_dimsum/cook.sw" + - name: patron + dir: [0, 1] + system: false + display: + invisible: false + attr: blue + devices: + - ADT calculator + - branch predictor + - comparator + - dictionary + - lambda + - logger + - rolex + - scanner + - strange loop + - fork + inventory: + - [2, bitcoin] + program: | + run "scenarios/Challenges/_dimsum/patron.sw" +entities: + - name: table + display: + attr: wood + char: 't' + description: + - Pushable table + properties: [known, pushable] + - name: spatula + display: + char: 's' + description: + - Serving utensil for the cart + properties: [known, pickable] + - name: fork + display: + char: 'k' + description: + - Eating utensil for patron + properties: [known, pickable] + - name: food + display: + char: 'f' + description: + - Food from the cart + properties: [known, pickable] + - name: empty cart + display: + attr: copper + char: 'e' + description: + - Food cart + properties: [known, pushable] + - name: full cart + display: + attr: gold + char: 'f' + description: + - Food cart + properties: [known, pushable] +recipes: + - in: + - [1, empty cart] + out: + - [1, full cart] + required: + - [1, spatula] + - in: + - [1, full cart] + out: + - [1, empty cart] + - [1, food] + required: + - [1, fork] +known: [boulder, bitcoin] +world: + dsl: | + {grass} + palette: + 'B': [grass, erase, base] + '.': [grass, erase] + 'S': [dirt, erase] + '@': [grass, boulder] + 'd': [grass, table] + 'k': [grass, table, cook] + 'p': [grass, table, patron] + 's': [grass, empty cart] + 'x': [stone, erase] + upperleft: [0, 0] + map: | + .@@@......... + .@k@@@@@@@@x@ + .@Bddddddddd@ + .@dxxxxxxxd@@ + .@dxSSSSSxd@. + .@dxxSxxxxd@. + .@dxxxSxxxd@. + .@dxxSxxxxd@. + .@dxSSSSSxd@. + @@dxxxxxxxd@. + @ddddddddds@. + @x@@@@@@@@p@. + .........@@@. 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 @@ -10,7 +10,7 @@ char: 'Ω' attr: robot heavy: true - dir: [0, 1] + dir: north devices: - 3D printer - ADT calculator @@ -47,7 +47,7 @@ - [10, calculator] - name: cat system: true - dir: [-1, 0] + dir: west display: invisible: false char: 'c' @@ -58,9 +58,7 @@ run "scenarios/Challenges/_friend/cat.sw" objectives: - goal: - - There's a cat wandering around in the field. Bring it back to - your base. If you give it something it likes, perhaps you can - get it to follow you. + - There's a cat wandering around in the field. Bring it back to your base. If you give it something it likes, perhaps you can get it to follow you. condition: | c <- robotNamed "cat"; catLoc <- as c {whereami}; @@ -74,8 +72,7 @@ char: 'f' description: - A smelly fish. Rather unappetizing to a robot. - properties: [known, portable] - + properties: [known, pickable] known: [fish] seed: 0 world: diff --git a/data/scenarios/Challenges/gallery.yaml b/data/scenarios/Challenges/gallery.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/gallery.yaml @@ -0,0 +1,263 @@ +version: 1 +name: Art museum +author: Karl Ostmo +description: | + Rearrange sculpture exhibit +creative: false +attrs: + - name: bust1 + fg: "#008800" + - name: bust2 + fg: "#ff8888" + - name: bust3 + fg: "#0000ff" + - name: bust4 + fg: "#880088" + - name: bust5 + fg: "#884444" + - name: bust6 + fg: "#00ffff" + - name: bust7 + fg: "#880000" + - name: bust8 + fg: "#ff0000" + - name: bust9 + fg: "#000088" + - name: bust10 + fg: "#884488" + - name: bust11 + fg: "#ffff00" + - name: bust12 + fg: "#008888" + - name: bust13 + fg: "#ff00ff" + - name: bust14 + fg: "#448844" + - name: bust15 + fg: "#444488" + - name: bust16 + fg: "#00ff00" +objectives: + - teaser: Rearrange + goal: + - | + A prankster has wreaked mischief in the hall of presidential busts! + The sculptures just happen now to be in order of your personal presidential preference. + - | + Put the exhibits back into chronological order before the museum opens. + - | + The museum also sells replicas, and it so happens that the inventory of earlier + presidents are invariably understocked relative to later ones. + condition: | + def ensureMonotonicDecreasing = \itemCount. \prevOrdinal. + maybeEntity <- scan down; + case maybeEntity (\_. return $ itemCount == 0) (\item. + myCount <- count item; + if (myCount <= prevOrdinal) { + move; + ensureMonotonicDecreasing (itemCount - 1) myCount; + } { + return false; + }; + ); + 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; + } { + return false; + } + }; +robots: + - name: base + dir: east + devices: + - ADT calculator + - branch predictor + - comparator + - counter + - dozer blade + - dictionary + - Elmer's glue + - lambda + - linotype + - logger + - keyboard + - scanner + - strange loop + - treads + - name: judge + system: true + dir: east + display: + invisible: true + program: | + run "scenarios/Challenges/_gallery/setup.sw" +solution: | + run "scenarios/Challenges/_gallery/solution.sw" +entities: + - name: wall + display: + char: 'w' + description: + - Building boundary + properties: [known, unwalkable] + - name: George Washington + display: + char: '@' + attr: bust1 + description: + - The first president + properties: [known, pushable] + tags: [bust] + - name: John Adams + display: + char: '@' + attr: bust2 + description: + - The second president + properties: [known, pushable] + tags: [bust] + - name: Thomas Jefferson + display: + char: '@' + attr: bust3 + description: + - The third president + properties: [known, pushable] + tags: [bust] + - name: James Madison + display: + char: '@' + attr: bust4 + description: + - The fourth president + properties: [known, pushable] + tags: [bust] + - name: James Monroe + display: + char: '@' + attr: bust5 + description: + - The fifth president + properties: [known, pushable] + tags: [bust] + - name: John Quincy Adams + display: + char: '@' + attr: bust6 + description: + - The sixth president + properties: [known, pushable] + tags: [bust] + - name: Andrew Jackson + display: + char: '@' + attr: bust7 + description: + - The seventh president + properties: [known, pushable] + tags: [bust] + - name: Martin Van Buren + display: + char: '@' + attr: bust8 + description: + - The eighth president + properties: [known, pushable] + tags: [bust] + - name: William Henry Harrison + display: + char: '@' + attr: bust9 + description: + - The ninth president + properties: [known, pushable] + tags: [bust] + - name: John Tyler + display: + char: '@' + attr: bust10 + description: + - The tenth president + properties: [known, pushable] + tags: [bust] + - name: James K. Polk + display: + char: '@' + attr: bust11 + description: + - The eleventh president + properties: [known, pushable] + tags: [bust] + - name: Zachary Taylor + display: + char: '@' + attr: bust12 + description: + - The twelfth president + properties: [known, pushable] + tags: [bust] + - name: Millard Fillmore + display: + char: '@' + attr: bust13 + description: + - The thirteenth president + properties: [known, pushable] + tags: [bust] + - name: Franklin Pierce + display: + char: '@' + attr: bust14 + description: + - The fourteenth president + properties: [known, pushable] + tags: [bust] + - name: James Buchanan + display: + char: '@' + attr: bust15 + description: + - The fifteenth president + properties: [known, pushable] + tags: [bust] + - name: Abraham Lincoln + display: + char: '@' + attr: bust16 + description: + - The sixteenth president + properties: [known, pushable] + tags: [bust] +known: [] +world: + dsl: | + overlay + [ {terrain: stone} + , if (x/5 + (-y)/5) % 2 == 0 then {terrain: dirt} else {blank} + , 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] + 'x': [stone] + 'd': [dirt] + '.': [stone] + 'w': [stone, wall] + map: | + wwwwwwwwwwwwwwwwwwwwwwwwww + w........................w + w...dddddddddddddddddd...w + w.B.djxxxxxxxxxxxxxxxd...w + w...dddddddddddddddddd...w + w........................w + wwwwwwwwwwwwwwwwwwwwwwwwww 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 @@ -41,7 +41,7 @@ loc: [-1, 1] display: attr: blue - dir: [1, 0] + dir: east devices: - ADT calculator - 3D printer @@ -77,7 +77,7 @@ - [120, flower] - name: gopher system: true - dir: [0, 1] + dir: north display: char: 'G' invisible: false @@ -110,14 +110,14 @@ capabilities: [turn] description: - Allows a robot to "turn" but not "move". - properties: [known, portable] + properties: [known, pickable] - name: uranium display: char: 'U' attr: silver description: - Unearthed by industrious gophers. - properties: [known, portable] + properties: [known, pickable] recipes: - in: - [1, mound] @@ -126,7 +126,7 @@ required: - [1, drill] solution: | - run "scenarios/Challenges/_gopher/solution.sw" + run "scenarios/Challenges/_gopher/solution.sw" known: [] world: dsl: | 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 @@ -45,7 +45,7 @@ hasPowerup <- as ghost { has "donut"; }; - + if hasPowerup { return true; } { @@ -76,7 +76,7 @@ - | Be teleported condition: | - r <- robotnamed "teleporter"; + r <- robotnamed "teleport_monitor"; loc <- as r { has "bit (0)" }; @@ -104,7 +104,7 @@ hasPowerup <- as ghost { has "donut"; }; - + if hasPowerup { if (n > 1) { allHasPowerup $ n - 1; @@ -127,7 +127,7 @@ south: 'n' char: 'U' attr: gold - dir: [1, 0] + dir: east devices: - ADT calculator - antenna @@ -149,16 +149,16 @@ - strange loop - treads - workbench - - name: teleporter - dir: [0, 1] + - name: teleport_monitor + dir: north system: true display: invisible: true char: 'T' program: | - run "scenarios/Challenges/_hackman/teleporter.sw" + run "scenarios/Challenges/_hackman/teleport_monitor.sw" - name: ghost1 - dir: [0, 1] + dir: north system: true display: invisible: false @@ -167,7 +167,7 @@ program: | run "scenarios/Challenges/_hackman/ghost.sw" - name: ghost2 - dir: [0, 1] + dir: north system: true display: invisible: false @@ -176,7 +176,7 @@ program: | run "scenarios/Challenges/_hackman/ghost.sw" - name: ghost3 - dir: [0, 1] + dir: north system: true display: invisible: false @@ -185,7 +185,7 @@ program: | run "scenarios/Challenges/_hackman/ghost.sw" - name: ghost4 - dir: [0, 1] + dir: north system: true display: invisible: false @@ -194,7 +194,7 @@ program: | run "scenarios/Challenges/_hackman/ghost.sw" - name: fruit_maker - dir: [0, 1] + dir: north system: true display: invisible: true @@ -211,7 +211,7 @@ description: - A caffeine pellet. - Helps Hackman produce more code. - properties: [known, portable] + properties: [known, pickable] - name: donut display: char: 'o' @@ -219,14 +219,14 @@ description: - Breakfast of champions. - Fancied by ghosts. Will you share? - properties: [known, portable] + properties: [known, pickable] - name: den key display: char: 'k' attr: gold description: - Opens a gate - properties: [known, portable] + properties: [known, pickable] - name: strawberry display: char: 'v' @@ -234,7 +234,7 @@ description: - A tart berry - Possessing this fruit gives you great satisfaction. - properties: [known, portable] + properties: [known, pickable] - name: gate display: char: '=' @@ -249,17 +249,17 @@ properties: [known, unwalkable] recipes: - in: - - [181, "pellet"] + - [181, "pellet"] out: - - [1, "den key"] + - [1, "den key"] - in: - - [1, "den key"] - - [1, "gate"] + - [1, "den key"] + - [1, "gate"] out: - - [1, "den key"] + - [1, "den key"] required: - - [1, drill] -solution: + - [1, drill] +solution: | run "scenarios/Challenges/_hackman/solution.sw" known: [] seed: 0 @@ -272,10 +272,10 @@ 'b': [blank, null, ghost2] 'c': [blank, null, ghost3] 'd': [blank, null, ghost4] - 'T': [blank, null, teleporter] '.': [blank, pellet] '*': [blank, donut] 'x': [blank, wall] + 'T': [blank, null, teleport_monitor] '=': [blank, gate] '┌': [stone, upper left corner] '┐': [stone, upper right corner] @@ -283,27 +283,50 @@ '┘': [stone, lower right corner] '─': [stone, horizontal wall] '│': [stone, vertical wall] - upperleft: [-11, 10] + 'W': + cell: [blank] + waypoint: + name: western_exit + 'X': + cell: [blank] + waypoint: + name: western_entrance + 'Y': + cell: [blank] + waypoint: + name: eastern_exit + 'Z': + cell: [blank] + waypoint: + name: eastern_entrance + portals: + - entrance: eastern_entrance + exitInfo: + exit: western_exit + - entrance: western_entrance + exitInfo: + exit: eastern_exit + upperleft: [-12, 10] map: |- - xxxxxxxxxxxxxxxxxxxxxxx - x..........x..........x - x*xxx.xxxx.x.xxxx.xxx*x - x.xxx.xxxx.x.xxxx.xxx.x - x.....................x - x.xxx.x.xxxxxxx.x.xxx.x - x.....x....x....x.....x - xxxxx.xxxxBxBxxxx.xxxxx - BBBBx.xBBBBBBBBBx.xBBBB - xxxxx.xB┌──=──┐Bx.xxxxx - TBBBB.BB│abBcd│BB.BBBBT - xxxxx.xB└─────┘Bx.xxxxx - BBBBx.xBBBfΩBBBBx.xBBBB - xxxxx.xBxxxxxxxBx.xxxxx - x..........x..........x - x.xxx.xxxx.x.xxxx.xxx.x - x*..x.............x..*x - xxx.x.x.xxxxxxx.x.x.xxx - x.....x....x....x.....x - x.xxxxxxxx.x.xxxxxxxx.x - x.....................x - xxxxxxxxxxxxxxxxxxxxxxx + BxxxxxxxxxxxxxxxxxxxxxxxT + Bx..........x..........xB + Bx*xxx.xxxx.x.xxxx.xxx*xB + Bx.xxx.xxxx.x.xxxx.xxx.xB + Bx.....................xB + Bx.xxx.x.xxxxxxx.x.xxx.xB + Bx.....x....x....x.....xB + Bxxxxx.xxxxBxBxxxx.xxxxxB + BBBBBx.xBBBBBBBBBx.xBBBBB + Bxxxxx.xB┌──=──┐Bx.xxxxxB + ZYBBBB.BB│abBcd│BB.BBBBWX + Bxxxxx.xB└─────┘Bx.xxxxxB + BBBBBx.xBBBfΩBBBBx.xBBBBB + Bxxxxx.xBxxxxxxxBx.xxxxxB + Bx..........x..........xB + Bx.xxx.xxxx.x.xxxx.xxx.xB + Bx*..x.............x..*xB + Bxxx.x.x.xxxxxxx.x.x.xxxB + Bx.....x....x....x.....xB + Bx.xxxxxxxx.x.xxxxxxxx.xB + Bx.....................xB + BxxxxxxxxxxxxxxxxxxxxxxxB 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 @@ -4,10 +4,8 @@ description: The classic Towers of Hanoi puzzle with three disks. objectives: - goal: - - Move all the numbers (traditionally, "disks") from the - left column to the right column. - - You may only pick up one disk at a time, and you may never - place a larger disk on top of a smaller one. + - Move all the numbers (traditionally, "disks") from the left column to the right column. + - You may only pick up one disk at a time, and you may never place a larger disk on top of a smaller one. condition: | teleport self (2,-1); x <- ishere "one"; @@ -20,7 +18,7 @@ run "scenarios/Challenges/_hanoi/hanoi-solution.sw" robots: - name: base - dir: [0,-1] + dir: south devices: - net - treads @@ -35,17 +33,17 @@ - scanner - ADT calculator - name: invariant - dir: [0,0] + dir: [0, 0] system: true devices: - - logger + - logger inventory: - - [1, one] - - [1, two] - - [1, three] - - [1, blocked one] - - [1, blocked two] - - [1, blocked three] + - [1, one] + - [1, two] + - [1, three] + - [1, blocked one] + - [1, blocked two] + - [1, blocked three] program: | // if // 0. I stand on locked X @@ -62,12 +60,12 @@ // - lock X run "scenarios/Challenges/_hanoi/hanoi-invariant.sw" - name: increasing - dir: [0,0] + dir: [0, 0] system: true inventory: - - [1, OK] + - [1, OK] devices: - - logger + - logger program: | // if // 0. all (but max 3) disks in my column are sorted @@ -77,13 +75,13 @@ // - try to grab "OK" run "scenarios/Challenges/_hanoi/hanoi-increasing.sw" - name: count - dir: [0,0] + dir: [0, 0] system: true inventory: - - [1, two] - - [0, three] + - [1, two] + - [0, three] devices: - - logger + - logger program: | // count all entities placed in columns // the final count should be either 2 or 3 @@ -95,49 +93,49 @@ char: '┴' attr: entity description: - - A bottom tee wall. + - A bottom tee wall. properties: [unwalkable] - name: three display: char: '3' attr: gold description: - - A disk of radius 3. - properties: [portable] + - A disk of radius 3. + properties: [pickable] - name: two display: char: '2' attr: gold description: - - A disk of radius 2. - properties: [portable] + - A disk of radius 2. + properties: [pickable] - name: one display: char: '1' attr: gold description: - - A disk of radius 1. - properties: [portable] + - A disk of radius 1. + properties: [pickable] - name: blocked one display: char: '1' attr: entity description: - - A disk of radius 1. + - A disk of radius 1. properties: [unwalkable] - name: blocked two display: char: '2' attr: entity description: - - A disk of radius 2. + - A disk of radius 2. properties: [unwalkable] - name: blocked three display: char: '3' attr: entity description: - - A disk of radius 3. + - A disk of radius 3. properties: [unwalkable] - name: OK display: @@ -174,7 +172,6 @@ '.': [stone, null, invariant] '^': [grass, null, increasing] 'X': [grass, three, count] - upperleft: [-3, 1] map: | ┌─────┐ 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 @@ -38,7 +38,7 @@ }; robots: - name: base - dir: [0, 1] + dir: north devices: - branch predictor - treads @@ -61,7 +61,7 @@ - [5000, vanilla] - name: customer system: true - dir: [0, -1] + dir: south display: invisible: false attr: 'iron' @@ -70,26 +70,26 @@ program: | run "scenarios/Challenges/_ice-cream/customer.sw" solution: | - run "scenarios/Challenges/_ice-cream/solution.sw" + run "scenarios/Challenges/_ice-cream/solution.sw" entities: - name: scoop display: char: '@' description: - A single scoop of vanilla ice cream - properties: [portable] + properties: [pickable] - name: cherry display: char: '6' attr: 'red' - properties: [portable] + properties: [pickable] description: - A traditional ice cream garnish - name: Counter display: char: '▒' attr: 'sand' - properties: [portable, known] + properties: [pickable, known] capabilities: [count] description: - Where customers are served. @@ -98,42 +98,42 @@ display: char: 'V' attr: 'sand' - properties: [portable] + properties: [pickable] description: - A conical, edible container for ice cream - name: egg display: char: 'e' attr: 'gold' - properties: [portable] + properties: [pickable] description: - Organic from local, free-range, meticulously pampered chickens. - name: milk display: char: 'm' attr: 'silver' - properties: [portable] + properties: [pickable] description: - Pasteurized, homogenized, commoditized, metabolized. - name: ice display: char: 'i' attr: 'snow' - properties: [portable] + properties: [pickable] description: - Ice cream is better cold, don't you think? - name: sugar display: char: 's' attr: 'snow' - properties: [portable] + properties: [pickable] description: - Basis of most desserts - name: vanilla display: char: 'v' attr: 'wood' - properties: [portable] + properties: [pickable] description: - Traditional ice cream flavoring - name: briefcase @@ -141,7 +141,7 @@ char: 'B' attr: rubber capabilities: [sum, prod] - properties: [portable] + properties: [pickable] description: - Standard business accoutrement. - Particularly useful for `meet`-ings. @@ -211,7 +211,6 @@ upperleft: [0, 0] offset: false palette: - '@': [stone, boulder] '.': [grass] ':': [stone] 'B': [stone, briefcase] @@ -243,4 +242,3 @@ ┌─┐x┌──┐..^^^^ │B:Ω:V6│..\ZZ/ └──────┘...\/. - 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 @@ -66,7 +66,7 @@ }; robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - antenna @@ -90,13 +90,13 @@ - workbench - name: judge system: true - dir: [1, 0] + dir: east display: invisible: true program: | run "scenarios/Challenges/_lights-out/assistant.sw"; solution: | - run "scenarios/Challenges/_lights-out/solution.sw" + run "scenarios/Challenges/_lights-out/solution.sw" entities: - name: pending-off display: @@ -150,7 +150,6 @@ z: [blank, null, judge] '.': [blank] 'x': [blank, "off"] - 'o': [blank, "on"] map: | B...... .xxxxx. @@ -159,4 +158,3 @@ .xxxxx. .xxxxx. z...... - 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 @@ -25,7 +25,7 @@ as monitor {has "dizzy"}; robots: - name: base - dir: [0, 1] + dir: north devices: - branch predictor - treads @@ -44,7 +44,7 @@ - strange loop - name: monitor system: true - dir: [0, 1] + dir: north display: invisible: true inventory: @@ -56,14 +56,14 @@ program: | run "scenarios/Challenges/_maypole/monitor.sw" solution: | - run "scenarios/Challenges/_maypole/solution.sw" + run "scenarios/Challenges/_maypole/solution.sw" entities: - name: dizzy display: char: '@' description: - A disorienting vestibular affliction - properties: [portable] + properties: [pickable] - name: maypole display: char: 'M' @@ -117,4 +117,3 @@ .........B...... ................ ................ - diff --git a/data/scenarios/Challenges/pack-tetrominoes.yaml b/data/scenarios/Challenges/pack-tetrominoes.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/pack-tetrominoes.yaml @@ -0,0 +1,147 @@ +version: 1 +name: Tetrominoes +description: | + Pack tetrominoes into a rectangle +creative: false +attrs: + - name: q-tile + fg: "#ffff00" + - name: z-tile + fg: "#ff0000" + - name: i-tile + fg: "#00ffff" + - name: j-tile + fg: "#0000ff" + - name: t-tile + fg: "#ff00ff" +objectives: + - teaser: Place all + goal: + - | + Place all five tetrominoes. + condition: | + def found = \s. + fs <- structure s 0; + return $ case fs (\_. false) (\_. true); + end; + + foundT <- found "tee"; + foundJ <- found "jay"; + foundI <- found "line"; + foundZ <- found "zee"; + foundQ <- found "square"; + return $ foundT && foundJ && foundI && foundZ && foundQ; +robots: + - name: base + dir: east + devices: + - grabber + - treads + inventory: + - [4, z-tile] + - [4, j-tile] + - [4, i-tile] + - [4, q-tile] + - [4, t-tile] +entities: + - name: q-tile + display: + char: 'q' + attr: q-tile + description: + - q-tile + properties: [known, pickable] + - name: j-tile + display: + char: 'j' + attr: j-tile + description: + - j-tile + properties: [known, pickable] + - name: i-tile + display: + char: 'i' + attr: i-tile + description: + - i-tile + properties: [known, pickable] + - name: t-tile + display: + char: 't' + attr: t-tile + description: + - t-tile + properties: [known, pickable] + - name: z-tile + display: + char: 'z' + attr: z-tile + description: + - z-tile + properties: [known, pickable] +solution: | + run "scenarios/Challenges/_pack-tetrominoes/solution.sw" +structures: + - name: tee + recognize: [north, south, east, west] + description: "Tee tetromino" + structure: + mask: '.' + palette: + 'x': [stone, t-tile] + map: | + .x. + xxx + - name: square + recognize: [north] + description: "Square tetromino" + structure: + mask: '.' + palette: + 'x': [stone, q-tile] + map: | + xx + xx + - name: line + recognize: [north, east] + description: "Line tetromino" + structure: + mask: '.' + palette: + 'x': [stone, i-tile] + map: | + xxxx + - name: jay + recognize: [north, east, south, west] + description: "Jay tetromino" + structure: + mask: '.' + palette: + 'x': [stone, j-tile] + map: | + xxx + ..x + - name: zee + recognize: [north, east] + description: "Zee tetromino" + structure: + mask: '.' + palette: + 'x': [stone, z-tile] + map: | + xx. + .xx +known: [boulder] +world: + name: root + dsl: | + {boulder} + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + upperleft: [0, 0] + map: | + ...... + ...... + ...... + B..... 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 @@ -18,8 +18,8 @@ turn back; move;move;move; w10; move;move;move; grab robots: - name: base - loc: [3,0] - dir: [1,0] + loc: [3, 0] + dir: east devices: - treads - logger @@ -29,8 +29,8 @@ - [0, lambda] - name: portkey1 system: true - loc: [0,0] - dir: [0,0] + loc: [0, 0] + dir: [0, 0] program: | def forever = \prog. wait 10; prog; forever prog; end; destRob <- robotNamed "portkey2"; @@ -42,8 +42,8 @@ ); - name: portkey2 system: true - loc: [16,0] - dir: [0,0] + loc: [16, 0] + dir: [0, 0] program: | def forever = \prog. wait 10; prog; forever prog; end; wait 5; 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 @@ -24,7 +24,7 @@ as base {x <- meet; return $ case x (\_. false) (\_. true)}; robots: - name: base - dir: [0, 1] + dir: north devices: - branch predictor - comparator @@ -40,7 +40,7 @@ - treads - name: wavebot system: true - dir: [0, 1] + dir: north display: invisible: false attr: 'plant' @@ -61,14 +61,14 @@ end; start; solution: | - run "scenarios/Challenges/_wave/solution.sw" + run "scenarios/Challenges/_wave/solution.sw" entities: [] known: [wavy water, water, bitcoin] world: dsl: | overlay [ {dirt, water} - , if (x + y / 2) % 5 == 0 then {dirt, wavy water} else {blank} + , if (x / 2 - y) % 5 == 0 then {dirt, wavy water} else {blank} ] upperleft: [-3, 6] offset: false @@ -86,4 +86,3 @@ x............................................................................................................................................................................................................................................................x xxx........................................................................................................................................................................................................................................................xxx xxxxxxwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwxxxxxx - diff --git a/data/scenarios/Challenges/wolf-goat-cabbage.yaml b/data/scenarios/Challenges/wolf-goat-cabbage.yaml --- a/data/scenarios/Challenges/wolf-goat-cabbage.yaml +++ b/data/scenarios/Challenges/wolf-goat-cabbage.yaml @@ -9,7 +9,7 @@ display: char: 'U' attr: wood - dir: [0, 1] + dir: north devices: - ADT calculator - branch predictor @@ -29,12 +29,12 @@ - boat - name: east_detector system: true - dir: [0, 1] + dir: north display: invisible: true - name: west_detector system: true - dir: [0, 1] + dir: north display: invisible: true objectives: @@ -51,7 +51,7 @@ previewable: true logic: not: - or: + or: - id: unattended_disaster - id: carrying_two_items - goal: @@ -70,7 +70,7 @@ condition: | run "data/scenarios/Challenges/_wolf-goat-cabbage/unattended-together.sw"; optional: true - hidden: true + hidden: true solution: | run "scenarios/Challenges/_wolf-goat-cabbage/cross.sw" entities: @@ -80,21 +80,21 @@ attr: silver description: - A wolf. Likes to eat goats. - properties: [known, portable] + properties: [known, pickable] - name: goat display: char: 'g' attr: sand description: - A goat. Likes to eat cabbage. - properties: [known, portable] + properties: [known, pickable] - name: cabbage display: char: 'c' attr: green description: - A cabbage. - properties: [known, portable] + properties: [known, pickable] known: [water, boulder] seed: 0 world: 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 @@ -7,204 +7,20 @@ creative: false objectives: - goal: - - Use the `drill` command (e.g. `drill down` when on top of the - intended letter) to mark the sequence of letters that - spells `C`{=entity}`O`{=entity}`W`{=entity} within the designated playfield. + - Use the `drill` command (e.g. `drill down` when on top of the intended letter) to mark the sequence of letters that spells `C`{=entity}`O`{=entity}`W`{=entity} within the designated playfield. - | The sequence may appear horizontally in either the leftward or rightward direction, or vertically in either the upward or downward direction. Diagonal appearances are not valid. condition: | - /** - Algorithm: - We only need to check the base's - current position: if we find three contiguous highlights, - then we know that the player has just completed their - third highlight. - */ - - def whichOrdinal = - isC <- ishere "lowercase c"; - if (isC) { - return 0; - } { - isO <- ishere "lowercase o"; - if (isO) { - return 1; - } { - isW <- ishere "lowercase w"; - if (isW) { - return 2; - } { - return (-1); - } - } - } - end; - - - def whichHighlightedOrdinal = \str. - if (str == "lowercase c") { - return 0; - } { - if (str == "lowercase o") { - return 1; - } { - if (str == "lowercase w") { - return 2; - } { - return (-1); - } - } - } - end; - - def countConsecutive = \expectedOrdinal. \n. - - thisOrdinal <- whichOrdinal; - nextOrdinal <- if (thisOrdinal == expectedOrdinal) { - return $ expectedOrdinal + 1; - } { - return 0; - }; - - if (nextOrdinal == 3) { - return true; - } { - if (n > 1) { - move; - countConsecutive nextOrdinal $ n - 1; - } { - return false; - }; - }; - end; - - def checkBackAndForth = - - foundBackward <- countConsecutive 0 3; - if (foundBackward) { - return true; - } { - turn back; - countConsecutive 0 3; - } - end; - - def checkDirections = \n. - if (n > 0) { - wasFound <- checkBackAndForth; - if wasFound { - return true; - } { - turn left; - checkDirections $ n - 1; - } - } { - return false; - } - end; - - def isMarkedInDirection = \d. - scanResult <- scan d; - ordinalNum <- case scanResult - (\_. return (-1)) - whichHighlightedOrdinal; - return $ ordinalNum >= 0; - end; - - /** - It's possible we could be one cell away from - a marked cell after finishing, either due - to using a directional `drill` command instead of - `drill down`, or due to an apparent bug which - does not evaluate the goal condition between the - `drill` and a `move` command. - */ - def moveToMarkedCell = \n. - if (n > 0) { - isMarkedAhead <- isMarkedInDirection forward; - if isMarkedAhead { - move; - return true; - } { - turn left; - moveToMarkedCell $ n - 1; - }; - } { - return false; - }; - end; - - /** - Orient ourselves such that - a marked cell is behind us. - */ - def findMarkBehind = \n. - if (n > 0) { - isMarkedBehind <- isMarkedInDirection back; - if isMarkedBehind { - return true; - } { - turn left; - findMarkBehind $ n - 1; - }; - } { - return false; - }; - end; - - /** - The cell we're on might be in the middle of a word, - rather than the end. Determine the orientation of - the line, then move along it until reaching the end. - - Algorithm: - 0. Assumption: we are currently on a marked cell. - 1. Turn in all all four directions to `scan back` - for a second marked cell. Stop turning if - we encounter one. - If none found after 4 turns, abort. - 2. `scan forward` to see if there is a marked cell in - the opposite direction. - `move` (foward) once if there is. Since the word - is only three cells long, this will be the other - end of it. - */ - def moveToWordExtrema = - foundCellBehind <- findMarkBehind 4; - if foundCellBehind { - isMarkedAhead <- isMarkedInDirection forward; - if isMarkedAhead { - move; - } {}; - } {}; - end; - - def checkSoln = - isMarkedHere <- isMarkedInDirection down; - atMarkedCell <- if isMarkedHere { - return true; - } { - moveToMarkedCell 4; - }; - - if atMarkedCell { - moveToWordExtrema; - checkDirections 4; - } { - return false; - } - end; - - as base {checkSoln}; - + foundStructure <- structure "cow" 0; + return $ case foundStructure (\_. false) (\_. true); robots: - name: base display: attr: flower - dir: [-1, 0] + dir: west devices: - treads - ADT calculator @@ -226,7 +42,7 @@ - [3, ink] - name: lettersetter system: true - dir: [1, 0] + dir: east display: invisible: true inventory: @@ -296,14 +112,24 @@ capabilities: [drill] description: - Instrument for marking found words - properties: [known, portable] + properties: [known, pickable] - name: ink display: char: 'K' attr: gold description: - Ink for marking found words - properties: [known, portable] + properties: [known, pickable] +structures: + - name: cow + recognize: [north, south, east, west] + structure: + palette: + 'c': [dirt, lowercase c] + 'o': [dirt, lowercase o] + 'w': [dirt, lowercase w] + map: | + cow recipes: - in: - [1, capital C] 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 @@ -1,2 +1,4 @@ GoL.yaml logo-burst.yaml +horton.yaml +snake.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 @@ -7,8 +7,8 @@ display: attr: robot char: 'Ω' - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - treads - compass @@ -19,7 +19,7 @@ - [1000, rock] - name: cell system: true - dir: [0,1] + dir: north display: invisible: true inventory: @@ -35,7 +35,7 @@ b <- scan back; return (cnt h + cnt f + cnt b) end; - def mod : int -> int -> int = \a. \b. a - (a/b)*b end; + def mod : Int -> Int -> Int = \a. \b. a - (a/b)*b end; def waitUntil = \p. b <- p; if b {wait 1} {waitUntil p} @@ -63,7 +63,7 @@ palette: 'o': [ice, rock, cell] '.': [ice, null, cell] - upperleft: [1,-1] + upperleft: [1, -1] map: | .............................. .............................. diff --git a/data/scenarios/Fun/_logo-burst/coordinator.sw b/data/scenarios/Fun/_logo-burst/coordinator.sw --- a/data/scenarios/Fun/_logo-burst/coordinator.sw +++ b/data/scenarios/Fun/_logo-burst/coordinator.sw @@ -1,4 +1,4 @@ -def forever : cmd unit -> cmd unit = \c. c ; forever c end +def forever : Cmd Unit -> Cmd Unit = \c. c ; forever c end def alternate = wait 50; 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 @@ -1,12 +1,12 @@ -def repeat : int -> cmd unit -> cmd unit = +def repeat : Int -> Cmd Unit -> Cmd Unit = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} end def abs = \n. if (n < 0) {-n} {n} end def elif = \t. \then. \else. {if t then else} end def else = \t. t end -def randdir : cmd dir = +def randdir : Cmd Dir = d <- random 4; return ( if (d == 0) {north} diff --git a/data/scenarios/Fun/_snake/snake.sw b/data/scenarios/Fun/_snake/snake.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Fun/_snake/snake.sw @@ -0,0 +1,160 @@ +/** +Uses a string to maintain a queue of coordinates. +*/ + +def coordsToString : (Int * Int) -> Text = \coords. + format (fst coords) ++ "," ++ format (snd coords) + end + +def indexOfRec : Int -> Text -> Text -> (Unit + Int) = \pos. \inputString. \targetChar. + if (pos >= chars inputString) { + inL () + } { + if (toChar (charAt pos inputString) == targetChar) { + inR pos + } { + indexOfRec (pos + 1) inputString targetChar + } + } + end + +def indexOf : Text -> Text -> (Unit + Int) = + indexOfRec 0 + end + +// Drops the first character of a string +def strTail : Text -> Text = \inputString. + snd $ split 1 inputString + 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) + ) + end + +def getDecimalCharValue = \inputString. \idx. + charAt idx inputString - charAt 0 "0" + end + +// Works from right to left +def parseDecimalRec : Int -> Text -> Int = \charsRemaining. \inputString. + if (charsRemaining > 0) { + getDecimalCharValue inputString (charsRemaining - 1) + 10 * parseDecimalRec (charsRemaining - 1) inputString + } {0} + end + +def parseDecimal : Text -> Int = \inputString. + let isNegative = toChar (charAt 0 inputString) == "-" in + let negationMultiplier = if isNegative {-1} {1} in + let modifiedString = if isNegative {strTail inputString} {inputString} in + let stringLength = chars modifiedString in + negationMultiplier * parseDecimalRec stringLength modifiedString; + end + +// 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) + end + +// APPEND to string representation of a coordinate list +def snoc : (Int * Int) -> Text -> Text = \coords. \strList. + let delimiter = if (chars strList > 0) {";"} {""} in + strList ++ delimiter ++ coordsToString coords; + end + +// Extracts the first element and returns the shortened list +def pop : Text -> (Unit + ((Int * Int) * Text)) = \strList. + if (chars strList > 0) { + let pair = splitOnFirstChar strList ";" in + inR (stringToCoords $ fst pair, snd pair) + } { + inL (); + } + end + +def getDir = \dest. + path (inL ()) (inL dest); + end; + +def doAtLoc = \currLoc. \targetLoc. \func. + teleport self targetLoc; + x <- func; + teleport self currLoc; + return x; + end; + +def moveTail = \tailList. + emptyHere <- isempty; + if emptyHere { + let maybeShifted = pop tailList in + case maybeShifted (\_. + // Nothing to pick up or replace + return tailList; + + ) (\newPair. + + let farthestTail = fst newPair in + let newInit = snd newPair in + newLoc <- whereami; + grabbedItem <- doAtLoc newLoc farthestTail grab; + place grabbedItem; + + return $ snoc newLoc newInit; + ); + } { + return tailList; + } + end; + +def moveOneStep = \tailList. + + // This robot will always be sitting atop the apple + r <- robotnamed "spawn"; + targetLoc <- as r {whereami}; + + maybeD <- getDir targetLoc; + case maybeD (\_. say "Dead!"; return "") (\d. + turn $ fst d; + newList <- moveTail tailList; + move; + return newList + ); + end + +// Invariant: No tail pieces shall ever be moved underneath the +// snake robot, unless an apple was just picked up. +def moveToApple = \tailList. + + myLoc <- whereami; + + appleHere <- ishere "apple"; + if appleHere { + + modifiedTailList <- try { + make "tail"; + swap "tail"; + return $ snoc myLoc tailList; + } { + grab; + return tailList; + }; + // Need to move here so that we get out of the way + // if the tail gets elongated + moveOneStep modifiedTailList; + } { + moveOneStep tailList; + } + end; + +def go = \tailList. + newList <- instant $ moveToApple tailList; + go newList; + end; + +go ""; diff --git a/data/scenarios/Fun/_snake/spawn.sw b/data/scenarios/Fun/_snake/spawn.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Fun/_snake/spawn.sw @@ -0,0 +1,35 @@ +def waitForConsumption = + watch down; + wait 2000; + appleHere <- ishere "apple"; + if appleHere { + waitForConsumption; + } {} + end; + +// TODO Ensure we don't spawn inside a coil of the tail +def placeAtOpenLocation = \range. + randX <- random range; + randY <- random range; + let x = range/2 - randX in + let y = range/2 - randY in + teleport self (x, y); + emptyHere <- isempty; + if emptyHere { + place "apple"; + } { + placeAtOpenLocation range; + } + end; + +def repeatedlyPlaceApple = \range. + placeAtOpenLocation range; + waitForConsumption; + end; + +def go = + instant $ repeatedlyPlaceApple 20; + go; + end; + +go; diff --git a/data/scenarios/Fun/horton.yaml b/data/scenarios/Fun/horton.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Fun/horton.yaml @@ -0,0 +1,96 @@ +version: 1 +name: Horton's Field +author: Karl Ostmo +seed: 1 +description: | + Horton picks all of the flowers +creative: false +objectives: + - goal: + - | + Pluck every flower. + condition: | + as base { + flowerCount <- count "flower"; + return $ flowerCount >= 399; + } +robots: + - name: Horton + dir: north + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - grabber + - hourglass + - clock + - lambda + - logger + - net + - scanner + - strange loop + - treads + - wayfinder +solution: | + def goDir = \f. \result. + let d = fst result in + if (d == down) {grab; f;} {turn d; move; f;} + end; + + def followRoute = + nextDir <- path (inL ()) (inR "flower"); + case nextDir return $ goDir followRoute; + end; + + followRoute; +entities: + - name: wayfinder + display: + char: 'w' + description: + - | + Enables the `path` command: + - | + `path : (Unit + Int) -> ((Int * Int) + Text) -> Cmd (Unit + (Dir * Int))` + - | + Optionally supply a distance limit as the first argument, and + supply either a location (`inL`) or an entity (`inR`) as the second argument. + - | + Example: + - | + `path (inL ()) (inR "tree");` + - If a path exists, returns the direction to proceed along. + properties: [known, pickable] + capabilities: [path] +known: [water, boulder, flower] +world: + dsl: | + let + cl = perlin seed 4 0.08 0.5, + patch = cl > 0.0, + prize = cl < -0.8 + in + overlay + [ {dirt} + , mask (patch) {boulder} + , mask (prize) {flower} + , mask (x < -80 || x > 80 || y < -60 || y > 60) (overlay [{water}]) + ] + upperleft: [-4, 4] + offset: false + palette: + 'B': [grass, erase, Horton] + '.': [grass, erase] + 'x': [blank] + map: | + xxx...xxx + x.......x + x.......x + ......... + ....B.... + ......... + x.......x + x.......x + xxx...xxx 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 @@ -10,7 +10,7 @@ - name: base display: invisible: true - dir: [1, 0] + dir: east devices: - logger - hearing aid @@ -18,42 +18,41 @@ system: true display: invisible: false - dir: [1, 0] + dir: east program: | run "scenarios/Fun/_logo-burst/drone.sw" - name: botUp system: true display: invisible: false - dir: [0, 1] + dir: north program: | run "scenarios/Fun/_logo-burst/drone.sw" - name: botLeft system: true display: invisible: false - dir: [-1, 0] + dir: west program: | run "scenarios/Fun/_logo-burst/drone.sw" - name: botDown system: true display: invisible: false - dir: [0, -1] + dir: south program: | run "scenarios/Fun/_logo-burst/drone.sw" - name: stoplight system: true display: invisible: false - dir: [0, 1] + dir: north devices: - lodestone inventory: - [1, bit (0)] program: | run "scenarios/Fun/_logo-burst/coordinator.sw" - known: [boulder, tree, water, wavy water] world: upperleft: [0, 0] @@ -73,11 +72,11 @@ 'v': [blank, null, botDown] map: | s v . - . . + . . . v<^vv<<@ ^^ vv >^v^T ^^^v< <>< v > T ^< >^ < >> v> v< >T <<▒^ @><> . - . <@v^^>> @v > v>> @v > v> >> v@ @@> << ~v < >~ ^~ >> @^ >v . - . >>^v^^^ < ~ T~v v< <~ >>T . - . ▒ . + . >>^v^^^ < ~ T~v v< <~ >>T . + . ▒ . . ^ ^ v > > . diff --git a/data/scenarios/Fun/snake.yaml b/data/scenarios/Fun/snake.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Fun/snake.yaml @@ -0,0 +1,122 @@ +version: 1 +name: Snake +author: Karl Ostmo +seed: 1 +description: | + Watch the snake eat the apples +creative: false +objectives: + - goal: + - | + Eat and "digest" many apples + condition: | + r <- robotnamed "snake"; + as r { + appleCoreCount <- count "apple core"; + return $ appleCoreCount >= 40; + } +robots: + - name: base + dir: north + devices: + - ADT calculator + - branch predictor + - clock + - comparator + - compass + - dictionary + - grabber + - hourglass + - hearing aid + - keyboard + - lambda + - logger + - net + - scanner + - strange loop + - string + - treads + - wayfinder + - name: snake + dir: north + system: true + display: + attr: green + invisible: false + devices: + - rattle + program: | + run "scenarios/Fun/_snake/snake.sw" + - name: spawn + dir: north + system: true + display: + invisible: true + inventory: + - [100, apple] + program: | + run "scenarios/Fun/_snake/spawn.sw" +solution: | + noop +entities: + - name: wayfinder + display: + char: 'w' + description: + - | + Enables the `path` command + properties: [known, pickable] + capabilities: [path] + - name: apple + display: + char: 'a' + attr: red + description: + - | + Tasty snack + properties: [known, pickable] + - name: apple core + display: + char: 'I' + attr: wood + description: + - | + Remains of an eaten apple + properties: [known, pickable] + - name: rattle + display: + char: 'r' + attr: green + description: + - | + Device unique to a snake + properties: [known] + - name: tail + display: + char: '@' + attr: green + description: + - | + Segment of snake's tail + properties: [known, unwalkable] +recipes: + - in: + - [3, apple] + out: + - [1, tail] + - [3, apple core] + required: + - [1, rattle] +known: [] +world: + dsl: | + {grass} + upperleft: [0, 0] + palette: + 'B': [grass, erase, base] + 'S': [grass, erase, snake] + 's': [grass, erase, spawn] + '.': [grass, erase] + map: | + B.. + s.S diff --git a/data/scenarios/Mechanics/active-trapdoor.yaml b/data/scenarios/Mechanics/active-trapdoor.yaml --- a/data/scenarios/Mechanics/active-trapdoor.yaml +++ b/data/scenarios/Mechanics/active-trapdoor.yaml @@ -19,7 +19,7 @@ display: char: 'ω' attr: robot - dir: [0, 1] + dir: north devices: - treads - 3D printer @@ -43,7 +43,7 @@ - [1, treads] - name: gate system: true - dir: [0, 1] + dir: north display: invisible: true inventory: 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 @@ -1,16 +1,15 @@ version: 1 name: Curry author: Brent Yorgey -description: Race to make a bowl of `curry`{=entity} as quickly as possible. - See the Swarm wiki for more information on Swarm speedrunning. +description: Race to make a bowl of `curry`{=entity} as quickly as possible. See the Swarm wiki for more information on Swarm speedrunning. objectives: - goal: - Make a bowl of curry as quickly as possible! condition: as base {has "curry"} robots: - name: base - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north heavy: true display: char: Ω @@ -19,6 +18,7 @@ - 3D printer - dictionary - grabber + - welder - life support system - logger - toolkit @@ -31,6 +31,7 @@ - [70, grabber] - [100, solar panel] - [50, scanner] + - [50, clock] - [5, toolkit] world: offset: true 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 @@ -1,16 +1,15 @@ version: 1 name: Forester author: Brent Yorgey -description: Race to harvest 1024 `tree`{=entity}s as quickly as possible. - See the Swarm wiki for more information on Swarm speedrunning. +description: Race to harvest 1024 `tree`{=entity}s as quickly as possible. See the Swarm wiki for more information on Swarm speedrunning. objectives: - goal: - Harvest 1024 `tree`{=entity}s as quickly as possible! condition: as base {n <- count "tree"; return (n >= 1024)} robots: - name: base - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north heavy: true display: char: Ω @@ -19,6 +18,7 @@ - 3D printer - dictionary - grabber + - welder - life support system - logger - toolkit @@ -31,6 +31,7 @@ - [70, grabber] - [100, solar panel] - [50, scanner] + - [50, clock] - [5, toolkit] world: offset: true 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 @@ -1,16 +1,15 @@ version: 1 name: Mithril author: Brent Yorgey -description: Race to mine some `mithril`{=entity}. - See the Swarm wiki for more information on Swarm speedrunning. +description: Race to mine some `mithril`{=entity}. See the Swarm wiki for more information on Swarm speedrunning. objectives: - goal: - Mine some `mithril`{=entity} as quickly as possible! condition: as base {has "mithril"} robots: - name: base - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north heavy: true display: char: Ω @@ -19,6 +18,7 @@ - 3D printer - dictionary - grabber + - welder - life support system - logger - toolkit @@ -31,6 +31,7 @@ - [70, grabber] - [100, solar panel] - [50, scanner] + - [50, clock] - [5, toolkit] world: offset: true 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,16 +36,34 @@ 1218-stride-command.yaml 1234-push-command.yaml 1256-halt-command.yaml +1262-display-device-commands.yaml 1295-density-command.yaml 1138-structures 1320-world-DSL 1356-portals 144-subworlds 836-pathfinding +1569-pathfinding-cache 1341-command-count.yaml 1355-combustion.yaml 1379-single-world-portal-reorientation.yaml +1322-wait-with-instant.yaml +1598-detect-entity-change.yaml 1399-backup-command.yaml 1430-built-robot-ownership.yaml 1536-custom-unwalkable-entities.yaml +1721-custom-walkable-entities.yaml +1721-walkability-whitelist-path-cache.yaml 1535-ping +1575-structure-recognizer +1631-tags.yaml +1634-message-colors.yaml +1681-pushable-entity.yaml +1747-volume-command.yaml +1777-capability-cost.yaml +1775-custom-terrain.yaml +1642-biomes.yaml +1780-structure-merge-expansion +1533-sow-command.yaml +1533-sow-seed-maturation.yaml +231-requirements diff --git a/data/scenarios/Testing/1007-use-command.yaml b/data/scenarios/Testing/1007-use-command.yaml --- a/data/scenarios/Testing/1007-use-command.yaml +++ b/data/scenarios/Testing/1007-use-command.yaml @@ -17,7 +17,7 @@ grab; robots: - name: base - dir: [1,0] + dir: east display: char: Ω attr: robot @@ -28,34 +28,34 @@ - treads - welder entities: -- name: fence - display: - attr: wood - char: '#' - description: - - Impassable barrier - properties: [known, unwalkable] -- name: gate key - display: - attr: iron - char: 'k' - description: - - Can open a closed gate - properties: [known, portable] -- name: closed gate - display: - attr: wood - char: '|' - description: - - Cannot pass through this - properties: [known, unwalkable] -- name: open gate - display: - attr: wood - char: '/' - description: - - Can pass through this - properties: [known] + - name: fence + display: + attr: wood + char: '#' + description: + - Impassable barrier + properties: [known, unwalkable] + - name: gate key + display: + attr: iron + char: 'k' + description: + - Can open a closed gate + properties: [known, pickable] + - name: closed gate + display: + attr: wood + char: '|' + description: + - Cannot pass through this + properties: [known, unwalkable] + - name: open gate + display: + attr: wood + char: '/' + description: + - Can pass through this + properties: [known] recipes: - in: - [1, closed gate] @@ -74,8 +74,8 @@ 'k': [grass, gate key] upperleft: [0, 0] map: | - ...... - ..###. - Ωk|*#. - ..###. - ...... + ...... + ..###. + Ωk|*#. + ..###. + ...... 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 @@ -27,7 +27,7 @@ forever drill_for_sand robots: - name: base - dir: [1,0] + dir: east devices: - dictionary - logger @@ -40,6 +40,6 @@ palette: '>': [grass, null, base] 'Å': [stone, copper mine] - upperleft: [0,0] + upperleft: [0, 0] map: | >Å 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 @@ -1,9 +1,13 @@ version: 1 name: Rainbow color custom attributes description: | - Custom attributes with rainbow colors + Custom attributes with rainbow colors. + + Participates as a do-nothing integration test to ensure parseability. creative: false attrs: + - name: robotWithBackground + bg: "#880088" - name: rainbow1 fg: "#ffadad" - name: rainbow2 @@ -18,24 +22,46 @@ fg: "#a0c4ff" - name: rainbow7 fg: "#bdb2ff" + - name: rainbow1bg + bg: "#ffadad" + - name: rainbow2bg + bg: "#ffd6a5" + - name: rainbow3bg + bg: "#ffff96" + - name: rainbow4bg + bg: "#caffbf" + - name: rainbow5bg + bg: "#9bf6ff" + - name: rainbow6bg + bg: "#a0c4ff" + - name: rainbow7bg + bg: "#bdb2ff" - name: redOnYellow fg: "#ff0000" - bg: ffff00 + bg: "#ffff00" - name: cyanOnMagenta - fg: "#00ffff + fg: "#00ffff" bg: "#ff00ff" - name: greenForeground fg: "#00ff00" - name: blueBackround bg: "#0000ff" - name: italicAndUnderline + fg: "#ffffff" style: - Italic - Underline - name: boldAndStrikethrough + fg: "#ffffff" style: - Bold - Strikethrough +objectives: + - goal: + - Do nothing + condition: | + pos <- as base {whereami}; + return $ fst pos > 7; entities: - name: color1 display: @@ -86,6 +112,55 @@ description: - c7 properties: [known] + - name: color1bg + display: + char: ' ' + attr: rainbow1bg + description: + - c1bg + properties: [known] + - name: color2bg + display: + char: ' ' + attr: rainbow2bg + description: + - c2bg + properties: [known] + - name: color3bg + display: + char: ' ' + attr: rainbow3bg + description: + - c3bg + properties: [known] + - name: color4bg + display: + char: ' ' + attr: rainbow4bg + description: + - c4bg + properties: [known] + - name: color5bg + display: + char: ' ' + attr: rainbow5bg + description: + - c5bg + properties: [known] + - name: color6bg + display: + char: ' ' + attr: rainbow6bg + description: + - c6bg + properties: [known] + - name: color7bg + display: + char: ' ' + attr: rainbow7bg + description: + - c7bg + properties: [known] - name: color1f display: char: '█' @@ -177,9 +252,35 @@ description: - Bold and Strikethrough properties: [known] -robots: [] +robots: + - name: base + dir: east + devices: + - treads + - name: companion + dir: east + devices: + - treads + program: | + move; move; move; move; + move; move; move; move; + - name: companion2 + dir: east + display: + attr: robotWithBackground + devices: + - treads + program: | + move; move; move; move; + move; move; move; move; +solution: | + move; move; move; move; + move; move; move; move; world: palette: + 'Ω': [blank, null, base] + 'α': [blank, null, companion] + 'β': [blank, null, companion2] '.': [blank] '1': [blank, color1] '2': [blank, color2] @@ -188,6 +289,13 @@ '5': [blank, color5] '6': [blank, color6] '7': [blank, color7] + 'T': [blank, color1bg] + 'U': [blank, color2bg] + 'V': [blank, color3bg] + 'W': [blank, color4bg] + 'X': [blank, color5bg] + 'Y': [blank, color6bg] + 'Z': [blank, color7bg] 'a': [blank, color1f] 'b': [blank, color2f] 'c': [blank, color3f] @@ -203,7 +311,7 @@ 'B': [blank, boldStrikethrough] upperleft: [0, 0] map: |- - .1234567..Rzzy...IIy - .1234567y.R.z....... - .abcdefg......C..BBz - .abcdefgyy.yy..Cz.z. + α.1234567..Rzzy...IIy + Ω.TUVWXYZy.R.z....... + β.TUVWXYZ......C..BBz + α.abcdefgyy.yy..Cz.z. 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 @@ -5,7 +5,7 @@ robots: - name: base loc: [11, 0] - dir: [1, 0] + dir: east known: [flower, bit (0), bit (1)] world: palette: 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 @@ -5,7 +5,7 @@ robots: - name: base loc: [11, 0] - dir: [1, 0] + dir: east known: [tree, flower, bit (0), bit (1)] world: palette: diff --git a/data/scenarios/Testing/1138-structures/sibling-precedence.yaml b/data/scenarios/Testing/1138-structures/sibling-precedence.yaml --- a/data/scenarios/Testing/1138-structures/sibling-precedence.yaml +++ b/data/scenarios/Testing/1138-structures/sibling-precedence.yaml @@ -5,7 +5,7 @@ robots: - name: base loc: [11, 0] - dir: [1, 0] + dir: east known: [water, sand] world: palette: @@ -68,11 +68,11 @@ xx xx placements: - - src: tiny rectangle - - src: small rectangle - - src: medium rectangle - - src: big rectangle - src: huge rectangle + - src: big rectangle + - src: medium rectangle + - src: small rectangle + - src: tiny rectangle 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 @@ -22,7 +22,7 @@ ); robots: - name: base - dir: [0,1] + dir: north display: char: Ω attr: robot @@ -41,12 +41,12 @@ 'T': [grass, tree] upperleft: [-4, 4] map: | - ......... - ......... - ......... - ......... - ......T.. - ......... - ......... - .Ω....... - ......... + ......... + ......... + ......... + ......... + ......T.. + ......... + ......... + .Ω....... + ......... 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 @@ -11,7 +11,7 @@ case out return place; robots: - name: base - dir: [0,1] + dir: north display: char: Ω attr: robot @@ -28,31 +28,31 @@ 'x': [grass, gumball machine] upperleft: [-1, 2] map: | - ... - .x. - .Ω. - ... + ... + .x. + .Ω. + ... entities: - name: gumball machine display: attr: red char: 'G' description: - - Yields a gumball when drilled + - Yields a gumball when drilled properties: [unwalkable, known] - name: gumball display: attr: blue char: 'o' description: - - Dispensed from a gumball machine - properties: [portable] + - Dispensed from a gumball machine + properties: [pickable] recipes: - in: - - [1, gumball machine] + - [1, gumball machine] out: - - [1, gumball machine] - - [1, gumball] + - [1, gumball machine] + - [1, gumball] required: - - [1, drill] + - [1, drill] time: 1 diff --git a/data/scenarios/Testing/1171-chirp-command.yaml b/data/scenarios/Testing/1171-chirp-command.yaml --- a/data/scenarios/Testing/1171-chirp-command.yaml +++ b/data/scenarios/Testing/1171-chirp-command.yaml @@ -22,7 +22,7 @@ takeStep "tree"; robots: - name: base - dir: [0,-1] + dir: south display: char: Ω attr: robot @@ -39,9 +39,9 @@ 'T': [grass, tree] upperleft: [0, 0] map: | - ......... - ......T.. - ......... - ......... - .Ω....... - ......... + ......... + ......T.. + ......... + ......... + .Ω....... + ......... 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 @@ -16,7 +16,7 @@ doN 7 (place "tree"; move) robots: - name: base - dir: [1, 0] + dir: east display: char: Ω attr: robot @@ -30,7 +30,7 @@ inventory: - [7, "tree"] - name: judge - dir: [1, 0] + dir: east system: true display: invisible: false @@ -45,6 +45,6 @@ '.': [grass, erase] upperleft: [4, -1] map: | - J........ - .Ω....... - ......... + J........ + .Ω....... + ......... 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 @@ -31,7 +31,7 @@ homeIn item initialDistance; robots: - name: base - dir: [0,-1] + dir: south display: char: Ω attr: robot @@ -48,9 +48,9 @@ 'T': [grass, tree] upperleft: [0, 0] map: | - ......... - ......T.. - ......... - ......... - .Ω....... - ......... + ......... + ......T.. + ......... + ......... + .Ω....... + ......... diff --git a/data/scenarios/Testing/1207-scout-command.yaml b/data/scenarios/Testing/1207-scout-command.yaml --- a/data/scenarios/Testing/1207-scout-command.yaml +++ b/data/scenarios/Testing/1207-scout-command.yaml @@ -32,7 +32,7 @@ grabFlower robots: - name: base - dir: [0,-1] + dir: south display: char: Ω attr: robot @@ -47,21 +47,21 @@ - string - treads - name: bot - dir: [0,1] + dir: north system: true display: invisible: false char: b attr: robot - name: obscuredbot - dir: [0,1] + dir: north system: true display: invisible: false char: o attr: robot - name: invisiblebot - dir: [0,1] + dir: north system: true display: invisible: true @@ -80,10 +80,10 @@ 'T': [grass, tree] upperleft: [0, 0] map: | - ......... - ..o.i.b.. - ......... - ..T...*.. - ......... - Ω.......@ - ......... + ......... + ..o.i.b.. + ......... + ..T...*.. + ......... + Ω.......@ + ......... 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 @@ -8,9 +8,9 @@ condition: | as base {has "tree"} prerequisite: - logic: - not: - id: grab_flower + logic: + not: + id: grab_flower - id: grab_flower teaser: Grab flower goal: @@ -32,7 +32,7 @@ }; turn west; - try { + try { stride 1; } { log "Could not stride west"; @@ -46,13 +46,13 @@ } { log "Could not grab southern flower"; }; - + turn east; stride 5; grab; robots: - name: base - dir: [1, 0] + dir: east display: char: Ω attr: robot @@ -68,14 +68,14 @@ - treads - turbocharger entities: -- name: turbocharger - display: - attr: silver - char: 't' - description: - - Allows one to "stride" across multiple cells - properties: [known, portable] - capabilities: [movemultiple] + - name: turbocharger + display: + attr: silver + char: 't' + description: + - Allows one to "stride" across multiple cells + properties: [known, pickable] + capabilities: [movemultiple] known: [tree, flower, boulder, water] world: palette: @@ -87,16 +87,16 @@ 'w': [grass, water] upperleft: [0, 0] map: | - .............. - ......*....... - .............. - ......w....... - .............. - ...www........ - .*.wwwΩ....T.. - ...www@....... - .............. - .............. - .............. - ......*....... - .............. + .............. + ......*....... + .............. + ......w....... + .............. + ...www........ + .*.wwwΩ....T.. + ...www@....... + .............. + .............. + .............. + ......*....... + .............. diff --git a/data/scenarios/Testing/1234-push-command.yaml b/data/scenarios/Testing/1234-push-command.yaml --- a/data/scenarios/Testing/1234-push-command.yaml +++ b/data/scenarios/Testing/1234-push-command.yaml @@ -19,7 +19,7 @@ push; robots: - name: base - dir: [1, 0] + dir: east display: char: Ω attr: robot @@ -35,20 +35,20 @@ - treads - dozer blade - name: judge - dir: [0, 1] + dir: north system: true display: char: j attr: robot invisible: true entities: -- name: crate - display: - attr: wood - char: '▪' - description: - - Pushable crate - properties: [known, portable, unwalkable] + - name: crate + display: + attr: wood + char: '▪' + description: + - Pushable crate + properties: [known, pickable, unwalkable] known: [tree, flower, boulder, water] world: palette: @@ -61,8 +61,8 @@ 'x': [grass, crate] upperleft: [0, 0] map: | - .............. - ......w....... - .....@Ωx.x.... - ......*..j.... - ......*....... + .............. + ......w....... + .....@Ωx.x.... + ......*..j.... + ......*....... 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 @@ -4,8 +4,7 @@ description: Stop a robot using halt objectives: - goal: - - The robot next to you is holding a flower, but is stuck in an - infinite loop. Get the flower! + - The robot next to you is holding a flower, but is stuck in an infinite loop. Get the flower! condition: | as base {has "flower"} solution: | @@ -13,7 +12,7 @@ case mr (\_. return ()) (\r. halt r; turn west; move; salvage ) robots: - name: base - dir: [0,-1] + dir: south display: char: Ω attr: robot @@ -28,7 +27,7 @@ - ADT calculator - halting oracle - name: infinitebot - dir: [0,1] + dir: north display: invisible: false devices: @@ -47,10 +46,10 @@ '.': [grass] upperleft: [0, 0] map: | - ......... - ......... - ......... - ...^Ω.... - ......... - ......... - ......... + ......... + ......... + ......... + ...^Ω.... + ......... + ......... + ......... diff --git a/data/scenarios/Testing/1262-display-device-commands.yaml b/data/scenarios/Testing/1262-display-device-commands.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1262-display-device-commands.yaml @@ -0,0 +1,54 @@ +version: 1 +name: Device commands +description: | + Demo display of commands offered by each device, along with their cost. +creative: false +robots: + - name: base + dir: east + devices: + - treads + - logger + - Fresnel lens + - string + inventory: + - [1, flash bulb] + - [1, photographic plate] +entities: + - name: flash bulb + display: + char: 'f' + description: + - Consumables for a `Fresnel lens`{=entity} that enable `ignite`ing + properties: [known, pickable] + - name: photographic plate + display: + char: 'p' + description: + - Consumables for a `Fresnel lens`{=entity} that enable `scan`ning + properties: [known, pickable] + - name: Fresnel lens + display: + char: 'z' + description: + - Ignites things with sufficiently powerful light source + properties: [known, pickable] + capabilities: + - capability: ignite + cost: + - [1, "flash bulb"] + - capability: scan + cost: + - [2, "photographic plate"] +known: [water] +world: + dsl: | + {water} + palette: + 'B': [grass, erase, base] + '.': [grass, erase] + upperleft: [-1, 1] + map: | + ... + .B. + ... 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 @@ -16,7 +16,7 @@ doN 3 (move; grab); robots: - name: base - dir: [1, 0] + dir: east display: char: Ω attr: robot @@ -28,7 +28,7 @@ - treads - ADT calculator - name: judge - dir: [1, 0] + dir: east system: true display: invisible: false @@ -44,7 +44,7 @@ '*': [grass, flower] upperleft: [76, -89] map: | - *.*. - Ω*.* - *.*. - J*.* + *.*. + Ω*.* + *.*. + J*.* diff --git a/data/scenarios/Testing/1320-world-DSL/00-ORDER.txt b/data/scenarios/Testing/1320-world-DSL/00-ORDER.txt --- a/data/scenarios/Testing/1320-world-DSL/00-ORDER.txt +++ b/data/scenarios/Testing/1320-world-DSL/00-ORDER.txt @@ -1,3 +1,5 @@ constant.yaml erase.yaml override.yaml +coords.yaml +reflect.yaml 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 @@ -7,13 +7,13 @@ - condition: | as base { n <- count "tree"; return (n >= 4) } goal: - - Get 4 trees + - Get 4 trees solution: | grab; move; grab; move; grab; move; grab robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - treads diff --git a/data/scenarios/Testing/1320-world-DSL/coords.yaml b/data/scenarios/Testing/1320-world-DSL/coords.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1320-world-DSL/coords.yaml @@ -0,0 +1,22 @@ +version: 1 +name: Coordinate test +description: | + Ensure x and y are handled correctly in the world DSL +creative: false +objectives: + - goal: + - Must pick up a rock + condition: | + as base {has "rock"} +solution: | + grab +robots: + - name: base + loc: [1, 2] + dir: east + devices: + - logger + - grabber +world: + dsl: | + mask (x == 1) (mask (y == 2) {rock,dirt}) 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 @@ -6,7 +6,7 @@ - condition: | as base { n <- count "tree"; return (n == 0) } goal: - - Get rid of your trees. + - Get rid of your trees. solution: | place "tree"; move; move; place "tree"; move; move; @@ -14,8 +14,8 @@ place "tree" robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - treads 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 @@ -6,13 +6,13 @@ - condition: | as base { n <- count "tree"; return (n == 1) } goal: - - Get a tree. + - Get a tree. solution: | grab robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - treads diff --git a/data/scenarios/Testing/1320-world-DSL/reflect.yaml b/data/scenarios/Testing/1320-world-DSL/reflect.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1320-world-DSL/reflect.yaml @@ -0,0 +1,46 @@ +version: 1 +name: Reflection (imap) test +description: | + A world with both horizontal and vertical reflection symmetry, + created with 'imap'. +creative: false +objectives: + - goal: + - Pick up four trees + condition: | + as base {n <- count "tree"; return (n >= 4)} +robots: + - name: base + loc: [0, 0] + dir: north + devices: + - logger + - grabber + - treads + - branch predictor + - scanner + - ADT calculator + - comparator + - GPS receiver + - bitcoin +solution: | + 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 + n <- random 10; + x (n+1) move; turn right; move; + loc <- findTree; + grabTrees loc +known: [tree] +world: + dsl: | + let trees = if (hash % 4 == 0) then {tree, dirt} else {stone} + in + overlay + [ mask (x >= 0 && y >= 0) trees + , mask (x >= 0 && y < 0) (imap x (-y) trees) + , mask (x < 0 && y >= 0) (imap (-x) y trees) + , mask (x < 0 && y < 0) (imap (-x) (-y) trees) + ] diff --git a/data/scenarios/Testing/1322-wait-with-instant.yaml b/data/scenarios/Testing/1322-wait-with-instant.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1322-wait-with-instant.yaml @@ -0,0 +1,72 @@ +version: 1 +name: Using wait with instant +author: Karl Ostmo +description: | + Observe timing of (instant $ wait 1) + interspersed with other commands +creative: false +seed: 0 +objectives: + - goal: + - | + Hare must win by three cells + condition: | + h <- robotnamed "hare"; + hareloc <- as h {whereami}; + + t <- robotnamed "tortoise"; + tortoiseloc <- as t {whereami}; + + let xDiff = fst hareloc - fst tortoiseloc in + + return $ fst hareloc == 0 && xDiff == 3; +solution: | + noop; +robots: + - name: base + dir: [1, 0] + display: + invisible: true + devices: + - hourglass + - logger + - name: tortoise + system: true + display: + invisible: false + attr: green + dir: [1, 0] + program: | + move; move; + move; move; + move; move; + - name: hare + system: true + display: + invisible: false + attr: snow + dir: [1, 0] + program: | + instant ( + move; move; + wait 1; + move; move; + wait 1; + move; move; + ); +world: + dsl: | + {blank} + upperleft: [-6, 2] + offset: false + palette: + '.': [grass, erase] + 'd': [dirt, erase] + 'B': [grass, erase, base] + 'T': [grass, erase, tortoise] + 'H': [grass, erase, hare] + map: | + B.....d. + T.....d. + H.....d. + ......d. 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 @@ -8,25 +8,25 @@ of ticks that they `wait`. objectives: - goal: - - | - `grab` the "tree". + - | + `grab` the "tree". condition: | as base {has "tree"} solution: | - move; + move; + move; + wait 10; + x <- harvest; + if (x == "flower") { + turn right; move; - wait 10; - x <- harvest; - if (x == "flower") { - turn right; - move; - grab; - } { - return ""; - }; + grab; + } { + return ""; + }; robots: - name: base - dir: [1, 0] + dir: east devices: - treads - grabber @@ -36,7 +36,7 @@ - hourglass - branch predictor - name: idler1 - dir: [1, 0] + dir: east system: true devices: - dictionary @@ -49,7 +49,7 @@ end; go; - name: idler2 - dir: [1, 0] + dir: east system: true devices: - dictionary @@ -62,7 +62,7 @@ end; go; - name: idler3 - dir: [1, 0] + dir: east system: true devices: - dictionary @@ -75,7 +75,7 @@ end; go; - name: idler4 - dir: [1, 0] + dir: east system: true devices: - dictionary 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 @@ -40,7 +40,7 @@ ignite right; robots: - name: base - dir: [1, 0] + dir: east devices: - branch predictor - calculator @@ -50,49 +50,49 @@ - treads - torch - name: judge - dir: [1, 0] + dir: east system: true display: invisible: true char: J entities: -- name: torch - display: - attr: wood - char: 't' - description: - - Can set things on fire - properties: [known, portable] - capabilities: [ignite] -- name: fuse - display: - attr: wood - char: '~' - description: - - Reliably combustible - combustion: - ignition: 1 - duration: [8, 8] - product: null - properties: [known, portable, combustible] -- name: dynamite - display: - attr: red - char: '!' - description: - - Explosive material - combustion: - ignition: 1 - duration: [2, 2] - product: crater - properties: [known, portable, combustible] -- name: crater - display: - attr: rock - char: '@' - description: - - Result of explosive excavation - properties: [known] + - name: torch + display: + attr: wood + char: 't' + description: + - Can set things on fire + properties: [known, pickable] + capabilities: [ignite] + - name: fuse + display: + attr: wood + char: '~' + description: + - Reliably combustible + combustion: + ignition: 1 + duration: [8, 8] + product: null + properties: [known, pickable, combustible] + - name: dynamite + display: + attr: red + char: '!' + description: + - Explosive material + combustion: + ignition: 1 + duration: [2, 2] + product: crater + properties: [known, pickable, combustible] + - name: crater + display: + attr: rock + char: '@' + description: + - Result of explosive excavation + properties: [known] known: [ash, tree, log, board, paper, cotton] world: palette: @@ -107,27 +107,27 @@ '.': [grass] upperleft: [0, 0] map: | - ..iiii....bbbb..TT..llll....iiii..... - ..iiii....bbbb..TT..llll....iiii..... - ..iiii....bbbb..TT..llll....iiii..... - ..iiii....bbbb..TT..llll....iiii..... - ..iiii....bbbb..TT..llll....iiii..... - ..iiii....bbbb..TT..llll....iiii..... - ..TTTT....TTTT..TT..TTTT....TTTT..... - ..TTTT....TTTT..TT..TTTT....TTTT..... - ................TT................... - ................TT................... - iiiiiiiiiii.....TT....FFFFF...FFFFF.. - ......iiiiii....TT....F...F...F...F.. - iiiiiiiiiiiii...TT....F...F...F...F.. - ......iiiiiiii........F...F...F...F.. - iiiiiiiiiiiiiii..Ω.FFFF...FFFFF...d.. - ......iiiiiiii....................... - iiiiiiiiiiiii.....qqqqqqqqqqqqqqqq... - ......iiiiii......qqqqqqqqqqqqqqqq... - iiiiiiiiiii.......qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... - ..................qqqqqqqqqqqqqqqq... + ..iiii....bbbb..TT..llll....iiii..... + ..iiii....bbbb..TT..llll....iiii..... + ..iiii....bbbb..TT..llll....iiii..... + ..iiii....bbbb..TT..llll....iiii..... + ..iiii....bbbb..TT..llll....iiii..... + ..iiii....bbbb..TT..llll....iiii..... + ..TTTT....TTTT..TT..TTTT....TTTT..... + ..TTTT....TTTT..TT..TTTT....TTTT..... + ................TT................... + ................TT................... + iiiiiiiiiii.....TT....FFFFF...FFFFF.. + ......iiiiii....TT....F...F...F...F.. + iiiiiiiiiiiii...TT....F...F...F...F.. + ......iiiiiiii........F...F...F...F.. + iiiiiiiiiiiiiii..Ω.FFFF...FFFFF...d.. + ......iiiiiiii....................... + iiiiiiiiiiiii.....qqqqqqqqqqqqqqqq... + ......iiiiii......qqqqqqqqqqqqqqqq... + iiiiiiiiiii.......qqqqqqqqqqqqqqqq... + ..................qqqqqqqqqqqqqqqq... + ..................qqqqqqqqqqqqqqqq... + ..................qqqqqqqqqqqqqqqq... + ..................qqqqqqqqqqqqqqqq... + ..................qqqqqqqqqqqqqqqq... 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 @@ -6,13 +6,13 @@ robots: - name: base loc: [0, 0] - dir: [1, 0] + dir: east - name: patroller loc: [5, -4] - dir: [1, 0] + dir: east display: invisible: false - attr: robot + attr: robot program: | run "scenarios/Testing/1356-portals/_automatic-waypoint-patrol/program.sw" known: [flower, boulder] 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 @@ -10,32 +10,32 @@ - name: portal_out fg: "#00a2ff" bg: "#0065ff" +solution: turn left; move; move; turn left; move; move; move; turn left; move; move; move; move; move; entities: - name: telepad entrance display: attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base loc: [0, 4] - dir: [1, 0] + dir: east known: [tree, flower, sand, bit (0), bit (1)] world: upperleft: [-4, 7] palette: '.': [grass] '*': [stone, flower] - 'P': [grass, telepad entrance] 'p': [grass, telepad exit] '┌': [stone, upper left corner] '┐': [stone, upper right corner] 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 @@ -4,8 +4,8 @@ Validate proper flip/rotate of portal waypoints objectives: - goal: - - | - `grab` the "bitcoin" + - | + `grab` the "bitcoin" condition: | as base {has "bitcoin"} solution: | @@ -23,18 +23,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor diff --git a/data/scenarios/Testing/1379-single-world-portal-reorientation.yaml b/data/scenarios/Testing/1379-single-world-portal-reorientation.yaml --- a/data/scenarios/Testing/1379-single-world-portal-reorientation.yaml +++ b/data/scenarios/Testing/1379-single-world-portal-reorientation.yaml @@ -8,28 +8,28 @@ bg: "#ff5d00" objectives: - goal: - - | - `place` the "flower" on the white cell. + - | + `place` the "flower" on the white cell. condition: | j <- robotnamed "judge"; as j {ishere "flower"} solution: | - def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; - doN 23 move; - f <- grab; - doN 23 move; - place f; + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + doN 23 move; + f <- grab; + doN 23 move; + place f; entities: - name: telepad entrance display: attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] robots: - name: base - dir: [0, 1] + dir: north devices: - branch predictor - calculator @@ -41,7 +41,7 @@ - strange loop - treads - name: judge - dir: [1, 0] + dir: east system: true display: char: 'J' diff --git a/data/scenarios/Testing/1399-backup-command.yaml b/data/scenarios/Testing/1399-backup-command.yaml --- a/data/scenarios/Testing/1399-backup-command.yaml +++ b/data/scenarios/Testing/1399-backup-command.yaml @@ -4,15 +4,15 @@ Locomote backwards without access to the turn command objectives: - goal: - - | - `grab` the "flower". + - | + `grab` the "flower". condition: | as base {has "flower"} solution: | - backup; backup; grab; + backup; backup; grab; robots: - name: base - dir: [0, 1] + dir: north devices: - tape drive - grabber 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 @@ -4,7 +4,7 @@ description: Demo of system robot construction robots: - name: base - dir: [1, 0] + dir: east display: char: Ω attr: robot @@ -21,7 +21,7 @@ - grabber - hearing aid - name: sysbot - dir: [-1, 0] + dir: west system: true display: char: j @@ -40,11 +40,11 @@ program: | build {move; say (format parent)} solution: | - listen; build {move; say (format parent)} + listen; build {move; say (format parent)} objectives: - goal: - - Check that system robots build system robots and normal robots do not. - - This check is performed in integration tests. + - Check that system robots build system robots and normal robots do not. + - This check is performed in integration tests. condition: | r2 <- robotNumbered 2; r3 <- robotNumbered 3; @@ -57,8 +57,8 @@ '.': [grass] upperleft: [0, 0] map: | - ......... - ......... - ...Ω..r.. - ......... - ......... + ......... + ......... + ...Ω..r.. + ......... + ......... diff --git a/data/scenarios/Testing/144-subworlds/basic-subworld.yaml b/data/scenarios/Testing/144-subworlds/basic-subworld.yaml --- a/data/scenarios/Testing/144-subworlds/basic-subworld.yaml +++ b/data/scenarios/Testing/144-subworlds/basic-subworld.yaml @@ -4,8 +4,8 @@ Surface and underground with portals. objectives: - goal: - - | - `place` the "flower" on the white cell. + - | + `place` the "flower" on the white cell. condition: | j <- robotnamed "judge"; as j {ishere "flower"} @@ -24,18 +24,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor @@ -50,7 +50,7 @@ - strange loop - treads - name: judge - dir: [1, 0] + dir: east system: true display: char: 'J' diff --git a/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml b/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml --- a/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml +++ b/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml @@ -15,18 +15,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor diff --git a/data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml b/data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml --- a/data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml +++ b/data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml @@ -4,8 +4,8 @@ Demonstrate that system robots can be placed in any subworld. objectives: - goal: - - | - `give` the "flower" to the robot underground. + - | + `give` the "flower" to the robot underground. condition: | j <- robotnamed "judge"; as j {has "flower"} @@ -24,18 +24,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east loc: subworld: root loc: [2, 0] @@ -54,7 +54,7 @@ - strange loop - treads - name: judge - dir: [1, 0] + dir: east loc: subworld: underground loc: [4, 0] @@ -69,7 +69,6 @@ palette: '.': [dirt] 'b': [dirt, boulder] - 't': [grass, null, judge] 'p': cell: [dirt, telepad exit] waypoint: @@ -94,8 +93,6 @@ palette: '.': [grass] 'f': [grass, flower] - 'B': [grass, null, base] - 't': [grass, null, judge] 'p': cell: [grass, telepad exit] waypoint: diff --git a/data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml b/data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml --- a/data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml +++ b/data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml @@ -7,10 +7,10 @@ on subworld. objectives: - goal: - - | - `give` the "bitcoin" to the robot in the "root" world. - - | - First obtain it from the robot living underground. + - | + `give` the "bitcoin" to the robot in the "root" world. + - | + First obtain it from the robot living underground. condition: | j <- robotnumbered 1; as j {has "bitcoin"} @@ -29,18 +29,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - antenna @@ -56,7 +56,7 @@ - strange loop - treads - name: judge - dir: [1, 0] + dir: east system: true display: char: 'J' diff --git a/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml b/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml --- a/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml +++ b/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml @@ -1,7 +1,7 @@ version: 1 name: Subworld shared structures description: | - Traverse floors of the tower + Traverse the floors of the tower, then grab the flower in the middle attrs: - name: portal_in fg: "#ff9a00" @@ -9,25 +9,33 @@ - name: portal_out fg: "#00a2ff" bg: "#0065ff" +objectives: + - goal: + - | + Visit all of the floors + condition: | + as base {has "flower"} entities: - name: telepad entrance display: attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] - loc: [0, 0] + dir: east + loc: + subworld: root + loc: [0, 0] devices: - ADT calculator - branch predictor @@ -41,6 +49,20 @@ - logger - strange loop - treads +solution: | + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + doN 4 ( + doN 4 move; + turn right; + doN 4 move; + ); + + doN 2 move; + turn right; + doN 2 move; + + grab; known: [flower] structures: - name: minibox @@ -48,7 +70,6 @@ palette: '.': [stone] 'd': [dirt] - 'f': [stone, flower] 'p': cell: [grass, telepad exit] waypoint: @@ -77,27 +98,19 @@ default: [blank] palette: '.': [dirt] - 'f': [dirt, flower] - 'p': - cell: [dirt, telepad exit] - waypoint: - name: portal_out - 'P': - cell: [dirt, telepad entrance] - waypoint: - name: portal_in placements: - - src: flowers - offset: [1, 1] - src: minibox offset: [0, 0] orient: up: west + - src: flowers + offset: [1, 1] portals: - entrance: portal_in exitInfo: exit: portal_out subworldName: floor2 + reorient: back upperleft: [0, 0] map: | ..... @@ -109,27 +122,19 @@ default: [blank] palette: '.': [dirt] - 'f': [dirt, flower] - 'p': - cell: [dirt, telepad exit] - waypoint: - name: portal_out - 'P': - cell: [dirt, telepad entrance] - waypoint: - name: portal_in placements: - - src: flowers - offset: [1, 0] - src: minibox offset: [0, 0] orient: up: south + - src: flowers + offset: [1, 0] portals: - entrance: portal_in exitInfo: exit: portal_out subworldName: floor3 + reorient: back upperleft: [0, 0] map: | ..... @@ -141,27 +146,19 @@ default: [blank] palette: '.': [dirt] - 'f': [dirt, flower] - 'p': - cell: [dirt, telepad exit] - waypoint: - name: portal_out - 'P': - cell: [dirt, telepad entrance] - waypoint: - name: portal_in placements: - - src: flowers - offset: [1, -2] - src: minibox offset: [0, 0] orient: up: east + - src: flowers + offset: [1, -2] portals: - entrance: portal_in exitInfo: exit: portal_out subworldName: root + reorient: back upperleft: [0, 0] map: | ..... @@ -171,20 +168,20 @@ ..... world: name: root - default: [blank] palette: '.': [grass] upperleft: [0, 0] placements: - - src: flowers - offset: [0, -2] - src: minibox offset: [0, 0] + - src: flowers + offset: [0, -2] portals: - entrance: portal_in exitInfo: exit: portal_out subworldName: floor1 + reorient: back map: | ..... ..... diff --git a/data/scenarios/Testing/1533-sow-command.yaml b/data/scenarios/Testing/1533-sow-command.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1533-sow-command.yaml @@ -0,0 +1,195 @@ +version: 1 +name: Sow command and spread +seed: 0 +description: | + Demonstrate `sow` command and spreading growth with biome restrictions. + + Illustrates different rates of spread for different crops. +creative: false +attrs: + - name: clay + fg: "#444444" + bg: "#c2b280" + - name: wheat + fg: "#444444" + bg: "#F5DEB3" + - name: barley + fg: "#444444" + bg: "#F6E9B1" + - name: maize + fg: "#444444" + bg: "#FBEC5D" + - name: mint + bg: "#3EB489" +terrains: + - name: clay + attr: clay + description: | + Sandy soil +objectives: + - goal: + - | + Observe `kudzu`{=entity} spread + condition: | + r <- robotnamed "kudzubot"; + as r { + kCount <- resonate "kudzu" ((0, 0), (10, 4)); + return $ kCount >= 45; + } +solution: | + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + doN 6 move; + harvest; + + doN 13 move; + turn right; + harvest; + doN 6 move; + + sow "mint"; + turn right; + doN 13 move; + + sow "barley"; + turn left; + doN 7 move; + sow "barley"; + turn left; + + doN 13 move; + sow "kudzu"; + doN 6 move; +robots: + - name: base + dir: east + devices: + - branch predictor + - calculator + - comparator + - dictionary + - harvester + - logger + - seed spreader + - treads + inventory: + - [2, barley] + - [1, kudzu] + - [1, mint] + - name: kudzubot + 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' + attr: barley + description: + - Grain + properties: [known, pickable, growable] + growth: + duration: [30, 50] + spread: + radius: 2 + density: 0.3 + biomes: [dirt, clay] + - name: corn + display: + char: 'c' + attr: maize + description: + - Animal feed + properties: [known, pickable, growable] + growth: + duration: [30, 60] + spread: + radius: 3 + density: 0.1 + biomes: [dirt, clay] + - name: kudzu + display: + char: 'k' + attr: plant + description: + - Dense, impassable plant. + properties: [known, unwalkable, growable] + growth: + duration: [30, 50] + spread: + radius: 1 + density: 3 + biomes: [dirt, clay] + - name: mint + display: + char: 'm' + attr: mint + description: + - Invasive + properties: [known, pickable, growable] + growth: + duration: [10, 50] + spread: + radius: 2 + density: 0.6 + biomes: [dirt, clay] + - name: seed spreader + display: + char: 's' + description: + - A handheld pouch with a manual crank to broadcast seeds evenly within a small radius + properties: [known] + capabilities: [sow] +known: [flower] +world: + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 'd': [dirt] + 'c': [clay] + 'K': [clay, null, kudzubot] + 'C': [dirt, corn] + 'W': [clay, wheat] + upperleft: [-1, 1] + map: | + .......................... + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + BdddddCddddd..cccccWccccc. + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .......................... + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .......................... + .......................... + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .ddddddddddd..ccccccccccc. + .ddddddddddd..Kcccccccccc. + .......................... + .......................... + .......................... + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .ccccccccccc..ddddddddddd. + .......................... diff --git a/data/scenarios/Testing/1533-sow-seed-maturation.yaml b/data/scenarios/Testing/1533-sow-seed-maturation.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1533-sow-seed-maturation.yaml @@ -0,0 +1,101 @@ +version: 1 +name: Seed maturation +description: | + A seed grows into a different entity, which again + yields the original seed when harvested. + + The 'mature' sub-property of the 'growth' property + facilitates the distinction between seeds and the + entities those seeds produce. For example, it doesn't make much sense + to plant an `acorn`{=entity} and call the resulting, + fully-grown plant also an `acorn`{=entity}. + + In combination with 'yields', it + effectively precludes the grown entity (as it exists in the world) + from entering into the player's inventory. +creative: false +objectives: + - id: plant_acorn + goal: + - | + Plant an `acorn`{=entity} + condition: | + as base { + x <- has "acorn"; + return $ not x; + } + - goal: + - | + Go to the `oak`{=entity} + condition: | + as base { + ishere "oak"; + } + - goal: + - | + Pick another `acorn`{=entity} + prerequisite: plant_acorn + condition: | + as base { + has "acorn"; + } +solution: | + sow "acorn"; + move; + watch back; + turn back; + wait 1000; + move; + harvest; +robots: + - name: base + dir: east + devices: + - branch predictor + - calculator + - comparator + - dictionary + - harvester + - logger + - rolex + - scanner + - seed spreader + - treads + inventory: + - [1, acorn] +entities: + - name: acorn + display: + char: 'a' + description: + - Seed of an `oak`{=entity} + properties: [known, pickable, growable] + growth: + duration: [200, 300] + mature: oak + - name: oak + display: + char: 'k' + description: + - Grows from an `acorn`{=entity} + properties: [known, pickable, growable] + growth: + duration: [200, 300] + yields: acorn + - name: seed spreader + display: + char: 's' + description: + - A handheld pouch with a manual crank to broadcast seeds evenly within a small radius + properties: [known] + capabilities: [sow] +world: + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [-2, 2] + map: | + ..... + ..B.. + ..... diff --git a/data/scenarios/Testing/1535-ping/1535-in-range.yaml b/data/scenarios/Testing/1535-ping/1535-in-range.yaml --- a/data/scenarios/Testing/1535-ping/1535-in-range.yaml +++ b/data/scenarios/Testing/1535-ping/1535-in-range.yaml @@ -22,17 +22,17 @@ char: 'x' description: - Enables `ping` command - properties: [known, portable] + properties: [known, pickable] capabilities: [ping] - name: map piece display: char: 'm' description: - Half of a treasure map - properties: [known, portable] + properties: [known, pickable] robots: - name: base - dir: [1,0] + dir: east devices: - ADT calculator - antenna @@ -48,7 +48,7 @@ inventory: - [1, map piece] - name: buddy - dir: [-1, 0] + dir: west system: true display: invisible: false @@ -75,8 +75,8 @@ dsl: | overlay [ {terrain: stone} - , if (x/5 + y/5) % 2 == 0 then {terrain: dirt} else {blank} - , if ((x + 3) % 19)/12 + (y % 19)/12 == 0 then {terrain: grass} else {blank} + , if (x/5 + (-y)/5) % 2 == 0 then {terrain: dirt} else {blank} + , if ((3 - y) % 19)/12 + (x % 19)/12 == 0 then {terrain: grass} else {blank} ] palette: 'B': [blank, null, base] 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 @@ -21,11 +21,11 @@ char: 'x' description: - Enables `ping` command - properties: [known, portable] + properties: [known, pickable] capabilities: [ping] robots: - name: base - dir: [-1,0] + dir: west devices: - calculator - antenna @@ -38,7 +38,7 @@ - transponder - welder - name: buddy - dir: [1, 0] + dir: east devices: - ADT calculator - grabber @@ -47,15 +47,15 @@ - transponder inventory: - [1, treads] - program: + program: | give base "treads"; known: [] world: dsl: | overlay [ {terrain: blank} - , if (x/4 + y/4) % 2 == 0 then {terrain: dirt} else {blank} - , if ((x + 3) % 19)/12 + (y % 19)/12 == 0 then {terrain: grass} else {blank} + , if (x/4 + (-y)/4) % 2 == 0 then {terrain: dirt} else {blank} + , if ((3 - y) % 19)/12 + (x % 19)/12 == 0 then {terrain: grass} else {blank} ] palette: 'B': [stone, null, base] diff --git a/data/scenarios/Testing/1536-custom-unwalkable-entities.yaml b/data/scenarios/Testing/1536-custom-unwalkable-entities.yaml --- a/data/scenarios/Testing/1536-custom-unwalkable-entities.yaml +++ b/data/scenarios/Testing/1536-custom-unwalkable-entities.yaml @@ -1,9 +1,6 @@ version: 1 name: Custom unwalkability -description: The base robot cannot walk through trees. - The scenario shall be failed if the robot - manages to walk through the tree by moving - three cells to the east. +description: The base robot cannot walk through trees. The scenario shall be failed if the robot manages to walk through the tree by moving three cells to the east. objectives: - goal: - Get the flower @@ -25,7 +22,7 @@ grab; robots: - name: base - dir: [1, 0] + dir: east display: attr: robot devices: @@ -34,17 +31,16 @@ - treads - dictionary - net - unwalkable: - - tree + walkable: + never: + - tree known: [tree, flower, bitcoin] world: palette: 'B': [grass, null, base] - '.': [grass] 'T': [grass, tree] 'b': [grass, bitcoin] 'f': [grass, flower] upperleft: [0, 0] map: | BfTb - diff --git a/data/scenarios/Testing/1569-pathfinding-cache/00-ORDER.txt b/data/scenarios/Testing/1569-pathfinding-cache/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1569-pathfinding-cache/00-ORDER.txt @@ -0,0 +1,3 @@ +1569-harvest-batch.yaml +1569-cache-invalidation-modes.yaml +1569-cache-invalidation-distance-limit.yaml diff --git a/data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-distance-limit.yaml b/data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-distance-limit.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-distance-limit.yaml @@ -0,0 +1,127 @@ +version: 1 +name: Pathfinding cache - changing distance limit +description: | + Demonstrates various sequences of distance limit increases and decreases. +creative: false +objectives: + - goal: + - Make lemonade + condition: | + as base { + has "lemonade"; + }; +solution: | + def go = + + // The cache gets initially populated with an + // unlimited distance, so in a sequence of + // (1) a decreased limit followed by + // (2) an increased finite limit, + // the increase in (2) is still considered a decrease + // relative to the cache. + + // Invocation #1: Expect RECOMPUTATION + path (inL ()) (inR "flower"); + + // Invocation #2: Expect SUCCESS + path (inL ()) (inR "flower"); + + // Invocation #3: Expect SUCCESS + path (inR 5) (inR "flower"); + + // Invocation #4: Expect SUCCESS + // Even though this is an increase relative to the previous invocation, + // it is a decrease relative to the cached limit. + path (inR 6) (inR "flower"); + + move; + + // Invocation #5: Expect RECOMPUTATION + // We have invoked 'path' from a new location, so evict the cache. + path (inR 6) (inR "flower"); + + // Invocation #6: Expect SUCCESS + path (inR 4) (inR "flower"); + + // Invocation #7: Expect RECOMPUTATION + path (inR 7) (inR "flower"); + + // Invocation #8: Expect SUCCESS + path (inR 5) (inR "flower"); + + // Invocation #9: Expect FAILURE + // This failure is not cached. + path (inR 2) (inR "flower"); + + // Invocation #10: Expect SUCCESS + // The cache is still valid from the previous success. + path (inR 4) (inR "flower"); + + make "lemonade"; + end; + + go; +entities: + - name: wayfinder + display: + char: 'w' + description: + - Enables `path` command + properties: [known, pickable] + capabilities: [path] + - name: monolith + display: + char: '@' + attr: rock + description: + - Pushable rock + properties: [known, unwalkable, pickable] + - name: lemon + display: + char: 'o' + attr: gold + description: + - Sour fruit + properties: [known, pickable] + - name: lemonade + display: + char: 'c' + attr: gold + description: + - Sweet drink + properties: [known, pickable] +recipes: + - in: + - [1, lemon] + out: + - [1, lemonade] +robots: + - name: base + dir: north + devices: + - ADT calculator + - antenna + - branch predictor + - comparator + - compass + - dictionary + - linotype + - logger + - grabber + - toolkit + - treads + - wayfinder + - workbench + inventory: + - [1, lemon] +known: [flower] +world: + palette: + 'B': [grass, erase, base] + '.': [grass] + 'f': [grass, flower] + upperleft: [0, 0] + map: | + .... + B..f + .... 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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-modes.yaml @@ -0,0 +1,176 @@ +version: 1 +name: Pathfinding cache - invalidation modes +description: | + The following sequence is performed: + + 1. An unwalkable entity is added to the path. + 2. An unwalkable entity is removed from the path. + 3. The target entity is added somewhere outside of the path + 4. The target entity is added somewhere on the path + + These events are recorded in the caching log and inspected in the + integration test. +creative: false +objectives: + - goal: + - Make lemonade + condition: | + as base { + has "lemonade"; + }; +solution: | + def queryFlowerPath = + p <- path (inL ()) (inR "flower"); + log $ format p; + end; + + def waitUntilSalvaged = + salvage; + gotPanel <- has "solar panel"; + if gotPanel {} {waitUntilSalvaged}; + end; + + def forceBlockageInvalidation = + build { + require 1 "monolith"; + move; + place "monolith"; + turn back; + move; + }; + + waitUntilSalvaged; + end; + + def forceRemovedUnwalkableInvalidation = + build { + turn back; + push; + turn back; + move; + }; + + waitUntilSalvaged; + end; + + def forceCompetingTargetInvalidation = + build { + require 1 "flower"; + turn right; + move; + place "flower"; + turn back; + move; + }; + + waitUntilSalvaged; + end; + + def go = + // Invocation #1: Expect RECOMPUTATION + queryFlowerPath; + forceBlockageInvalidation; + + // Invocation #2: Expect RECOMPUTATION + queryFlowerPath; + + turn right; + move; + turn left; + move; move; + turn left; + move; + turn right; + + // Invocation #3: Expect SUCCESS + queryFlowerPath; + forceRemovedUnwalkableInvalidation; + + // Invocation #4: Expect RECOMPUTATION + queryFlowerPath; + + forceCompetingTargetInvalidation; + + // Invocation #5: Expect RECOMPUTATION + queryFlowerPath; + + place "flower"; + + // Invocation #6: Expect SUCCESS + queryFlowerPath; + + make "lemonade"; + end; + + go; +entities: + - name: wayfinder + display: + char: 'w' + description: + - Enables `path` command + properties: [known, pickable] + capabilities: [path] + - name: monolith + display: + char: '@' + attr: rock + description: + - Pushable rock + properties: [known, unwalkable, pickable] + - name: lemon + display: + char: 'o' + attr: gold + description: + - Sour fruit + properties: [known, pickable] + - name: lemonade + display: + char: 'c' + attr: gold + description: + - Sweet drink + properties: [known, pickable] +recipes: + - in: + - [1, lemon] + out: + - [1, lemonade] +robots: + - name: base + dir: east + devices: + - 3D printer + - ADT calculator + - antenna + - branch predictor + - comparator + - compass + - dictionary + - linotype + - logger + - grabber + - toolkit + - treads + - wayfinder + - workbench + inventory: + - [1, solar panel] + - [1, treads] + - [1, dozer blade] + - [1, grabber] + - [1, monolith] + - [2, flower] + - [1, lemon] +known: [flower] +world: + palette: + 'B': [grass, erase, base] + '.': [grass] + 'f': [grass, flower] + upperleft: [0, 0] + map: | + ..... + B...f + ..... diff --git a/data/scenarios/Testing/1569-pathfinding-cache/1569-harvest-batch.yaml b/data/scenarios/Testing/1569-pathfinding-cache/1569-harvest-batch.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1569-pathfinding-cache/1569-harvest-batch.yaml @@ -0,0 +1,60 @@ +version: 1 +name: Pathfinding cache - harvest entity batches +description: | + Demonstrates repeated application of `path` command to + harvest a cluster of entities. Upon each harvest, + the path cache shall be invalidated since the destination + entity has been removed. +creative: false +objectives: + - goal: + - Get 4 flowers. + condition: | + as base { + fCount <- count "flower"; + return $ fCount >= 4; + }; +solution: | + def goDir = \f. \result. + let d = fst result in + if (d == down) {grab; f;} {turn d; move; f;} + end; + + def followRoute = + nextDir <- path (inL ()) (inR "flower"); + case nextDir return $ goDir followRoute; + end; + + followRoute; +entities: + - name: wayfinder + display: + char: 'w' + description: + - Enables `path` command + properties: [known, pickable] + capabilities: [path] +robots: + - name: base + dir: east + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - logger + - grabber + - treads + - wayfinder +known: [flower] +world: + palette: + 'B': [grass, erase, base] + '.': [grass] + 'f': [grass, flower] + upperleft: [0, 0] + map: | + B... + ..ff + ..ff diff --git a/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt b/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt @@ -0,0 +1,16 @@ +1575-browse-structures.yaml +1575-nested-structure-definition.yaml +1575-construction-count.yaml +1575-handle-overlapping.yaml +1575-ensure-single-recognition.yaml +1575-ensure-disjoint.yaml +1575-overlapping-tiebreaker-by-largest.yaml +1575-overlapping-tiebreaker-by-location.yaml +1575-remove-structure.yaml +1575-swap-structure.yaml +1575-placement-occlusion.yaml +1575-interior-entity-placement.yaml +1575-floorplan-command.yaml +1575-bounding-box-overlap.yaml +1644-rotated-recognition.yaml +1644-rotated-preplacement-recognition.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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-bounding-box-overlap.yaml @@ -0,0 +1,83 @@ +version: 1 +name: Structure recognizer - overlapping bounding boxes +description: | + Recognize non-rectangular structures even when + bounding boxes overlap with each other, + or when non-participating entities encroach within + the candidate bounding box. + + In this scenario, there is only one possible arrangement. +creative: false +objectives: + - teaser: Build structures + goal: + - | + Build 3 `chevron`{=structure} structures + condition: | + foundStructure <- structure "chevron" 0; + return $ case foundStructure (\_. false) (\x. fst x >= 3); +robots: + - name: base + dir: east + devices: + - ADT calculator + - branch predictor + - comparator + - dictionary + - fast grabber + - lambda + - logger + - strange loop + - treads + inventory: + - [10, boulder] +solution: | + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + doN 2 move; + turn right; + + doN 2 (place "boulder"; move;); + turn right; + doN 2 (place "boulder"; move;); + place "boulder"; + + turn left; + doN 2 move; + + turn left; + doN 2 move; + + doN 2 (place "boulder"; move;); + turn left; + doN 3 (place "boulder"; move;); +structures: + - name: chevron + recognize: [north] + structure: + palette: + 'g': [stone, boulder] + mask: '.' + map: | + ..g + ..g + ggg +known: [boulder, mountain, water] +world: + name: root + dsl: | + {water} + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + 'M': [grass, mountain] + placements: + - src: chevron + offset: [1, -1] + upperleft: [0, 0] + map: | + B.... + .M... + ..... + ..... + ..... diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml @@ -0,0 +1,130 @@ +version: 1 +name: Structure browser +description: | + Hit *F6* to view the recognizable structures. + + Only the subset of the structures marked with + *recognize: [north]* are browseable. + In particular, the `donut`{=structure} structure is placed + in the map but not displayed in the *F6* dialog. +creative: false +objectives: + - teaser: Build structure + goal: + - | + Build a `precious`{=structure} structure + condition: | + foundStructure <- structure "precious" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: east + devices: + - grabber + - treads + inventory: + - [50, flower] + - [50, log] + - [50, rock] + - [50, copper pipe] + - [50, iron gear] + - [50, quartz] + - [50, gold] + - [50, silver] + - [50, mithril] + - [50, cotton] +solution: | + move; + place "quartz"; + move; + place "quartz"; + move; + place "mithril"; +structures: + - name: donut + structure: + palette: + '@': [dirt, rock] + mask: '.' + map: | + .@@@. + @@@@@ + @@.@@ + @@@@@ + .@@@. + - name: diamond + recognize: [north] + description: "A diamond pattern of flowers" + structure: + mask: '.' + palette: + 'x': [stone, flower] + map: | + ...x... + ..xxx.. + .xxxxx. + xxxxxxx + .xxxxx. + ..xxx.. + ...x... + - name: contraption + recognize: [north] + description: "A device for assembling useful widgets" + structure: + mask: '.' + palette: + 'r': [stone, log] + 'I': [stone, rock] + 'l': [stone, copper pipe] + 'g': [stone, iron gear] + map: | + rllllr + lIIIIl + lIIIgg + rlllgg + - name: precious + recognize: [north] + structure: + mask: '.' + palette: + 'q': [stone, quartz] + 'g': [stone, gold] + 's': [stone, silver] + 'm': [stone, mithril] + map: | + qgs + gsq + qqm + - name: smallish + recognize: [north] + structure: + mask: '.' + palette: + 'q': [stone, quartz] + 'm': [stone, mithril] + 'c': [stone, cotton] + map: | + qqm + cqq +known: [flower, log, rock, copper pipe, iron plate] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'q': [grass, quartz] + 'g': [grass, gold] + 's': [grass, silver] + 'c': [grass, cotton] + 'B': [grass, null, base] + upperleft: [0, 0] + placements: + - src: donut + offset: [6, 0] + map: | + .qgs......... + .gsq......... + B............ + .cqq......... + ............. diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml @@ -0,0 +1,69 @@ +version: 1 +name: Structure recognizer - counting +description: | + Count the construction of several adjacent copies +creative: false +objectives: + - teaser: Build 12 structures + goal: + - | + Build 12 copies of the `green_jewel`{=structure} structure + condition: | + foundGreen <- structure "green_jewel" 0; + return $ case foundGreen (\_. false) (\x. fst x >= 12); +robots: + - name: base + dir: east + devices: + - ADT calculator + - branch predictor + - comparator + - dictionary + - grabber + - lambda + - logger + - strange loop + - treads + inventory: + - [108, pixel (G)] +solution: | + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + doN 6 ( + doN 9 (place "pixel (G)"; move;); + doN 2 (turn right; move;); + doN 9 (place "pixel (G)"; move;); + doN 2 (turn left; move;); + ); +structures: + - name: green_jewel + recognize: [north] + structure: + palette: + 'g': [stone, pixel (G)] + map: | + ggg + ggg + ggg +known: [pixel (G)] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + B........ + ......... + ......... + ......... + ......... + ......... + ......... + ......... + ......... + ......... + ......... + ......... diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml @@ -0,0 +1,85 @@ +version: 1 +name: Structure recognizer - Disjoint recognitions +description: | + Ensure that the completion of a second structure + template is not recognized if it overlaps + with a previously completed structure. + + Player starts with 3 `silver`{=entity}. A win + should not be counted until all three are placed. +creative: false +objectives: + - teaser: Build 2 `chessboard`{=structure}s + prerequisite: + not: premature_win + goal: + - | + Build 2 of the same structure + condition: | + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\fs. + let boardCount = fst fs in + boardCount >= 2; + ); + - id: premature_win + teaser: Don't count win early + optional: true + goal: + - | + Two structures shouldn't be recognized + while the bases still possesses `silver`{=entity} + condition: | + robotHasSilver <- as base {has "silver"}; + + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\fs. + let boardCount = fst fs in + boardCount >= 2 && robotHasSilver; + ); +robots: + - name: base + dir: south + devices: + - grabber + - treads + inventory: + - [3, silver] +solution: | + move; + turn left; + place "silver"; + move; move; + place "silver"; + move; move; + place "silver"; +structures: + - name: chessboard + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + gsgs + sgsg + gsgs + sgsg +known: [water, gold, silver] +world: + name: root + dsl: | + {water} + palette: + '.': [grass, water] + 'x': [grass, erase] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, water, base] + upperleft: [0, 0] + map: | + ...B.... + gsgxgxgx + sgsgsgsg + gsgsgsgs + sgsgsgsg 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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml @@ -0,0 +1,80 @@ +version: 1 +name: Structure recognizer - single recognition +description: | + Ensure that only a single structure is recognized + when placing an entity would complete more than one + structure template. +creative: false +objectives: + - teaser: Build 2 `chessboard`{=structure}s + prerequisite: + not: premature_win + goal: + - | + Build 2 of the same structure + condition: | + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\fs. + let boardCount = fst fs in + boardCount >= 2; + ); + - id: premature_win + teaser: Don't count win early + optional: true + goal: + - | + Two structures shouldn't be recognized + while the bases still possesses `gold`{=entity} + condition: | + robotHasGold <- as base {has "gold"}; + + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\fs. + let boardCount = fst fs in + boardCount >= 2 && robotHasGold; + ); +robots: + - name: base + dir: south + devices: + - grabber + - treads + inventory: + - [1, gold] + - [1, silver] +solution: | + move; + place "silver"; + move; move; move; + turn left; + move; move; move; move; + place "gold"; +structures: + - name: chessboard + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + gsgs + sgsg + gsgs + sgsg +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + ...B.... + gsg.gsgs + sgsgsgsg + gsgsgsgs + sgsgsgs. diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-floorplan-command.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-floorplan-command.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-floorplan-command.yaml @@ -0,0 +1,75 @@ +version: 1 +name: Floorplan command +description: | + Query the dimensions of a structure + template to build one. +creative: false +objectives: + - teaser: Build structure + goal: + - | + Build a `wooden box`{=structure} structure. + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + foundBox <- structure "wooden box" 0; + return $ isRight foundBox; +robots: + - name: base + dir: east + devices: + - ADT calculator + - blueprint + - branch predictor + - comparator + - dictionary + - grabber + - logger + - treads + inventory: + - [100, board] +solution: | + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + def mkRow = \width. + doN width $ (place "board"; move;); + turn back; + doN width move; + end; + + def mkRows = \height. \width. + doN height $ (mkRow width; turn left; move; turn left); + end; + + dims <- floorplan "wooden box"; + let width = fst dims in + let height = snd dims in + + mkRows height width; +structures: + - name: wooden box + recognize: [north] + structure: + palette: + 'b': [stone, board] + map: | + bbbbbbb + bbbbbbb + bbbbbbb + bbbbbbb + bbbbbbb +known: [board] +world: + dsl: | + {blank} + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + upperleft: [0, 0] + map: | + .......... + .B........ + .......... + .......... + .......... + .......... + .......... diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml @@ -0,0 +1,75 @@ +version: 1 +name: Structure recognizer - Overlaps +description: | + Completing a row that lies between two partially-complete structures + may complete both of them, but only one will be registered. +creative: false +objectives: + - teaser: Build structure + goal: + - | + Build a `precious`{=structure} structure + condition: | + foundStructure <- structure "precious" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: east + devices: + - grabber + - treads + inventory: + - [50, quartz] + - [50, gold] + - [50, silver] + - [50, mithril] + - [50, cotton] +solution: | + move; + place "quartz"; + move; + place "quartz"; + move; + place "mithril"; +structures: + - name: precious + recognize: [north] + structure: + mask: '.' + palette: + 'q': [stone, quartz] + 'g': [stone, gold] + 's': [stone, silver] + 'm': [stone, mithril] + map: | + qgs + gsq + qqm + - name: smallish + recognize: [north] + structure: + mask: '.' + palette: + 'q': [stone, quartz] + 'm': [stone, mithril] + 'c': [stone, cotton] + map: | + qqm + cqq +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'q': [grass, quartz] + 'g': [grass, gold] + 's': [grass, silver] + 'c': [grass, cotton] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + .qgs. + .gsq. + B.... + .cqq. 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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml @@ -0,0 +1,109 @@ +version: 1 +name: Structure recognition - interior space +description: | + Entities can be added and removed + on empty cells within the rectangular + boundary of an already-placed structure without + affecting its recognition status. + + 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 + prerequisite: grab_rock + goal: + - | + 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 + j <- robotnamed "judge"; + as j { + structBounds <- floorplan "pigpen"; + + // Move to bottom-left corner + teleport self structPos; + + rockCount <- resonate "rock" ((0, 0), structBounds); + return $ rockCount > 0; + } + ); + - teaser: Grab rock + id: grab_rock + prerequisite: prerecognized + goal: + - | + Grab an entity from inside a `pigpen`{=structure} structure. + condition: | + as base { + has "rock"; + } + - teaser: Prerecognize + id: prerecognized + goal: + - | + `pigpen`{=structure} structure should be recognized upon initialization, + even with an extraneous entity within its bounds. + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + foundBox <- structure "pigpen" 0; + return $ isRight foundBox; +robots: + - name: base + dir: east + devices: + - ADT calculator + - blueprint + - grabber + - logger + - treads + - name: judge + dir: east + system: true + display: + invisible: true +solution: | + move; move; + x <- grab; + move; + place x; +structures: + - name: pigpen + recognize: [north] + structure: + palette: + 'b': [stone, board] + mask: '.' + map: | + bbbb + b..b + b..b + bbbb +known: [board, rock] +world: + dsl: | + {blank} + placements: + - src: pigpen + offset: [1, 0] + - src: pigpen + offset: [3, -6] + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + 'r': [grass, rock] + 'j': [grass, erase, judge] + upperleft: [-7, 3] + map: | + j..... + ...... + B.r... + ...... + ...... 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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-nested-structure-definition.yaml @@ -0,0 +1,100 @@ +version: 1 +name: Structure recognizer - nested structure +description: | + Ensure nested structures are assembled correctly. + Demonstrate structure recognition both before + a member is removed and after replacing it. +creative: false +objectives: + - teaser: Re-recognized + prerequisite: grab_tree + goal: + - | + 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); + - teaser: Pre-recognized + id: pre_recognized + prerequisite: + not: grab_tree + goal: + - | + Pre-placed structure must be recognized + condition: | + foundStructure <- structure "double ring" 0; + return $ case foundStructure (\_. false) (\_. true); + - teaser: Grab tree + id: grab_tree + goal: + - | + Grab a `tree`{=entity} + condition: | + as base { + has "tree"; + } +solution: | + move; move; + t <- grab; + place t; +robots: + - name: base + dir: south + devices: + - grabber + - treads +structures: + - name: double ring + recognize: [north] + structure: + palette: + 's': [ice, tree] + mask: '.' + structures: + - name: treering + structure: + palette: + 'p': [dirt, tree] + map: | + p + p + placements: + - src: treering + offset: [0, 0] + - src: treering + offset: [2, 0] + map: | + .s. + ... + - name: flowerbox + recognize: [north] + structure: + palette: + 'f': [ice, flower] + mask: '.' + map: | + fff + f.f + f.f + fff +known: [tree, flower] +world: + name: root + dsl: | + {blank} + placements: + - src: double ring + offset: [4, -2] + - src: flowerbox + offset: [1, 0] + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [-4, 7] + map: | + ....B... + ........ + ........ + ........ + ........ 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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml @@ -0,0 +1,71 @@ +version: 1 +name: Structure recognizer - Tiebreaking overlaps by size +description: | + A larger overlapping structure should always win the tiebreaker +creative: false +objectives: + - teaser: Build structure + prerequisite: + not: wrong_structure + goal: + - | + Build a 3x3 structure + condition: | + foundStructure <- structure "large" 0; + return $ case foundStructure (\_. false) (\_. true); + - id: wrong_structure + teaser: Don't recognize small structure + optional: true + goal: + - | + The small structure shouldn't be recognized. + condition: | + foundStructure <- structure "small" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: east + devices: + - grabber + - treads + inventory: + - [1, gold] + - [1, silver] +solution: | + move; + place "gold"; +structures: + - name: large + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + sss + ggs + ggs + - name: small + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + map: | + gg + gg +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + .sss + .ggs + B.gs 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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml @@ -0,0 +1,76 @@ +version: 1 +name: Structure recognizer - Tiebreaking overlaps by position +description: | + A more lower-left overlapping structure of + identical size should win the tiebreaker +creative: false +objectives: + - teaser: Build structure + prerequisite: + not: wrong_structure + goal: + - | + Build a `topleft`{=structure} structure + condition: | + foundStructure <- structure "topleft" 0; + return $ case foundStructure (\_. false) (\_. true); + - id: wrong_structure + teaser: Don't recognize small structure + optional: true + goal: + - | + The `bottomright`{=structure} structure shouldn't be recognized. + condition: | + foundStructure <- structure "bottomright" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: east + devices: + - grabber + - treads + inventory: + - [1, gold] + - [1, silver] +solution: | + move; move; move; + place "gold"; +structures: + - name: topleft + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + ss + gg + gg + - name: bottomright + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + gg + gg + ss +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + ..ss. + ..gg. + B.g.g + ...gg + ...ss diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml @@ -0,0 +1,89 @@ +version: 1 +name: Structure recognizer - placement occlusion +description: | + Pre-placed structures should be recognized, unless some other + structure or content has overwritten them. +creative: false +objectives: + - id: complete_green_structure + teaser: Complete green structure + prerequisite: + not: complete_red_structure + goal: + - | + Build a `green_jewel`{=structure} structure + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundGreen <- structure "green_jewel" 0; + return $ isRight foundGreen; + - id: complete_red_structure + optional: true + teaser: Complete red structure + goal: + - | + A `red_jewel`{=structure} structure should not be recognized + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundRed <- structure "red_jewel" 0; + return $ isRight foundRed; +robots: + - name: base + dir: east + devices: + - fast grabber + - treads + inventory: + - [1, pixel (R)] +solution: | + noop; +structures: + - name: red_jewel + recognize: [north] + structure: + palette: + 'r': [stone, pixel (R)] + map: | + rrr + rrr + rrr + - name: green_jewel + recognize: [north] + structure: + palette: + 'g': [stone, pixel (G)] + map: | + ggg + ggg + ggg +known: [pixel (R), pixel (G)] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [-97, 17] + placements: + - src: red_jewel + offset: [1, -1] + - src: red_jewel + offset: [1, -5] + - src: red_jewel + offset: [5, -1] + - src: red_jewel + offset: [5, -5] + - src: green_jewel + offset: [3, -3] + map: | + ......... + ......... + ......... + B........ + ......... + ......... + ......... + ......... + ......... diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml @@ -0,0 +1,65 @@ +version: 1 +name: Structure recognizer - removal +description: | + Remove a structure from the registry + when one of its cells are removed. +creative: false +objectives: + - teaser: Destroy structure + prerequisite: complete_structure + goal: + - | + Remove a piece of the structure to destroy it + condition: | + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. true) (\_. false); + - id: complete_structure + teaser: Complete structure + goal: + - | + Build a `chessboard`{=structure} structure + condition: | + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: south + devices: + - grabber + - treads + inventory: + - [1, gold] + - [1, silver] +solution: | + move; + place "silver"; + grab; +structures: + - name: chessboard + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + gsgs + sgsg + gsgs + sgsg +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + ...B. + gsg.g + sgsgs + gsgsg + sgsgs diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml @@ -0,0 +1,115 @@ +version: 1 +name: Structure recognizer - swap +description: | + Change one structure into another. + Also tests pre-registration of structures. +creative: false +objectives: + - teaser: Complete blue structure + prerequisite: complete_green_structure + goal: + - | + Build a `blue_jewel`{=structure} structure + 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); + - id: complete_green_structure + teaser: Complete green structure + prerequisite: complete_red_structure + goal: + - | + Build a `green_jewel`{=structure} structure + 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); + - id: complete_red_structure + teaser: Complete red structure + goal: + - | + Build a `red_jewel`{=structure} structure + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundRed <- structure "red_jewel" 0; + return $ isRight foundRed; +robots: + - name: base + dir: east + devices: + - fast grabber + - treads + inventory: + - [1, pixel (G)] + - [1, pixel (B)] +solution: | + move; move; move; + swap "pixel (G)"; + swap "pixel (B)"; +structures: + - name: red_jewel + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + 'j': [stone, pixel (R)] + map: | + ggggg + gsssg + gsjsg + gsssg + ggggg + - name: green_jewel + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + 'j': [stone, pixel (G)] + map: | + ggggg + gsssg + gsjsg + gsssg + ggggg + - name: blue_jewel + recognize: [north] + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + 'j': [stone, pixel (B)] + map: | + ggggg + gsssg + gsjsg + gsssg + ggggg +known: [gold, silver, pixel (R), pixel (G), pixel (B)] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [0, 0] + placements: + - src: red_jewel + offset: [1, 0] + map: | + ...... + ...... + B..... + ...... + ...... 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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-preplacement-recognition.yaml @@ -0,0 +1,47 @@ +version: 1 +name: Rotated pre-placed structure recognition +description: | + Pre-placed structure recognition with rotation +creative: false +objectives: + - teaser: Have structure + goal: + - | + Have a `tee`{=structure} structure + condition: | + foundStructure <- structure "tee" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: east +solution: | + noop; +structures: + - name: tee + recognize: [north, south, east, west] + description: "A tee pattern of flowers" + structure: + mask: '.' + palette: + 'x': [stone, flower] + map: | + .x. + xxx +known: [flower] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [0, 0] + placements: + - src: tee + offset: [2, 0] + orient: + up: east + map: | + B.... + ..... + ..... diff --git a/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-recognition.yaml b/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-recognition.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1644-rotated-recognition.yaml @@ -0,0 +1,51 @@ +version: 1 +name: Rotated structure recognition +description: | + Structure recognition with rotation +creative: false +objectives: + - teaser: Build structure + goal: + - | + Build a `tee`{=structure} structure + condition: | + foundStructure <- structure "tee" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: east + devices: + - grabber + - treads + inventory: + - [4, flower] +solution: | + move; move; + turn right; + move; move; + place "flower"; +structures: + - name: tee + recognize: [north, south, east, west] + description: "A tee pattern of flowers" + structure: + mask: '.' + palette: + 'x': [stone, flower] + map: | + .x. + xxx +known: [flower] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'x': [stone, flower] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + B.x.. + ..xx. + ..... diff --git a/data/scenarios/Testing/1598-detect-entity-change.yaml b/data/scenarios/Testing/1598-detect-entity-change.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1598-detect-entity-change.yaml @@ -0,0 +1,109 @@ +version: 1 +name: Entity change detection +author: Karl Ostmo +description: | + Ensure that a change to an entity can be observed + by a system robot within a single tick. + + In this scenario, the base will first `swap` the + existing `dial (R)`{=entity} with a `dial (G)`{=entity}, + then immediately `swap` again with a `dial (B)`{=entity}. + + The system robot should be able to detect the presence + of the `dial (G)`{=entity} before it is `swap`ped a second time. +creative: false +seed: 0 +objectives: + - goal: + - | + Turn the light green + condition: | + as base {has "flower"}; + prerequisite: + not: blue_light + - id: blue_light + teaser: No blue light + optional: true + goal: + - | + Turn the light blue + condition: | + r <- robotnamed "lockbot"; + as r {ishere "dial (B)"}; +robots: + - name: base + dir: [1, 0] + display: + invisible: true + devices: + - hourglass + - fast grabber + - logger + - treads + inventory: + - [1, "dial (R)"] + - [1, "dial (G)"] + - [1, "dial (B)"] + - name: lockbot + system: true + display: + invisible: true + dir: [1, 0] + program: | + def doUntilCorrect = + herenow <- ishere "dial (G)"; + if herenow { + give base "flower"; + } { + loc <- whereami; + surveil loc; + wait 1000; + doUntilCorrect; + } + end; + + def go = + doUntilCorrect; + end; + + go; + inventory: + - [1, flower] +solution: | + move; + move; + swap "dial (G)"; + swap "dial (B)"; +entities: + - name: "dial (R)" + display: + char: '•' + attr: red + description: + - A red dial + properties: [known, pickable] + - name: "dial (G)" + display: + char: '•' + attr: green + description: + - A green dial + properties: [known, pickable] + - name: "dial (B)" + display: + char: '•' + attr: blue + description: + - A blue dial + properties: [known, pickable] +world: + dsl: | + {blank} + upperleft: [-1, -1] + offset: false + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + 'c': [grass, dial (R), lockbot] + map: | + B.c diff --git a/data/scenarios/Testing/1631-tags.yaml b/data/scenarios/Testing/1631-tags.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1631-tags.yaml @@ -0,0 +1,130 @@ +version: 1 +name: Test tag commands +description: | + Test the `hastag` and `tagmembers` command. +objectives: + - condition: | + as base {has "mushroom"} + prerequisite: + not: got_fruit + goal: + - | + Pick up something `edible`{=tag} that is not a `fruit`{=tag}. + - teaser: "No fruit!" + 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; + + checkFruit 0; + 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; + ); + + if isTarget { + grab; + return (); + } { + move; + findTarget; + } + end; + + findTarget; +robots: + - name: base + dir: east + devices: + - ADT calculator + - branch predictor + - barcode scanner + - dictionary + - grabber + - lambda + - lodestone + - logger + - scanner + - solar panel + - strange loop + - treads +entities: + - name: barcode scanner + display: + attr: red + char: 'S' + description: + - Reads the 'tag' of an item + properties: [pickable] + capabilities: [hastag, tagmembers] + - name: canteloupe + display: + char: 'c' + description: + - Melon + tags: [edible, fruit] + properties: [pickable] + - name: mushroom + display: + char: 'm' + description: + - Nature's tiny umbrella. + tags: [edible, fungus] + properties: [pickable] + - name: gravel + display: + char: 'g' + description: + - Crushed rock + properties: [pickable] + - name: strawberry + display: + char: 's' + description: + - Just ripe + tags: [edible, fruit] + - name: peach + display: + char: 'g' + description: + - Just ripe + tags: [edible, fruit] + properties: [pickable] +world: + palette: + '.': [grass] + 'B': [grass, null, base] + 'a': [grass, canteloupe] + 'b': [grass, gravel] + 'c': [grass, strawberry] + 'd': [grass, mushroom] + 'e': [grass, peach] + upperleft: [-5, 5] + map: | + ....... + B.abcde + ....... diff --git a/data/scenarios/Testing/1634-message-colors.yaml b/data/scenarios/Testing/1634-message-colors.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1634-message-colors.yaml @@ -0,0 +1,40 @@ +version: 1 +name: Robot message log coloring +description: | + Demo color selection for robot log messages +robots: + - name: base + devices: + - logger + - hearing aid + - name: saybot + system: true + display: + invisible: false + attr: blue + program: | + loc <- whereami; + let idx = -(snd loc) in + wait $ idx + 1; + say $ "Hello saybot" ++ format idx; +world: + palette: + '.': [grass] + 'B': [grass, null, base] + 's': [grass, null, saybot] + upperleft: [0, 0] + map: | + B.s + ..s + ..s + ..s + ..s + ..s + ..s + ..s + ..s + ..s + ..s + ..s + ..s + ..s diff --git a/data/scenarios/Testing/1642-biomes.yaml b/data/scenarios/Testing/1642-biomes.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1642-biomes.yaml @@ -0,0 +1,102 @@ +version: 1 +name: Demo growth biomes +description: | + Demonstrate growth restrictions. + + `move`-ing to the distant goal cell gives the + `wheat`{=entity} enough time to grow back. +objectives: + - id: harvested + goal: + - | + `harvest` both `wheat`{=entity}, + from west to east. + Only the eastern wheat should grow back. + condition: | + as base { + c <- count "wheat"; + return $ c == 2; + } + - id: western_wheat_regrew + optional: true + goal: + - | + Wheat in grass must not regrow + condition: | + observer <- robotnamed "observer"; + as observer { + ishere "wheat"; + } + prerequisite: harvested + - goal: + - | + Go to the stone patch. + This takes at least 10 ticks, + by which time the + `wheat`{=entity} would have grown back. + Fails if the western wheat does grow back. + condition: | + goalbot <- robotnamed "goalbot"; + baseLoc <- as base {whereami}; + as goalbot { + goalLoc <- whereami; + return $ baseLoc == goalLoc; + } + prerequisite: + logic: + and: + - harvested + - not: western_wheat_regrew +solution: | + move; harvest; + move; harvest; + move; + move; move; move; move; move; + move; move; move; move; move; +robots: + - name: base + dir: east + devices: + - logger + - scythe + - treads + - name: observer + dir: east + system: true + - name: goalbot + 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' + description: + - Curved blade on a long handle + properties: [known] + capabilities: + - harvest + biomes: [dirt] +known: [flower] +world: + default: [blank] + palette: + '.': [grass] + 'd': [dirt] + 's': [stone, null, goalbot] + 'w': [grass, wheat, observer] + 'W': [dirt, wheat] + 'B': [grass, null, base] + upperleft: [-1, 1] + map: | + ..dd.......... + BwWd.........s + .............. diff --git a/data/scenarios/Testing/1681-pushable-entity.yaml b/data/scenarios/Testing/1681-pushable-entity.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1681-pushable-entity.yaml @@ -0,0 +1,56 @@ +version: 1 +name: Push test +creative: false +description: Push item +objectives: + - goal: + - Push a crate onto the stone pad + condition: | + j <- robotnamed "judge"; + as j {ishere "crate"} +solution: | + move; + push; +robots: + - name: base + dir: east + display: + char: Ω + attr: robot + devices: + - branch predictor + - calculator + - compass + - dictionary + - grabber + - logger + - net + - scanner + - treads + - dozer blade + - name: judge + dir: north + system: true + display: + char: j + attr: robot + invisible: true +entities: + - name: crate + display: + attr: wood + char: 'c' + description: + - Pushable crate + properties: [known, pushable] +known: [water] +world: + dsl: | + {water} + palette: + 'Ω': [grass, erase, base] + 'j': [stone, erase, judge] + 'x': [grass, crate] + upperleft: [0, 0] + map: | + Ωxxj diff --git a/data/scenarios/Testing/1721-custom-walkable-entities.yaml b/data/scenarios/Testing/1721-custom-walkable-entities.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1721-custom-walkable-entities.yaml @@ -0,0 +1,86 @@ +version: 1 +name: Custom walkability +description: | + The monkey can only walk on `tree`{=entity}s (and `banana`{=entity}s). + The `path` command must fail until the path of `tree`{=entity}s is completed. + + NOTE: In order for the objectives to be evaluated properly for a "Win", they must be + ordered strictly with "banana_access" coming before "placed_tree" in the + list below. +objectives: + - id: banana_access + teaser: Banana access + goal: + - Give monkey access to `banana`{=entity} + condition: | + m <- robotnamed "monkey"; + as m { + p <- path (inR 10) (inR "banana"); + return $ case p (\_. false) (\_. true); + }; + - id: placed_tree + teaser: Tree placed + prerequisite: + not: banana_access + goal: + - Tree must be placed + condition: | + x <- as base {has "tree"}; + return $ not x; +solution: | + move; + move; + place "tree" +entities: + - name: banana + display: + char: ')' + attr: gold + description: + - Tasty treat for a monkey + properties: [known, pickable] +robots: + - name: base + dir: east + display: + attr: robot + devices: + - logger + - grabber + - treads + - dictionary + - net + inventory: + - [1, tree] + - name: monkey + dir: south + display: + char: M + attr: robot + devices: + - logger + - grabber + - treads + - dictionary + - net + walkable: + only: + - tree + - banana +known: [tree] +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + 'M': [grass, null, monkey] + '.': [grass] + 'T': [grass, tree] + 'b': [grass, banana] + upperleft: [0, 0] + map: | + ..M. + ..T. + B... + ..T. + ..b. diff --git a/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml b/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml @@ -0,0 +1,101 @@ +version: 1 +name: Custom walkability - whitelist +description: | + Exercise various scenarios of path cache invalidation. +objectives: + - goal: + - Get somewhere + condition: | + as base {ishere "platform"} +solution: | + def goDir = \f. \result. + let d = fst result in + if (d == down) {return ()} {turn d; move; f;} + end; + + def followRoute = + nextDir <- path (inL ()) (inR "platform"); + case nextDir return $ goDir followRoute; + end; + + followRoute; +entities: + - name: platform + display: + char: 'P' + attr: ice + description: + - Goal at the end of the trees + properties: [known] + - name: wayfinder + display: + char: 'w' + description: + - | + Enables the `path` command: + - | + `path : (Unit + Int) -> ((Int * Int) + Text) -> Cmd (Unit + (Dir * Int))` + - | + Optionally supply a distance limit as the first argument, and + supply either a location (`inL`) or an entity (`inR`) as the second argument. + - | + Example: + - | + `path (inL ()) (inR "tree");` + - If a path exists, returns the direction to proceed along. + properties: [known, pickable] + capabilities: [path] +robots: + - name: base + dir: east + display: + attr: robot + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - grabber + - logger + - net + - treads + - wayfinder + walkable: + only: + - tree + - platform + - name: sysbot + dir: east + system: true + display: + attr: robot + invisible: false + program: | + move; + t <- grab; + move; + place t; + turn left; + move; + move; + t2 <- grab; + turn back; + move; +known: [tree] +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + 'S': [grass, null, sysbot] + '.': [grass] + 'T': [grass, tree] + 'P': [grass, platform] + upperleft: [0, 0] + map: | + ............ + ......TTT... + BTTTTTTTTP.. + ............ + .....ST..... diff --git a/data/scenarios/Testing/1747-volume-command.yaml b/data/scenarios/Testing/1747-volume-command.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1747-volume-command.yaml @@ -0,0 +1,56 @@ +version: 1 +name: Demo volume command +description: | + Measure volume of enclosed space +creative: true +objectives: + - goal: + - | + Make an enclosed volume of 14 cells + condition: | + as base { + let targetVolume = 14 in + vol <- volume targetVolume; + return $case vol (\_. false) (\x. x == targetVolume); + } +solution: | + move; + push; + turn left; + move; + turn right; + move; + turn right; + push; +robots: + - name: base + dir: east + devices: + - ADT calculator + - treads + - dozer blade + - logger + - branch predictor + - comparator +entities: + - name: monolith + display: + char: '@' + description: + - Pushable rock + properties: [known, unwalkable, pickable] +known: [mountain] +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + '.': [grass] + 'A': [stone, mountain] + '@': [grass, monolith] + upperleft: [-1, 1] + map: | + AAAAAAAAA + A.......A + AB.@....A + AAAA.AAAA diff --git a/data/scenarios/Testing/1775-custom-terrain.yaml b/data/scenarios/Testing/1775-custom-terrain.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1775-custom-terrain.yaml @@ -0,0 +1,58 @@ +version: 1 +name: Demo custom terrain +description: | + Colorful new terrain +creative: false +attrs: + - name: beachsand + bg: "#c2b280" + - name: lava + bg: "#dd7733" + - name: lilac + bg: "#a4a4bb" +terrains: + - name: beach + attr: beachsand + description: | + Shoreline covering, laborious to cross + - name: lava + attr: lava + description: | + Scorching, liquid rock + - name: heather + attr: lilac + description: | + Flowery ground cover +objectives: + - goal: + - | + No entities should be here + condition: | + as base { + isEmpty + } +solution: | + noop +robots: + - name: base + dir: east +known: [] +world: + dsl: | + {grass} + palette: + 'B': [heather, null, base] + '.': [heather] + 'i': [ice] + 'b': [beach] + 'v': [lava] + upperleft: [0, 0] + map: | + vvvvvvvv + vvvvvvvv + B....... + ........ + iiiiiiii + iiiiiiii + bbbbbbbb + bbbbbbbb diff --git a/data/scenarios/Testing/1777-capability-cost.yaml b/data/scenarios/Testing/1777-capability-cost.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1777-capability-cost.yaml @@ -0,0 +1,94 @@ +version: 1 +name: Capability cost +description: | + Consume inventory by exercising device capabilities +creative: false +seed: 0 +objectives: + - goal: + - | + Eliminate the `packing peanut`{=entity}s + condition: | + hasLighterFluid <- as base { + has "lighter fluid"; + }; + + if (not hasLighterFluid) { + judge <- robotnamed "judge"; + as judge { + maybePath <- path (inL ()) (inR "packing peanut"); + return $ case maybePath (\_. true) (\d. false); + } + } { + return false; + }; +solution: | + move; + turn right; + move; + place "packing peanut"; + ignite down; + move; + move; + ignite forward; +robots: + - name: base + dir: east + devices: + - treads + - logger + - Zippo + - grabber + inventory: + - [2, lighter fluid] + - [1, packing peanut] + - name: judge + dir: east + system: true +entities: + - name: lighter fluid + display: + char: 'f' + description: + - Fuel for a `Zippo`{=entity} + properties: [known, pickable] + - name: Zippo + display: + char: 'z' + description: + - Ignites things + properties: [known, pickable] + capabilities: + - capability: ignite + cost: + - [1, "lighter fluid"] + - name: packing peanut + display: + attr: snow + char: 's' + description: + - Easy to drop, but impossible to pick up. + - Highly combustible. + properties: [known, combustible] + combustion: + ignition: 0.5 + duration: [10, 20] + product: ash +known: [water, ash] +world: + dsl: | + {water} + palette: + 'B': [grass, erase, base] + 'j': [grass, erase, judge] + '.': [grass, erase] + 'c': [grass, packing peanut] + upperleft: [-1, 1] + map: | + ...... + Bcccc. + .j.... + .cccc. + ...... + .cccc. + ...... diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt b/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt @@ -0,0 +1,3 @@ +nonoverlapping-structure-merge.yaml +root-map-expansion.yaml +structure-composition.yaml diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml @@ -0,0 +1,59 @@ +version: 1 +name: Expansion of a substructure to fit its placements +description: | + Define two structures and place them on the map. +robots: + - name: base + loc: [4, -4] + dir: east +known: [water, sand, tree] +world: + palette: + '.': [grass] + upperleft: [-1, 1] + structures: + - name: vertical rectangle + structure: + palette: + 'x': [blank, tree] + map: | + xx + xx + xx + xx + - name: horizontal rectangle + structure: + palette: + 'x': [blank, sand] + map: | + xxxx + xxxx + - name: disjoint rectangles + structure: + palette: + 'x': [blank, water] + map: | + xx + xx + placements: + - src: vertical rectangle + offset: [-7, 7] + - src: horizontal rectangle + offset: [7, -7] + placements: + - src: disjoint rectangles + offset: [2, -2] + map: | + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml @@ -0,0 +1,30 @@ +version: 1 +name: Non-overlapping merging with expansion +description: | + Define two structures and place them on the map. + + Demonstrates automatic expansion of the root map grid. +robots: + - name: base + loc: [8, 0] + dir: east +known: [tree, sand, water] +world: + palette: + '.': [grass] + 'i': [ice] + 'j': [dirt] + upperleft: [3, 3] + structures: + - name: single tree + structure: + palette: + 'x': [blank, tree] + map: | + x + placements: + - src: single tree + offset: [-2, -4] + map: | + i. + .j diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml @@ -0,0 +1,99 @@ +version: 1 +name: Various structure merging arrangements +description: | + Define two structures and place them on the map. +robots: + - name: base + loc: [11, 0] + dir: east +known: [water, sand] +world: + palette: + '.': [grass] + upperleft: [-1, 1] + structures: + - name: vertical rectangle + structure: + palette: + 'x': [blank, water] + map: | + xx + xx + xx + xx + - name: horizontal rectangle + structure: + palette: + 'x': [blank, sand] + map: | + xxxx + xxxx + - name: combined rectangles blank base + structure: + palette: + 'x': [blank] + map: | + xxxx + xxxx + xxxx + xxxx + placements: + - src: vertical rectangle + - src: horizontal rectangle + - name: combined rectangles empty base + structure: + map: "" + placements: + - src: vertical rectangle + - src: horizontal rectangle + - name: combined rectangles single cell base + structure: + palette: + 'x': [blank] + map: | + x + placements: + - src: vertical rectangle + - src: horizontal rectangle + - name: multi overlap + structure: + palette: + 'x': [blank] + map: | + xxxx + placements: + - src: vertical rectangle + offset: [1, 0] + - src: horizontal rectangle + offset: [0, -2] + - src: vertical rectangle + offset: [3, -2] + - src: horizontal rectangle + offset: [3, -4] + - src: vertical rectangle + offset: [5, -4] + placements: + - src: vertical rectangle + offset: [1, -1] + - src: horizontal rectangle + offset: [1, -1] + - src: multi overlap + offset: [1, -6] + - src: combined rectangles blank base + offset: [6, -1] + - src: combined rectangles empty base + offset: [11, -1] + - src: combined rectangles single cell base + offset: [11, -6] + 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 @@ -5,3 +5,4 @@ 201-require-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 new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/1664-require-system-robot-children.yaml @@ -0,0 +1,51 @@ +version: 1 +name: Requirements of system-robot children +description: | + Normally, system robots are not required to possess devices in order to use any particular command. + However, a robot built by a system robot becomes subject to the requirement. + This is a bug. + + In this scenario, the child robot cannot be built because the + parent robot ("queenbee") does not possess a "beaglepuss" in its inventory. +objectives: + - condition: | + try { + robotnamed "childbot"; + return true; + } { + return false; + } +solution: | + noop; +robots: + - name: base + dir: east + - name: queenbee + dir: east + system: true + display: + invisible: false + char: 'Q' + inventory: + - [1, solar panel] + - [0, beaglepuss] + program: | + def createWorker = + build { + setname "childbot"; + appear "B" (inl ()); + }; + end; + + createWorker; +known: [water] +world: + palette: + '.': [grass] + 'B': [grass, null, base] + 'Q': [grass, null, queenbee] + upperleft: [-1, 1] + map: | + B..Q + .... + .... 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 @@ -18,8 +18,8 @@ build {require "boat"; move; move} robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - 3D printer - logger 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 @@ -18,8 +18,8 @@ build {require "boat"; move; move} robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - 3D printer @@ -46,7 +46,7 @@ attr: water char: ' ' description: - - An infinite ocean of water. - properties: [known, portable, growable, liquid] - growth: [0,0] + - An infinite ocean of water. + properties: [known, pickable, growable, liquid] + growth: [0, 0] yields: water 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 @@ -17,8 +17,8 @@ build {require "boat"; move; require "boat"; move} robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - 3D printer - logger diff --git a/data/scenarios/Testing/201-require/201-require-entities-def.yaml b/data/scenarios/Testing/201-require/201-require-entities-def.yaml --- a/data/scenarios/Testing/201-require/201-require-entities-def.yaml +++ b/data/scenarios/Testing/201-require/201-require-entities-def.yaml @@ -17,8 +17,8 @@ build { log "hi"; require 5 "rock"; mp; mp; mp; mp } robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - 3D printer - logger diff --git a/data/scenarios/Testing/201-require/201-require-entities.yaml b/data/scenarios/Testing/201-require/201-require-entities.yaml --- a/data/scenarios/Testing/201-require/201-require-entities.yaml +++ b/data/scenarios/Testing/201-require/201-require-entities.yaml @@ -15,8 +15,8 @@ build { require 5 "rock"; move; place "rock"; move; place "rock" } robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - 3D printer - logger 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 @@ -31,8 +31,8 @@ reprogram fred {require "boat"; require "metal drill"; move; move} robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - 3D printer - logger 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 @@ -31,8 +31,8 @@ reprogram fred {require "boat"; require "metal drill"; move; require 3 "rock"; move; require 5 "rock"} robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - 3D printer - logger diff --git a/data/scenarios/Testing/231-requirements/00-ORDER.txt b/data/scenarios/Testing/231-requirements/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/231-requirements/00-ORDER.txt @@ -0,0 +1,1 @@ +231-command-transformer-reqs.yaml diff --git a/data/scenarios/Testing/231-requirements/231-command-transformer-reqs.yaml b/data/scenarios/Testing/231-requirements/231-command-transformer-reqs.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/231-requirements/231-command-transformer-reqs.yaml @@ -0,0 +1,36 @@ +name: Foo +version: 1 +description: | + A function transforming a command correctly accumulates requirements. +creative: false +solution: | + def pr = require 1 "rock"; move; place "rock" end + def x4 = \c. c;c;c;c end + build {x4 pr} +objectives: + - goal: + - Place four rocks + condition: | + judge <- robotNamed "judge"; + as judge {ishere "rock"} +robots: + - name: base + loc: [0, 0] + dir: east + devices: + - 3D printer + - solar panel + inventory: + - [4, rock] + - [1, treads] + - [1, grabber] + - [1, solar panel] + - [1, lambda] + - name: judge + loc: [4, 0] + system: true + display: + invisible: true +world: + dsl: | + {grass} 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 @@ -21,7 +21,7 @@ } robots: - name: base - dir: [0,1] + dir: north display: char: Ω attr: robot @@ -72,56 +72,47 @@ attr: copper' char: 'A' description: - - A place in the mountains where raw copper ore can be mined. - As it is hidden inside a mountain, a tunnel needs to be - first drilled through, so that the vein becomes accessible. + - A place in the mountains where raw copper ore can be mined. As it is hidden inside a mountain, a tunnel needs to be first drilled through, so that the vein becomes accessible. properties: [unwalkable] - - name: iron vein display: attr: iron' char: 'A' description: - - A place in the mountains where raw iron ore can be mined. - As it is hidden inside a mountain, a tunnel needs to be - first drilled through, so that the vein becomes accessible. + - A place in the mountains where raw iron ore can be mined. As it is hidden inside a mountain, a tunnel needs to be first drilled through, so that the vein becomes accessible. properties: [unwalkable] - recipes: ## TOY DRILL - in: - - [1, copper vein] + - [1, copper vein] out: - - [1, copper mine] - - [1, copper ore] + - [1, copper mine] + - [1, copper ore] required: - - [1, drill] + - [1, drill] time: 42 - - in: - - [1, iron vein] + - [1, iron vein] out: - - [1, iron mine] - - [1, iron ore] + - [1, iron mine] + - [1, iron ore] required: - - [1, drill] + - [1, drill] time: 64 - ## METAL DRILL - in: - - [1, copper vein] + - [1, copper vein] out: - - [1, copper mine] - - [1, copper ore] + - [1, copper mine] + - [1, copper ore] required: - - [1, metal drill] + - [1, metal drill] time: 6 - - in: - - [1, iron vein] + - [1, iron vein] out: - - [1, iron mine] - - [1, iron ore] + - [1, iron mine] + - [1, iron ore] required: - - [1, metal drill] + - [1, metal drill] time: 7 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 @@ -31,7 +31,7 @@ display: char: 'Ω' attr: robot - dir: [0,1] + dir: north devices: - 3D printer - life support system 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 @@ -30,8 +30,8 @@ place "detonator"; robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - treads - logger 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 @@ -10,17 +10,17 @@ - condition: | t <- time; return (t == 2) goal: - - | - This is a dummy condition that just ensures the base has had - time to run the problematic `build` command. The scenario - *should* generate an error message; what we really care about is - whether the generated error message is correct, which is checked - in test/integration/Main.hs . + - | + This is a dummy condition that just ensures the base has had + time to run the problematic `build` command. The scenario + *should* generate an error message; what we really care about is + whether the generated error message is correct, which is checked + in test/integration/Main.hs . solution: | build {move; turn right; loc <- whereami} robots: - name: base - dir: [0,1] + dir: north devices: - 3D printer - logger @@ -31,7 +31,7 @@ palette: 'Ω': [grass, null, base] '.': [grass] - upperleft: [0,1] + upperleft: [0, 1] map: | . Ω 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 @@ -15,21 +15,20 @@ botAlive <- isAlive "bot"; return (baseAlive && not botAlive); } { return false; } - solution: | log "start"; wait 5; robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - treads - logger program: "move" - name: bot - loc: [0,-1] - dir: [1,0] + loc: [0, -1] + dir: east devices: - treads program: "move" 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 @@ -16,16 +16,16 @@ log "I will win next tick!"; place "lambda"; robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - grabber inventory: - [1, lambda] - name: sleeper - loc: [0,-1] - dir: [1,0] + loc: [0, -1] + dir: east devices: - logger - clock 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 @@ -38,16 +38,16 @@ forever {tryharvest} robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - harvester inventory: - [1, lambda] - name: planter - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - grabber @@ -66,19 +66,19 @@ attr: plant char: 'W' description: - - A fast-growing weed. - properties: [known, portable, growable] - growth: [1,2] + - A fast-growing weed. + properties: [known, pickable, growable] + growth: [1, 2] - name: Win display: attr: device char: 'W' description: - You win! - properties: [known, portable] + properties: [known, pickable] world: palette: '.': [grass] - upperleft: [0,0] + upperleft: [0, 0] map: | . 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 @@ -25,16 +25,16 @@ forever {tryharvest} robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - harvester inventory: - [1, lambda] - name: planter - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - grabber @@ -55,12 +55,12 @@ attr: plant char: 'W' description: - - A fast-growing weed. - properties: [known, portable, growable] - growth: [1,2] + - A fast-growing weed. + properties: [known, pickable, growable] + growth: [1, 2] world: palette: '.': [grass] - upperleft: [0,0] + upperleft: [0, 0] map: | . 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 @@ -18,8 +18,8 @@ move; harvest; move; grab; turn right; move; grab; grab; harvest; grab robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - treads - harvester 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 @@ -14,14 +14,14 @@ place "tree" robots: - name: base - loc: [5,0] - dir: [1,0] + loc: [5, 0] + dir: east devices: - treads - logger - grabber inventory: - - [1, tree] + - [1, tree] world: palette: '.': [grass] 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 @@ -21,8 +21,8 @@ } robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - net @@ -59,14 +59,14 @@ attr: water char: 'G' description: - - A satellite navigation device. - properties: [known, portable] + - A satellite navigation device. + properties: [known, pickable] capabilities: [senseloc] - name: Tardis display: attr: water char: '█' description: - - Bigger on the inside. - properties: [known, portable] + - Bigger on the inside. + properties: [known, pickable] capabilities: [senseloc, 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 @@ -16,11 +16,11 @@ salvage robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east - name: fred - loc: [1,0] - dir: [0,0] + loc: [1, 0] + dir: [0, 0] inventory: - [1, rock] world: 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 @@ -3,7 +3,7 @@ description: Pick or drill lodestone and use it to flip bits. objectives: - goal: - - To create a drill bit, you will need to flip the available bit. + - To create a drill bit, you will need to flip the available bit. condition: | try { as base {has "drill bit"}; @@ -12,7 +12,7 @@ run "scenarios/Testing/562-lodestone.sw" robots: - name: base - dir: [1,0] + dir: east display: char: Ω attr: robot @@ -73,36 +73,31 @@ attr: iron' char: 'A' description: - - A place in the mountains where raw iron ore can be mined. - As it is hidden inside a mountain, a tunnel needs to be - first drilled through, so that the vein becomes accessible. + - A place in the mountains where raw iron ore can be mined. As it is hidden inside a mountain, a tunnel needs to be first drilled through, so that the vein becomes accessible. properties: [unwalkable] - - name: magnetic mine display: attr: iron' char: 'Å' description: - - A place in the mountains where raw iron ore can be mined. + - A place in the mountains where raw iron ore can be mined. properties: [unwalkable] - recipes: ## TOY DRILL - in: - - [1, magnetic vein] + - [1, magnetic vein] out: - - [1, magnetic mine] - - [1, lodestone] + - [1, magnetic mine] + - [1, lodestone] required: - - [1, drill] + - [1, drill] time: 42 - - in: - - [1, magnetic mine] + - [1, magnetic mine] out: - - [1, magnetic mine] - - [1, iron ore] - - [1, lodestone] + - [1, magnetic mine] + - [1, iron ore] + - [1, lodestone] required: - - [1, drill] + - [1, drill] time: 42 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 @@ -18,8 +18,8 @@ swap "bitcoin"; swap "gold coin"; robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - scanner @@ -29,8 +29,8 @@ - [1, gold coin] - [1, bitcoin] - name: watcher - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east system: true devices: - logger diff --git a/data/scenarios/Testing/687-watch-command.yaml b/data/scenarios/Testing/687-watch-command.yaml --- a/data/scenarios/Testing/687-watch-command.yaml +++ b/data/scenarios/Testing/687-watch-command.yaml @@ -22,7 +22,7 @@ grab; robots: - name: base - dir: [0,1] + dir: north display: char: Ω attr: robot @@ -32,7 +32,7 @@ - grabber - treads - name: competitor - dir: [0, -1] + dir: south display: char: b attr: robot @@ -48,7 +48,7 @@ turn back; move; - name: planter - dir: [1, 0] + dir: east display: char: p attr: robot @@ -66,12 +66,11 @@ world: palette: 'Ω': [grass, null, base] - p : [grass, null, planter] - b : [grass, null, competitor] + p: [grass, null, planter] + b: [grass, null, competitor] '.': [grass] - 'T': [grass, tree] upperleft: [0, 0] map: | - ......b... - .p........ - ......Ω... + ......b... + .p........ + ......Ω... 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 @@ -15,15 +15,15 @@ move; say "Fatal error: base was able to move into a boulder and not fail!" robots: - name: base - dir: [1,0] + dir: east devices: ["treads", "logger"] - name: one - dir: [1,0] + dir: east devices: ["treads", "logger"] program: | move; say "Fatal error: one was able to move into a boulder and not fail!" - name: two - dir: [1,0] + dir: east system: true devices: ["logger"] program: | 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 @@ -16,20 +16,20 @@ move; say "Fatal error: base was able to move into water and not fail!" robots: - name: base - dir: [1,0] + dir: east devices: ["treads", "logger"] - name: one - dir: [1,0] + dir: east devices: ["treads", "logger"] program: | move; say "Fatal error: one was able to move into water and not fail or drown!" - name: two - dir: [1,0] + dir: east devices: ["treads", "logger", "boat", "net"] program: | try {move} {say "Fatal error: two was unable to move into water even though it has a boat!"} - name: three - dir: [1,0] + dir: east system: true devices: ["logger"] program: | 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 @@ -19,18 +19,18 @@ try {teleport self (3,0)} {teleport self (5,0)} robots: - name: base - dir: [0,0] + dir: [0, 0] - name: one - dir: [1,0] + dir: east - name: two - dir: [-1,0] + dir: west - name: three - dir: [0,1] + dir: north system: true program: | t <- robotNamed "four"; teleport t (3,0); teleport self (3,0) - name: four - dir: [0,-1] + dir: south system: true world: palette: 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 @@ -48,17 +48,16 @@ ┌────┐--u~~U │....1..2../ └────┘--l~~L - robots: - name: base - dir: [1,0] - loc: [0,0] + dir: east + loc: [0, 0] devices: - treads - logger - name: check1 - dir: [0,0] - loc: [3,0] + dir: [0, 0] + loc: [3, 0] system: true display: invisible: true @@ -73,8 +72,8 @@ ); create "Win" - name: check2 - dir: [0,0] - loc: [6,0] + dir: [0, 0] + loc: [6, 0] system: true display: invisible: true @@ -89,8 +88,8 @@ ); create "Win" - name: check3 - dir: [0,0] - loc: [9,0] + dir: [0, 0] + loc: [9, 0] system: true display: invisible: true @@ -105,11 +104,11 @@ ); create "Win" - name: horizon - dir: [0,0] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,horizontal wall]] + 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); @@ -117,11 +116,11 @@ until (as c1 {has "Win"}); swap "horizontal wall" - name: vertice - dir: [0,0] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,vertical wall]] + 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); @@ -129,11 +128,11 @@ until (as c1 {has "Win"}); swap "vertical wall" - name: upright - dir: [0,0] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,upper right corner]] + 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); @@ -141,11 +140,11 @@ until (as c1 {has "Win"}); swap "upper right corner" - name: lowright - dir: [0,0] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,lower right corner]] + 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); @@ -153,11 +152,11 @@ until (as c1 {has "Win"}); swap "lower right corner" - name: upleft - dir: [0,0] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,upper left corner]] + inventory: [[1, upper left 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); @@ -165,51 +164,51 @@ until (as c1 {has "Win"}); swap "upper left corner" - name: upright0 - dir: [0,0] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,down and horizontal wall]] + 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 - dir: [0,0] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,up and horizontal wall]] + inventory: [[1, up and horizontal 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] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,down and horizontal wall]] + 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 - dir: [0,0] + dir: [0, 0] system: true display: invisible: true - inventory: [[1,up and horizontal wall]] + inventory: [[1, up and horizontal 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" - name: gate1 - dir: [0,0] + dir: [0, 0] system: true display: invisible: true @@ -219,7 +218,7 @@ until (as c1 {has "Win"}); grab - name: gate2 - dir: [0,0] + dir: [0, 0] system: true display: invisible: 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 @@ -34,7 +34,7 @@ display: char: 'Ω' attr: robot - dir: [0, 1] + dir: north devices: - workbench - grabber diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml --- a/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml @@ -27,7 +27,7 @@ display: char: 'Ω' attr: robot - dir: [0, 1] + dir: north devices: - workbench inventory: 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 @@ -13,18 +13,17 @@ logic: or: - and: - - id: have_furnace - - not: - id: have_flower + - id: have_furnace + - not: + id: have_flower - and: - - id: have_gear - - id: have_flower + - id: have_gear + - id: have_flower - id: have_furnace goal: - Make a "furnace". condition: | as base {has "furnace"}; - optional: true - id: have_gear goal: @@ -45,7 +44,7 @@ display: char: 'Ω' attr: robot - dir: [0, 1] + dir: north devices: - workbench - grabber 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 @@ -33,7 +33,7 @@ display: char: 'Ω' attr: robot - dir: [0, 1] + dir: north devices: - workbench - grabber 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 @@ -23,14 +23,14 @@ char: 'w' description: - Enables `path` command - properties: [known, portable] + properties: [known, pickable] capabilities: [path] - name: atlas display: char: 'a' description: - Enables `waypoint` command - properties: [known, portable] + properties: [known, pickable] capabilities: [waypoint] - name: kudzu display: @@ -46,12 +46,12 @@ attr: easter_egg description: - A colorful egg laid by the rabbit - properties: [known, portable] + properties: [known, pickable] growth: [5, 10] robots: - name: base loc: [0, 0] - dir: [1, 0] + dir: east devices: - ADT calculator - atlas @@ -67,7 +67,7 @@ - wayfinder - name: gardener description: Periodically chops down the kudzu plant - dir: [1, 0] + dir: east system: true devices: - ADT calculator @@ -83,7 +83,7 @@ program: | run "scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/gardener.sw" - name: rabbit - dir: [1, 0] + dir: east loc: [2, -2] system: true devices: 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 @@ -20,11 +20,11 @@ char: 'w' description: - Enables `path` command - properties: [known, portable] + properties: [known, pickable] capabilities: [path] robots: - name: base - dir: [1,0] + dir: east devices: - treads - logger @@ -38,7 +38,6 @@ '.': [grass] 'x': [stone, mountain] 'f': [grass, flower] - 'T': [grass, tree] upperleft: [0, 0] map: | xxxxx...... 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 @@ -26,11 +26,11 @@ char: 'w' description: - Enables `path` command - properties: [known, portable] + properties: [known, pickable] capabilities: [path] robots: - name: base - dir: [1,0] + dir: east devices: - treads - logger 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 @@ -15,7 +15,7 @@ move; robots: - name: base - dir: [1,0] + dir: east devices: - treads - logger 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 @@ -16,7 +16,7 @@ move; robots: - name: base - dir: [1,0] + dir: east devices: - treads - logger @@ -32,4 +32,3 @@ ....... ..B..f. ....... - 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 @@ -19,11 +19,11 @@ char: 'w' description: - Enables `path` command - properties: [known, portable] + properties: [known, pickable] capabilities: [path] robots: - name: base - dir: [1,0] + dir: east devices: - ADT calculator - branch predictor diff --git a/data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity.yaml b/data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity.yaml --- a/data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity.yaml +++ b/data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity.yaml @@ -16,11 +16,11 @@ char: 'w' description: - Enables `path` command - properties: [known, portable] + properties: [known, pickable] capabilities: [path] robots: - name: base - dir: [1,0] + dir: east devices: - ADT calculator - branch predictor diff --git a/data/scenarios/Testing/836-pathfinding/836-path-exists-find-location.yaml b/data/scenarios/Testing/836-pathfinding/836-path-exists-find-location.yaml --- a/data/scenarios/Testing/836-pathfinding/836-path-exists-find-location.yaml +++ b/data/scenarios/Testing/836-pathfinding/836-path-exists-find-location.yaml @@ -16,11 +16,11 @@ char: 'w' description: - Enables `path` command - properties: [known, portable] + properties: [known, pickable] capabilities: [path] robots: - name: base - dir: [1,0] + dir: east devices: - ADT calculator - branch predictor 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,4 +1,5 @@ -def goDir = \f. \d. +def goDir = \f. \r. + let d = fst r in if (d == down) { eggHere <- ishere "egg"; if eggHere {grab; return ()} {}; 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,4 +1,5 @@ -def goDir = \f. \d. +def goDir = \f. \r. + let d = fst r in if (d == down) { grab; return () } { 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,4 +1,5 @@ -def goDir = \goalItem. \f. \d. +def goDir = \goalItem. \f. \r. + let d = fst r in if (d == down) { grab; return () } { 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,4 +1,5 @@ -def goDir = \f. \d. +def goDir = \f. \r. + let d = fst r in if (d == down) { grab; return () } { 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 @@ -16,7 +16,7 @@ }; robots: - name: base - dir: [0, 1] + dir: north devices: - treads - scanner 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 @@ -14,7 +14,7 @@ }; robots: - name: base - dir: [0, 1] + dir: north devices: - treads - scanner diff --git a/data/scenarios/Testing/858-inventory/858-possession-objective.yaml b/data/scenarios/Testing/858-inventory/858-possession-objective.yaml --- a/data/scenarios/Testing/858-inventory/858-possession-objective.yaml +++ b/data/scenarios/Testing/858-inventory/858-possession-objective.yaml @@ -13,7 +13,7 @@ }; robots: - name: base - dir: [0, 1] + dir: north devices: - treads - scanner 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 @@ -8,29 +8,41 @@ r0 <- robotNamed "other0"; b0 <- as r0 { has "boat" }; teleport self (0,0); - b1 <- meetAll (\b. \r. b0 <- as r {has "boat"}; return (b && b0)) true; + 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}) + end; + rs <- meetAll; + b1 <- all rs (\r. as r {has "boat"}); n2 <- as r0 { count "boat" }; return (b0 && b1 && (n2 == 2)) solution: | mr0 <- meet; case mr0 (\_. return ()) (\r0. give r0 "boat"); - meetAll (\_. \r. give r "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) + end; + rs <- meetAll; + forM_ rs (\r. give r "boat") robots: - name: base - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east devices: - logger - antenna - - ADT calculator + - hyperloop - grabber inventory: - [7, boat] - name: other0 - loc: [0,0] - dir: [1,0] + loc: [0, 0] + dir: east - name: other - dir: [1,0] + dir: east world: palette: '.': [grass] 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 @@ -12,7 +12,7 @@ h <- heading; turn east; move; move; turn right; move; move; turn h robots: - name: base - dir: [0,1] + dir: north devices: - treads - compass 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 @@ -22,8 +22,8 @@ turn (if (snd loc < 0) {north} {south}); x (abs (snd loc)) move; robots: - name: base - dir: [0,1] - loc: [-5,5] + dir: north + loc: [-5, 5] devices: - clock - dictionary @@ -37,8 +37,8 @@ - branch predictor - logger - name: teleporter - dir: [0,1] - loc: [0,0] + dir: north + loc: [0, 0] system: true display: invisible: true @@ -62,4 +62,3 @@ ........... ........... ........... - diff --git a/data/scenarios/Testing/958-isempty.yaml b/data/scenarios/Testing/958-isempty.yaml --- a/data/scenarios/Testing/958-isempty.yaml +++ b/data/scenarios/Testing/958-isempty.yaml @@ -19,7 +19,7 @@ grab robots: - name: base - dir: [1,0] + dir: east devices: - scanner - branch predictor @@ -36,8 +36,8 @@ attr: gold char: 'Y' description: - - A thing that everyone needs! - properties: [portable] + - A thing that everyone needs! + properties: [pickable] world: palette: '.': [grass] 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 @@ -9,8 +9,8 @@ mover <- robotNumbered 1; as mover { loc <- whereami; return $ loc == (0,1) } goal: - - | - Get a robot to (0,1)! + - | + Get a robot to (0,1)! solution: | build {move} entities: @@ -19,12 +19,12 @@ attr: device char: 'o' description: - - A non-traditional means of locomotion. - properties: [known, portable] + - A non-traditional means of locomotion. + properties: [known, pickable] capabilities: [move] robots: - name: base - dir: [0,1] + dir: north devices: - 3D printer - logger @@ -35,7 +35,7 @@ palette: 'Ω': [grass, null, base] '.': [grass] - upperleft: [0,1] + upperleft: [0, 1] map: | . Ω 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 @@ -16,8 +16,8 @@ build { turn right; move; move; move } robots: - name: base - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north heavy: true display: char: Ω diff --git a/data/scenarios/Testing/_Validation/1138-nonexistent-nested-structure.yaml b/data/scenarios/Testing/_Validation/1138-nonexistent-nested-structure.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1138-nonexistent-nested-structure.yaml @@ -0,0 +1,55 @@ +version: 1 +name: Structure placement (nested) +description: | + Try to place a structure named "bitpair_bogus" + which does not exist. +robots: + - name: base + loc: [11, 0] + dir: east +world: + palette: + '.': [grass] + upperleft: [-1, 1] + structures: + - name: bitpair + structure: + palette: + '0': [stone, bit (0)] + '1': [stone, bit (1)] + map: | + 1 + 0 + - name: bigbox + structure: + palette: + '.': [stone] + 'T': [stone, tree] + structures: + - name: minibox + structure: + palette: + '.': [stone] + 'x': [stone, tree] + placements: + - src: bitpair_bogus + offset: [1, 0] + map: | + x. + .x + placements: + - src: minibox + offset: [0, -1] + map: | + T.T. + .T.T + placements: + - src: bigbox + offset: [1, -1] + - src: bitpair + offset: [1, -7] + map: | + ........ + ........ + ........ + ........ diff --git a/data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml b/data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml --- a/data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml +++ b/data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml @@ -15,18 +15,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east known: [tree] world: upperleft: [-1, 1] diff --git a/data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml b/data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml --- a/data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml +++ b/data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml @@ -15,18 +15,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east known: [tree] world: upperleft: [1, -1] diff --git a/data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml b/data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml --- a/data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml +++ b/data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml @@ -12,11 +12,11 @@ attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east known: [tree] world: upperleft: [1, -1] diff --git a/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml b/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml --- a/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml +++ b/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml @@ -15,18 +15,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor diff --git a/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml b/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml --- a/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml +++ b/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml @@ -15,18 +15,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor @@ -41,7 +41,7 @@ - strange loop - treads - name: judge - dir: [1, 0] + dir: east system: true display: char: 'J' diff --git a/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml b/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml --- a/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml +++ b/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml @@ -15,18 +15,18 @@ attr: portal_in char: "o" description: - - Portal entrance + - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description: - - Portal exit + - Portal exit properties: [known] robots: - name: base - dir: [1, 0] + dir: east devices: - ADT calculator - branch predictor @@ -41,7 +41,7 @@ - strange loop - treads - name: judge - dir: [1, 0] + dir: east system: true display: char: 'J' diff --git a/data/scenarios/Testing/_Validation/1575-recognized-placements-disallow-reorientation.yaml b/data/scenarios/Testing/_Validation/1575-recognized-placements-disallow-reorientation.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1575-recognized-placements-disallow-reorientation.yaml @@ -0,0 +1,40 @@ +version: 1 +name: Structure recognizer - placement occlusion +description: | + Disallow recognized structures from being placed with non-default orientation. +creative: false +robots: + - name: base + dir: east + devices: + - treads +structures: + - name: red_jewel + recognize: [east] + structure: + mask: '.' + palette: + 'r': [stone, pixel (R)] + map: | + rrrr + rrrr +known: [pixel (R), pixel (G)] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [0, 0] + placements: + - src: red_jewel + offset: [2, -2] + orient: + up: west + map: | + ....... + ....... + B...... + ....... + ....... diff --git a/data/scenarios/Testing/_Validation/1632-entity-attributes.yaml b/data/scenarios/Testing/_Validation/1632-entity-attributes.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1632-entity-attributes.yaml @@ -0,0 +1,19 @@ +version: 1 +name: | + Entity attribute validity +description: | + This should be rejected by the parser. +entities: + - name: scooter + display: + char: 'M' + attr: 'foobar' + description: + - My scooter +robots: [] +world: + palette: + 'x': [grass, null, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Testing/_Validation/1655-display-characters.yaml b/data/scenarios/Testing/_Validation/1655-display-characters.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1655-display-characters.yaml @@ -0,0 +1,18 @@ +version: 1 +name: | + Display character width +description: | + Characters that are too wide mess up the world rendering. +entities: + - name: ladder + display: + char: '且' + description: + - My ladder +robots: [] +world: + palette: + 'x': [grass, null, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Testing/_Validation/1678-redundant-structure-recognition-symmetries.yaml b/data/scenarios/Testing/_Validation/1678-redundant-structure-recognition-symmetries.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1678-redundant-structure-recognition-symmetries.yaml @@ -0,0 +1,29 @@ +version: 1 +name: Structure recognizer - redundant symmetries +description: | + Prevent orientations from being supplied + for recognition when they are redundant by + rotational symmetry +creative: false +robots: + - name: base + dir: east +structures: + - name: domino + recognize: [east, north, west] + structure: + mask: '.' + palette: + 'r': [stone, tree] + map: | + r + r +known: [tree] +world: + name: root + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + B diff --git a/data/scenarios/Testing/_Validation/1775-invalid-terrain-attr.yaml b/data/scenarios/Testing/_Validation/1775-invalid-terrain-attr.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1775-invalid-terrain-attr.yaml @@ -0,0 +1,27 @@ +version: 1 +name: Custom terrain - invalid attribute +description: | + Colorful new terrain +creative: false +attrs: + - name: lava + bg: "#dd7733" +terrains: + - name: lava + attr: baklava + description: | + Scorching, liquid rock +robots: + - name: base + dir: east +known: [] +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + '.': [lava] + upperleft: [0, 0] + map: | + B. + .. diff --git a/data/scenarios/Testing/_Validation/1775-invalid-terrain-reference.yaml b/data/scenarios/Testing/_Validation/1775-invalid-terrain-reference.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1775-invalid-terrain-reference.yaml @@ -0,0 +1,27 @@ +version: 1 +name: Custom terrain - invalid terrain reference +description: | + Colorful new terrain +creative: false +attrs: + - name: lava + bg: "#dd7733" +terrains: + - name: lava + attr: lava + description: | + Scorching, liquid rock +robots: + - name: base + dir: east +known: [] +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + '.': [liver] + upperleft: [0, 0] + map: | + B. + .. diff --git a/data/scenarios/Testing/_Validation/1777-capability-cost-bad-entity-reference.yaml b/data/scenarios/Testing/_Validation/1777-capability-cost-bad-entity-reference.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1777-capability-cost-bad-entity-reference.yaml @@ -0,0 +1,39 @@ +version: 1 +name: Capability cost - bad entity reference +description: | + Capability cost recipe for 'ignite' in `Zippo`{=entity} + references a non-existent entity +creative: false +robots: + - name: base + dir: east + devices: + - Zippo +entities: + - name: heavier fluid + display: + char: 'f' + description: + - Fuel for a Zippo + properties: [known, pickable] + - name: Zippo + display: + char: 'z' + description: + - Ignites things + properties: [known, pickable] + capabilities: + - capability: ignite + cost: + - [1, "lighter fluid"] +known: [] +world: + dsl: | + {grass} + palette: + 'B': [grass, null, base] + '.': [grass] + upperleft: [-1, 1] + map: | + .. + B. diff --git a/data/scenarios/Testing/_Validation/1875-robot-subworld-location.yaml b/data/scenarios/Testing/_Validation/1875-robot-subworld-location.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1875-robot-subworld-location.yaml @@ -0,0 +1,16 @@ +version: 1 +name: Robot location in nonexistent named subworld +description: | + Robot specifies an explicit "planar" location, which uses + the "default" subworld name. However, since the root subworld + has been given a name, we object that the subworld specified by + the robot doesn't exist. +robots: + - name: base + loc: [0, 0] +world: + name: mySubworld + palette: + '.': [grass] + map: |- + . diff --git a/data/scenarios/Testing/_Validation/1935-rectangular-area.yaml b/data/scenarios/Testing/_Validation/1935-rectangular-area.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1935-rectangular-area.yaml @@ -0,0 +1,12 @@ +version: 1 +name: Enforce rectangular maps +description: | + Enforce map area is rectangular. +robots: [] +world: + palette: + '.': [grass] + upperleft: [0, 0] + map: | + .. + ... diff --git a/data/scenarios/Testing/_Validation/1938-palette-usage.yaml b/data/scenarios/Testing/_Validation/1938-palette-usage.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1938-palette-usage.yaml @@ -0,0 +1,13 @@ +version: 1 +name: Enforce palette usage +description: | + Every entry in the palette must be used by the world map. +robots: [] +world: + palette: + '.': [grass] + 'd': [dirt] + upperleft: [0, 0] + map: | + .. + .. diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml --- a/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml +++ b/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml @@ -23,7 +23,7 @@ display: char: 'Ω' attr: robot - dir: [0, 1] + dir: north devices: - workbench inventory: 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 @@ -22,7 +22,7 @@ display: char: 'Ω' attr: robot - dir: [0, 1] + dir: north devices: - workbench - grabber diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml --- a/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml +++ b/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml @@ -17,7 +17,7 @@ display: char: 'Ω' attr: robot - dir: [0, 1] + dir: north devices: - workbench inventory: 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 @@ -4,29 +4,9 @@ Introduction to the backstory of Swarm. objectives: - goal: - - In a shockingly original turn of events, you have crash landed - on an alien planet! It's not clear how you'll ever get home, - but since you're here, you might as well explore a bit. Your - sensors indicate that the atmosphere is highly toxic, so - you'll have to stay inside your robotic base, with its - built-in life support system. However, you are stocked with - all the materials you need to build robots to explore - for you! - - To start, you only have some very basic - devices which can give your robots abilities like moving, turning, - grabbing things, and interpreting very simple imperative - programs. As you use your robots to gather resources, you will - be able to construct better devices, which in turn allow you to - construct robots with upgraded abilities and programming - language features, which in turn allow you to program more - sophisticated robots which in turn will... you get the - idea. - - To prepare you, this simulator will walk you through a series of hands-on - exercises that introduce you to the way robots work and the programming - language you will use to control them. Note that your progress through - the tutorials will be saved automatically. You can return to - the menu at any time to jump around between tutorials or pick - up again where you left off. + - In a shockingly original turn of events, you have crash landed on an alien planet! It's not clear how you'll ever get home, but since you're here, you might as well explore a bit. Your sensors indicate that the atmosphere is highly toxic, so you'll have to stay inside your robotic base, with its built-in life support system. However, you are stocked with all the materials you need to build robots to explore for you! + - To start, you only have some very basic devices which can give your robots abilities like moving, turning, grabbing things, and interpreting very simple imperative programs. As you use your robots to gather resources, you will be able to construct better devices, which in turn allow you to construct robots with upgraded abilities and programming language features, which in turn allow you to program more sophisticated robots which in turn will... you get the idea. + - To prepare you, this simulator will walk you through a series of hands-on exercises that introduce you to the way robots work and the programming language you will use to control them. Note that your progress through the tutorials will be saved automatically. You can return to the menu at any time to jump around between tutorials or pick up again where you left off. - | When you're ready for your first challenge, we will try the `say` command. Close this dialog with **Esc** or **Ctrl+G**, and type at the prompt: @@ -55,15 +35,15 @@ ``` - | To open the full goal text again, you can hit **Ctrl+G**. - properties: [known, portable] + properties: [known, pickable] robots: - name: base system: true display: char: 'Ω' attr: robot - dir: [1,0] - loc: [0,0] + dir: east + loc: [0, 0] inventory: - [1, READY] devices: @@ -72,8 +52,8 @@ system: true display: invisible: true - loc: [0,0] - dir: [0,0] + loc: [0, 0] + dir: [0, 0] inventory: - [0, READY] devices: 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 @@ -29,13 +29,13 @@ - | 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, + 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}. + `Unit`{=type}, returning it does not convey any information. + Thus, the type of `move` is `Cmd Unit`{=type}. - | Other commands do return a nontrivial value after executing. - For example, `grab` has type `cmd text`{=type}, and returns the name of the + For example, `grab` 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 @@ -80,10 +80,10 @@ char: 'H' description: - The Unspeakable One - properties: [portable] + properties: [pickable] robots: - name: base - dir: [0,1] + dir: north display: char: Ω attr: robot 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 @@ -7,13 +7,9 @@ # objectives: - goal: - - Now that you know basic commands, it is time to - build robots to do the work for you. - You will start in a base ('Ω') that does not move (at least not yet). + - Now that you know basic commands, it is time to build robots to do the work for you. You will start in a base ('Ω') that does not move (at least not yet). - Let's start by building a gardener robot to perform a simple task. - - You can `build` a robot with `build {COMMANDS}`{=snippet}, - where in place of `COMMANDS`{=snippet} you write the sequence - of commands for the robot to execute (separated by semicolons). + - You can `build` a robot with `build {COMMANDS}`{=snippet}, where in place of `COMMANDS`{=snippet} you write the sequence of commands for the robot to execute (separated by semicolons). - | Build a robot to harvest the `flower`{=entity} and place it next to the `water`{=entity}. @@ -35,7 +31,7 @@ build {turn right; move; move; harvest; turn right; move; place "flower"} robots: - name: base - dir: [0,1] + dir: north heavy: true display: char: Ω 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 @@ -13,9 +13,9 @@ to sweep over the entire 4x4 square and pick up a `very small rock`{=entity} any time you detect one. - | - The `ishere` command, with type `text -> cmd bool`{=type}, can be used + The `ishere` command, with type `Text -> Cmd Bool`{=type}, can be used for detecting the presence of a specific item such as a `very small rock`{=entity}. - What we need is a way to take the `bool`{=type} output from `ishere` + What we need is a way to take the `Bool`{=type} output from `ishere` and use it to decide whether to `grab` a rock or not. (Trying to execute `grab` in a cell without anything to grab will throw an exception, causing the robot to crash.) @@ -25,7 +25,7 @@ it is simply a built-in function of type - | ``` - if : bool -> {a} -> {a} -> a + if : Bool -> {a} -> {a} -> a ``` - | It takes a boolean expression and then returns either the first or second subsequent @@ -37,20 +37,20 @@ is called. Delayed expressions, on the other hand, are not evaluated until needed. In this case, we want to make sure that only the correct branch is evaluated. To write a value - of type, say, `{int}`{=type}, we just surround a value of type `int`{=type} + of type, say, `{Int}`{=type}, we just surround a value of type `Int`{=type} in curly braces, like `{3}`. This is why arguments to `build` must also be in curly braces: the type of `build` - is `{cmd a} -> cmd robot`{=type}. + is `{Cmd a} -> Cmd Actor`{=type}. - | - **TIP:** Note that `if` requires a `bool`{=type}, not a `cmd bool`{=type}! So you cannot directly say + **TIP:** Note that `if` requires a `Bool`{=type}, not a `Cmd Bool`{=type}! So you cannot directly say `if (ishere "very small rock") {...} {...}`{=snippet}. Instead you can write `b <- ishere "very small rock"; if b {...} {...}`{=snippet}. You might enjoy writing your own function of - type `cmd bool -> {cmd a} -> {cmd a} -> cmd a`{=type} to encapsulate this pattern. + type `Cmd Bool -> {Cmd a} -> {Cmd a} -> Cmd a`{=type} to encapsulate this pattern. - | **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 `{}` has type `{cmd unit}`{=type}. + allowed, because `{grab}` has type `{Cmd Text}`{=type} whereas `{}`{=snippet} has type `{Cmd Unit}`{=type}. In this case `{grab; return ()}` has the right type. condition: | try { @@ -71,7 +71,7 @@ robots: - name: base heavy: true - dir: [0,1] + dir: north display: char: Ω attr: robot @@ -96,7 +96,7 @@ invisible: true description: - A small rock. It is so small, it is practically invisible. - properties: [portable] + properties: [pickable] world: palette: 'Ω': [grass, null, base] 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 @@ -8,13 +8,9 @@ # objectives: - goal: - - Robots can use the `make` command to make things, as long as - they have a `workbench`{=entity} and the proper ingredients. For - example, `make "circuit"` will make a `circuit`{=entity}. - - Your base has a few `tree`{=entity}s in its inventory. Select them to see the - available recipes. - - Your goal is to make a `branch predictor`{=entity}, so you will have to make - some `branch`{=entity}es first. + - Robots can use the `make` command to make things, as long as they have a `workbench`{=entity} and the proper ingredients. For example, `make "circuit"` will make a `circuit`{=entity}. + - Your base has a few `tree`{=entity}s in its inventory. Select them to see the available recipes. + - Your goal is to make a `branch predictor`{=entity}, so you will have to make some `branch`{=entity}es first. - | **NOTE:** when used after opening quotes in the REPL, the Tab key can cycle through possible completions of a name. E.g., type: @@ -31,7 +27,7 @@ display: attr: robot char: 'Ω' - dir: [1,0] + dir: east devices: - workbench - logger diff --git a/data/scenarios/Tutorials/crash-secret.sw b/data/scenarios/Tutorials/crash-secret.sw --- a/data/scenarios/Tutorials/crash-secret.sw +++ b/data/scenarios/Tutorials/crash-secret.sw @@ -15,17 +15,23 @@ end; // At the beginning all robots can be given Win. -def allOK: actor -> bool = \rob. +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. - // (b -> actor -> cmd b) -> b -> cmd b - meetAll $ \f.\rob. +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 @@ -45,7 +51,6 @@ log $ "the robot " ++ format rob ++ "is missing a logger!"; return f; }; - } } end; @@ -56,8 +61,12 @@ log "Hi, I am secret"; iterate allOK (tryGive - $ "Send a robot to `salvage` me and come back to `give base \"Win\"`.\n" - ++ "When the rescue robot stands where I am and executes `salvage`,\n" - ++ "all my inventory and logs will go to it, including the \"Win\".\n" - ++ "Once you have brought the \"Win\" to your base, you will win!" + $ "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 --- a/data/scenarios/Tutorials/crash.yaml +++ b/data/scenarios/Tutorials/crash.yaml @@ -4,8 +4,7 @@ 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. + - 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, @@ -35,7 +34,7 @@ char: 'W' description: - If you have this, you win! - properties: [known, portable] + properties: [known, pickable] solution: | crasher <- build { turn east; move; move; move; log "bye"; move @@ -47,7 +46,7 @@ }; robots: - name: base - dir: [0,1] + dir: north heavy: true display: char: Ω 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 @@ -4,21 +4,16 @@ Learn how to define new commands. objectives: - goal: - - Your goal is to build a robot to fetch the `flower`{=entity} growing in the - upper right and bring it back to you; you win the challenge when the base - has a `flower`{=entity} in its inventory. + - Your goal is to build a robot to fetch the `flower`{=entity} growing in the upper right and bring it back to you; you win the challenge when the base has a `flower`{=entity} in its inventory. - | However, it would be extremely tedious to simply type out all the individual `move` and `turn` commands required. Your base has a `dictionary`{=entity} device that can be used to define new commands. For example: - | ``` - def m4 : cmd unit = move; move; move; move end + def m4 : Cmd Unit = move; move; move; move end ``` - - defines a new command `m4`{=snippet}, with type `cmd unit`{=type}, as four consecutive `move` commands. - With judicious - use of new definitions, it should be possible to complete this challenge - in just a few lines of code. + - defines a new command `m4`{=snippet}, with type `Cmd Unit`{=type}, as four consecutive `move` commands. With judicious use of new definitions, it should be possible to complete this challenge in just a few lines of code. - | **TIP:** your base is at coordinates `(0,0)`, and the `flower`{=entity} is at `(16,4)`, which you can confirm by clicking in the world map panel. When you click on a cell, @@ -52,7 +47,7 @@ } robots: - name: base - dir: [0,1] + dir: north display: char: Ω attr: robot 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 @@ -4,14 +4,8 @@ Learn how to equip devices and gain new capabilities. objectives: - goal: - - You know how to `grab` things lying around, so you are ready to get - an upgrade! - By equipping devices, you learn new capabilities which allow you to - perform more complex commands. - - Before you start building new robots in the later tutorials, you need - to gain the `build` capability. - Try typing `build {}` - you should get an error telling you that you - need to equip a `3D printer`{=entity}. + - You know how to `grab` things lying around, so you are ready to get an upgrade! By equipping devices, you learn new capabilities which allow you to perform more complex commands. + - Before you start building new robots in the later tutorials, you need to gain the `build` capability. Try typing `build {}` - you should get an error telling you that you need to equip a `3D printer`{=entity}. - | Fortunately, there is a `3D printer`{=entity} lying nearby. Go `grab` it, then `equip` it with `equip "3D printer"`. @@ -30,7 +24,7 @@ turn south; move; grab; equip "3D printer"; build {}; robots: - name: base - dir: [1,0] + dir: east devices: - logger - treads 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 @@ -5,13 +5,13 @@ def tL = turn left end; def tB = turn back end; def forever = \c. c ; forever c end; -def ifC : cmd bool -> {cmd a} -> {cmd a} -> cmd a = \test. \then. \else. +def ifC : Cmd Bool -> {Cmd a} -> {Cmd a} -> Cmd a = \test. \then. \else. b <- test; if b then else end; -def while : cmd bool -> {cmd a} -> cmd unit = \test. \body. +def while : Cmd Bool -> {Cmd a} -> Cmd Unit = \test. \body. ifC test {force body ; while test body} {} end; -def giveall : actor -> text -> cmd unit = \r. \thing. +def giveall : Actor -> Text -> Cmd Unit = \r. \thing. while (has thing) {give r thing} end; def x4 = \c. c; c; c; c end; @@ -19,13 +19,13 @@ def x12 = \c. x4 (c;c;c) end; def m12 = x12 move end; def next_row = tB; m12; tL; move; tL end; -def plant_field : text -> cmd unit = \thing. +def plant_field : Text -> Cmd Unit = \thing. x4 ( x12 (move; place thing; harvest); next_row ) end; -def harvest_field : text -> cmd unit = \thing. +def harvest_field : Text -> Cmd Unit = \thing. x4 ( x12 (move; ifC (ishere thing) {harvest; return ()} {}); next_row 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 @@ -38,19 +38,11 @@ } } { return 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. + - 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. - | To finally complete this tutorial, there is only one thing left for you to do: use one of your lambdas to make some delicious `curry`{=entity}. - - 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. + - 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} @@ -63,8 +55,8 @@ display: char: 'Ω' attr: robot - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north devices: - 3D printer - dictionary 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 @@ -9,9 +9,7 @@ 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. condition: | as base { bd <- has "board"; @@ -34,7 +32,7 @@ } robots: - name: base - dir: [0,1] + dir: north heavy: true display: char: Ω 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 @@ -4,19 +4,15 @@ Learn how to interact with the world by grabbing entities. objectives: - goal: - - Previously you learned how to make new things (like a `branch predictor`{=entity}) from ingredients. - Now you will learn how to obtain the ingredients you need. + - Previously you learned how to make new things (like a `branch predictor`{=entity}) from ingredients. Now you will learn how to obtain the ingredients you need. - There are some `tree`{=entity}s ahead of your robot; `move` to each one and `grab` it. - - You can learn more by reading about the grabber device in your - inventory. Remember, if the description does not fit in the - lower left info box, you can either hit **Enter** to pop out the - description, or focus the info box in order to scroll. + - You can learn more by reading about the grabber device in your inventory. Remember, if the description does not fit in the lower left info box, you can either hit **Enter** to pop out the description, or focus the info box in order to scroll. condition: | try { t <- as base {count "tree"}; return (t >= 6); } { return false } -solution: +solution: | move; move; grab; move; grab; @@ -26,7 +22,7 @@ move; grab; robots: - name: base - dir: [1,0] + dir: east devices: - treads - grabber 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 @@ -4,8 +4,7 @@ Learn how to define functions. objectives: - goal: - - Your goal in this challenge is to send a robot to grab the - `flower`{=entity} in the lower right (you don't need to bring it back). + - Your goal in this challenge is to send a robot to grab the `flower`{=entity} in the lower right (you don't need to bring it back). - | The path looks complex, but if you study it, you will see that it has a lot of structure. In particular, there are many parts of @@ -17,11 +16,9 @@ one more than `x`{=snippet}. As another example: - | ``` - def x4 : cmd unit -> cmd unit = \c. c; c; c; c end + def x4 : Cmd Unit -> Cmd Unit = \c. c; c; c; c end ``` - - That is, `x4`{=snippet} is defined as the function which takes a command, - called `c`{=snippet}, as input, and returns the command - `c; c; c; c`{=snippet} which consists of executing `c`{=snippet} four times. + - That is, `x4`{=snippet} is defined as the function which takes a command, called `c`{=snippet}, as input, and returns the command `c; c; c; c`{=snippet} which consists of executing `c`{=snippet} four times. condition: | try { teleport self (32,-16); @@ -42,7 +39,7 @@ } robots: - name: base - dir: [0,1] + dir: north display: char: Ω attr: robot @@ -71,7 +68,7 @@ '┘': [stone, lower right corner] '─': [stone, horizontal wall] '│': [stone, vertical wall] - upperleft: [-1,1] + upperleft: [-1, 1] map: | ┌─────────────────────────────────┐ │.......@.......@.......@.......@@│ @@ -92,5 +89,3 @@ │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ │Ω....@.......@.......@.......@..*│ └─────────────────────────────────┘ - - 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,13 +6,10 @@ - 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}. + - 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**. + - 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"}; @@ -26,12 +23,9 @@ ``` 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**. + - 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**. condition: | r <- robotNamed "check2"; loc <- as r {has "Win"}; @@ -39,37 +33,25 @@ - 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 `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. - | 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**. + - 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"}; prerequisite: move_along_corridor - goal: - Good job! You are now ready to move and turn on your own. - - To complete this challenge, move your robot to the northeast corner, - to the coordinates `(8,8)` marked with one `flower`{=entity}. + - To complete this challenge, move your robot to the northeast corner, to the coordinates `(8,8)` marked with one `flower`{=entity}. - 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**. + - 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"}; @@ -143,19 +125,17 @@ ┌───┐--d22c │..*1....X| └───┘-----b - # Font inspiration and a nicely visible separator: # -# ███████ ██ ██ █████ ██████ ███ ███ -# ██ ██ ██ ██ ██ ██ ██ ████ ████ -# ███████ ██ █ ██ ███████ ██████ ██ ████ ██ -# ██ ██ ███ ██ ██ ██ ██ ██ ██ ██ ██ -# ███████ ███ ███ ██ ██ ██ ██ ██ ██ - +# ███████ ██ ██ █████ ██████ ███ ███ +# ██ ██ ██ ██ ██ ██ ██ ████ ████ +# ███████ ██ █ ██ ███████ ██████ ██ ████ ██ +# ██ ██ ███ ██ ██ ██ ██ ██ ██ ██ ██ +# ███████ ███ ███ ██ ██ ██ ██ ██ ██ robots: - name: base - dir: [1,0] - loc: [0,0] + dir: east + loc: [0, 0] devices: - treads - logger @@ -164,7 +144,7 @@ ## OBJECTIVES ## ################# - name: check1 - loc: [2,0] + loc: [2, 0] system: true program: | def until = \c. b <- c; if b {} {until c} end; @@ -177,7 +157,7 @@ ); create "Win" - name: check2 - loc: [8,0] + loc: [8, 0] system: true program: | def until = \c. b <- c; if b {} {until c} end; @@ -190,7 +170,7 @@ ); create "Win" - name: check3 - loc: [8,4] + loc: [8, 4] system: true program: | def until = \c. b <- c; if b {} {until c} end; @@ -203,7 +183,7 @@ ); create "Win" - name: check4 - loc: [8,8] + loc: [8, 8] system: true program: | def until = \c. b <- c; if b {} {until c} end; 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 @@ -9,14 +9,9 @@ # objectives: - goal: - - Previously you learned how to plunder a plentiful forest for wood. - Now you will learn how to plant trees to obtain as much wood as you need. - - There is a fast-growing tree (called `spruce`{=entity}) ahead of you. You could `grab` - it as before, but you now have a new device called a `harvester`{=entity}. - If you `harvest` a tree rather than `grab` it, a new tree will grow in its - place after some time. - - You can also place items from your inventory on the ground - below you using the `place` command. + - Previously you learned how to plunder a plentiful forest for wood. Now you will learn how to plant trees to obtain as much wood as you need. + - There is a fast-growing tree (called `spruce`{=entity}) ahead of you. You could `grab` it as before, but you now have a new device called a `harvester`{=entity}. If you `harvest` a tree rather than `grab` it, a new tree will grow in its place after some time. + - You can also place items from your inventory on the ground below you using the `place` command. - | Using these commands in conjunction, you can plant new growable entities by placing and then harvesting them. For example, to plant a new `spruce`{=entity} seed @@ -24,8 +19,7 @@ ``` place "spruce"; harvest ``` - - Your goal is to collect 6 `spruce`{=entity} trees. You can speed this up - by planting more trees. + - Your goal is to collect 6 `spruce`{=entity} trees. You can speed this up by planting more trees. - | **TIP:** You can get a sneak peak at a feature we will explain later and type: ``` @@ -45,13 +39,13 @@ attr: plant char: 'T' description: - - | - A tall, living entity made of a tough cellular material called "wood". - They regrow after being harvested and are an important raw ingredient used - in making many different devices. - - | - This one seems to grow a little faster. - properties: [portable, growable] + - | + A tall, living entity made of a tough cellular material called "wood". + They regrow after being harvested and are an important raw ingredient used + in making many different devices. + - | + This one seems to grow a little faster. + properties: [pickable, growable] growth: [100, 120] solution: | def t = move; place "spruce"; harvest; end; @@ -67,7 +61,7 @@ turn back; h; h; h; h; h; h; robots: - name: base - dir: [1,0] + dir: east devices: - treads - grabber 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,23 +4,10 @@ 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`. (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!" condition: | try { as base {has "periwinkle"} @@ -31,8 +18,8 @@ attr: flower char: '*' description: - - A flower. - properties: [known, infinite, portable] + - A flower. + properties: [known, infinite, pickable] solution: | def m5 = move; move; move; move; move end; build { @@ -42,7 +29,7 @@ robots: - name: base heavy: true - dir: [0,1] + dir: north display: char: Ω attr: robot diff --git a/data/scenarios/Tutorials/requireinv.yaml b/data/scenarios/Tutorials/requireinv.yaml --- a/data/scenarios/Tutorials/requireinv.yaml +++ b/data/scenarios/Tutorials/requireinv.yaml @@ -4,16 +4,9 @@ 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! + - 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: ``` @@ -45,7 +38,7 @@ robots: - name: base heavy: true - dir: [0,1] + dir: north display: char: Ω attr: robot 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,14 +4,9 @@ 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 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. condition: | try { bm <- as base {knows "mountain"}; @@ -30,7 +25,7 @@ } robots: - name: base - dir: [0,1] + dir: north heavy: true display: char: Ω 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 @@ -7,7 +7,7 @@ - | Let's see what happens when you enter something that does not type check. Try typing `turn 1`{=snippet} at the REPL prompt. Clearly this is nonsense, and - the expression will be highlighted in red. To see what the error is, hit **Enter**. + part of the expression will be highlighted in red. To see what the error is, hit **Enter**. The REPL will print out a type error. - "Some other type errors for you to try:" - | @@ -16,13 +16,8 @@ `place tree`{=snippet} (without double quotes around `tree`{=snippet}) - | `move move`{=snippet} - - The last expression might give the most confusing error. - Obviously we are just missing a `;`{=snippet} separating the two `move` - commands. However, without the semicolon, it looks like - `move` is a function being applied to an argument, but of course - `move` is not a function. - - Once you are done experimenting, execute `place "Win"` to finish this challenge and - move on to the next. + - The last expression might give the most confusing error. Obviously we are just missing a `;`{=snippet} separating the two `move` commands. However, without the semicolon, it looks like `move` is a function being applied to an argument, but of course `move` is not a function. + - Once you are done experimenting, execute `place "Win"` to finish this challenge and move on to the next. condition: | try { w <- as base {has "Win"}; @@ -35,12 +30,12 @@ char: 'W' description: - Do `place "Win"` once you are done with this challenge. - properties: [known, portable] + properties: [known, pickable] solution: | place "Win" robots: - name: base - dir: [1,0] + dir: east devices: - treads - compass 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 @@ -4,19 +4,10 @@ Learn about the Swarm type system. objectives: - goal: - - The Swarm programming language has a strong static type system. That is, - every expression in the language has a type, and all the types must match up - properly before a program can be executed. - - To see the type of an expression, enter the expression at the - REPL prompt (you do not need to execute it). If the expression type checks, - its type will be displayed in gray text at the top right of the window. - - For example, if you try typing `move`, you can see that it has - type `cmd unit`{=type}, which means that `move` is a command which - returns a value of the `unit`{=type} type (the only value of - type `unit`{=type} is called `()`). - - As another example, you can see that `turn` has type `dir -> cmd unit`{=type}, - meaning that `turn` is a function which takes a direction as input - and results in a command. + - The Swarm programming language has a strong static type system. That is, every expression in the language has a type, and all the types must match up properly before a program can be executed. + - To see the type of an expression, enter the expression at the REPL prompt (you do not need to execute it). If the expression type checks, its type will be displayed in gray text at the top right of the window. + - For example, if you try typing `move`, you can see that it has type `Cmd Unit`{=type}, which means that `move` is a command which returns a value of the `Unit`{=type} type (the only value of type `Unit`{=type} is called `()`). + - As another example, you can see that `turn` has type `Dir -> Cmd Unit`{=type}, meaning that `turn` is a function which takes a direction as input and results in a command. - "Here are a few more expressions for you to try (feel free to try others as well):" - | `north` @@ -30,8 +21,7 @@ `3` - | `"tree"` - - Once you are done experimenting, execute `place "Win"` to finish this challenge and - move on to the next. + - Once you are done experimenting, execute `place "Win"` to finish this challenge and move on to the next. condition: | try { w <- as base {has "Win"}; @@ -44,13 +34,12 @@ char: 'W' description: - Do `place "Win"` once you are done with this challenge. - properties: [known, portable] + properties: [known, pickable] solution: | place "Win" - robots: - name: base - dir: [1,0] + dir: east devices: - treads - compass 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 @@ -11,11 +11,11 @@ def mg = m; grab end -def get_3_trees : cmd unit = +def get_3_trees : Cmd Unit = tB; m; mg; mg; mg; tB; m4 end -def make_harvester : cmd unit = +def make_harvester : Cmd Unit = make "log"; make "log"; make "log"; make "board"; make "board"; make "board"; make "box"; @@ -23,11 +23,11 @@ make "harvester" end -def get_lambda : cmd unit = +def get_lambda : Cmd Unit = m10; tR; m9; harvest; tB; m9; tL; m10 end -def solution : cmd unit = +def solution : Cmd Unit = build {get_3_trees}; wait 16; salvage; make_harvester; build {get_lambda}; wait 50; salvage 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 @@ -6,23 +6,10 @@ - id: get_trees teaser: Get 3 trees goal: - - You're ready to graduate to something a bit more complex! This - multi-step tutorial will walk you through a few of the first - steps you might take in exploring the new planet, using many - of the commands and techniques you have learned in the - previous tutorial challenges. - - 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**. + - You're ready to graduate to something a bit more complex! This multi-step tutorial will walk you through a few of the first steps you might take in exploring the new planet, using many of the commands and techniques you have learned in the previous tutorial challenges. + - 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**. condition: | try { n <- as base {count "tree"}; @@ -31,28 +18,15 @@ - 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. + - 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} 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. - - "**TIP:** since you only have a single harvester device for now, whenever you - send out a robot to harvest something, try programming it to come back - to the base when it is done. Then, execute `salvage` to get the harvester - back, so you can reuse it in another robot later." - - 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." + - 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. + - "**TIP:** since you only have a single harvester device for now, whenever you send out a robot to harvest something, try programming it to come back to the base when it is done. Then, execute `salvage` to get the harvester back, so you can reuse it in another robot later." + - 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} prerequisite: get_harvester @@ -63,8 +37,8 @@ display: char: 'Ω' attr: robot - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north devices: - 3D printer - dictionary 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 @@ -1,4 +1,4 @@ -def forever : cmd unit -> cmd unit = \c. c ; forever c end +def forever : Cmd Unit -> Cmd Unit = \c. c ; forever c end /** Teleports to a new location to execute a function then returns to the original location before 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 @@ -14,7 +14,7 @@ end; // modulus function (%) -def mod : int -> int -> int = \i.\m. +def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end @@ -28,9 +28,9 @@ Decide where to initially teleport to based on the initial coords. */ def init : - [xMin : int, xMax : int, yMin : int, yMax : int] - -> [yWest : int, yEast : int, xSouth : int, xNorth : int] - -> cmd (bool * int) = \extents. \lanes. + [xMin : Int, xMax : Int, yMin : Int, yMax : Int] + -> [yWest : Int, yEast : Int, xSouth : Int, xNorth : Int] + -> Cmd (Bool * Int) = \extents. \lanes. let topCorner = (-18, 30) in absloc <- whereami; let loc = sumTuples absloc $ mapTuple (\x. -x) topCorner in @@ -68,9 +68,9 @@ end; def getCanMove : - [xWest : int, xEast : int, ySouth : int, yNorth : int] - -> bool - -> cmd bool + [xWest : Int, xEast : Int, ySouth : Int, yNorth : Int] + -> Bool + -> Cmd Bool = \stoplines. \hasGreenLight. d <- heading; @@ -95,7 +95,7 @@ return $ hasGreenLight || not (atStopLine || neighborIsStopped); end; -def doTunnelWrap : [xMin : int, xMax : int, yMin : int, yMax : int] -> cmd bool = \extents. +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); @@ -116,10 +116,10 @@ end; def moveWithWrap : - [xWest : int, xEast : int, ySouth : int, yNorth : int] - -> [xMin : int, xMax : int, yMin : int, yMax : int] // extents - -> bool - -> cmd (bool * bool) + [xWest : Int, xEast : Int, ySouth : Int, yNorth : Int] + -> [xMin : Int, xMax : Int, yMin : Int, yMax : Int] // extents + -> Bool + -> Cmd (Bool * Bool) = \stoplines. \extents. \isLongitudinal. hasGreenLight <- isGreenLight isLongitudinal; @@ -141,9 +141,9 @@ end; def getNewDelayState : - bool - -> [moveDelay : int, transitionCountdown : int] - -> [moveDelay : int, transitionCountdown : int] + Bool + -> [moveDelay : Int, transitionCountdown : Int] + -> [moveDelay : Int, transitionCountdown : Int] = \canGo. \delayState. if (not canGo) { // reset to max delay and pause the countdown at max @@ -165,12 +165,12 @@ Then we continually decrease the delay by 1, until reaching no delay. */ def advance : - int - -> bool - -> [xWest : int, xEast : int, ySouth : int, yNorth : int] - -> [xMin : int, xMax : int, yMin : int, yMax : int] - -> [moveDelay : int, transitionCountdown : int] - -> cmd unit + Int + -> Bool + -> [xWest : Int, xEast : Int, ySouth : Int, yNorth : Int] + -> [xMin : Int, xMax : Int, yMin : Int, yMax : Int] + -> [moveDelay : Int, transitionCountdown : Int] + -> Cmd Unit = \idx. \isLongitudinal. \stoplines. \extents. \delayState. wait delayState.moveDelay; diff --git a/data/scenarios/Vignettes/roadway.yaml b/data/scenarios/Vignettes/roadway.yaml --- a/data/scenarios/Vignettes/roadway.yaml +++ b/data/scenarios/Vignettes/roadway.yaml @@ -8,7 +8,7 @@ display: char: Ω attr: robot - dir: [1, 0] + dir: east loc: [10, 3] devices: - logger @@ -18,7 +18,7 @@ system: true display: invisible: false - dir: [1, 0] + dir: east devices: - lodestone inventory: @@ -29,7 +29,7 @@ system: true display: invisible: true - dir: [0, 1] + dir: north loc: [24, 9] devices: - lodestone @@ -43,60 +43,47 @@ '.': [grass] 'd': [grass, null, drone] structures: - - name: road segment - structure: - palette: - 'S': - - stone - 'w': - - ice - '█': - - stone - - sand - map: | - SSSSSS - SSSSSS - ███SSS - SSSSSS - SSSSSS - wwwwww - - name: tunnel - structure: - mask: '.' - palette: - '@': [stone, boulder] - 'b': [blank] - map: | - ..@@@@.. - .@bbbb@. - @@bbbb@@ - @bbbbbb@ - - name: intersection - structure: - palette: - 'S': - - stone - 'w': - - ice - '█': - - stone - - sand - map: | - SSSSSS - SSSSSS - SSSSSS - SSSSSS - SSSSSS - SSSSSS + - name: road segment + structure: + palette: + 'S': + - stone + 'w': + - ice + '█': + - stone + - sand + map: | + SSSSSS + SSSSSS + ███SSS + SSSSSS + SSSSSS + wwwwww + - name: tunnel + structure: + mask: '.' + palette: + '@': [stone, boulder] + 'b': [blank] + map: | + ..@@@@.. + .@bbbb@. + @@bbbb@@ + @bbbbbb@ + - name: intersection + structure: + palette: + 'S': + - stone + map: | + SSSSSS + SSSSSS + SSSSSS + SSSSSS + SSSSSS + SSSSSS placements: - - src: tunnel - offset: [3, -21] - orient: - up: west - - src: tunnel - offset: [71, -21] - orient: - up: east - src: road segment offset: [6, -22] orient: @@ -161,9 +148,17 @@ orient: up: west flip: true + - src: tunnel + offset: [3, -21] + orient: + up: west + - src: tunnel + offset: [71, -21] + orient: + up: east upperleft: - - -18 - - 30 + - -18 + - 30 map: | dddddddddd.................................................................... dddddddd...................................................................... diff --git a/data/scenarios/World Examples/00-ORDER.txt b/data/scenarios/World Examples/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/World Examples/00-ORDER.txt @@ -0,0 +1,4 @@ +clearing.yaml +rorschach.yaml +stretch.yaml +translate.yaml diff --git a/data/scenarios/World Examples/clearing.yaml b/data/scenarios/World Examples/clearing.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/World Examples/clearing.yaml @@ -0,0 +1,22 @@ +version: 1 +name: Clearing +description: | + The base is in a clearing in the forest: the area within a certain + radius of the base is completely clear of trees; then there are + random trees at increasing density up to another radius; outside of + the outer radius there are only trees. +creative: true +robots: + - name: base + display: + char: Ω + loc: [0, 0] + dir: north +world: + dsl: | + 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} + ] diff --git a/data/scenarios/World Examples/rorschach.yaml b/data/scenarios/World Examples/rorschach.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/World Examples/rorschach.yaml @@ -0,0 +1,21 @@ +version: 1 +name: Rorschach +description: | + A world with both horizontal and vertical reflection symmetry, + created with `imap`{=snippet}. +creative: true +robots: + - name: base + dir: north + loc: [0, 0] +known: [tree] +world: + dsl: | + let trees = if (hash % 4 == 0) then {tree, dirt} else {stone} + in + overlay + [ mask (x >= 0 && y >= 0) trees + , mask (x >= 0 && y < 0) (imap x (-y) trees) + , mask (x < 0 && y >= 0) (imap (-x) y trees) + , mask (x < 0 && y < 0) (imap (-x) (-y) trees) + ] diff --git a/data/scenarios/World Examples/stretch.yaml b/data/scenarios/World Examples/stretch.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/World Examples/stretch.yaml @@ -0,0 +1,16 @@ +version: 1 +name: Stretch +description: | + A world created by stretching a random pattern of trees, with the + amount of stretching determined by the distance from the origin. +creative: true +robots: + - name: base + dir: north + loc: [0, 0] +known: [tree] +world: + dsl: | + let trees = if (hash % 4 == 0) then {tree, dirt} else {stone} + in + imap (if (y == 0) then 0 else (x/abs(y))) (if (abs x <= 1) then 0 else (y/abs(x/2))) trees diff --git a/data/scenarios/World Examples/translate.yaml b/data/scenarios/World Examples/translate.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/World Examples/translate.yaml @@ -0,0 +1,24 @@ +version: 1 +name: Translate +description: | + An illustration of how to use `imap`{=snippet} to translate. A basic patch is + created and then overlaid at various translations. Note that since + `imap`{=snippet} works by mapping a function over the coordinates, translation + is "backwards": for example, `imap (x+4)`{=snippet} translates 4 units to the + *left*. +creative: true +robots: + - name: base + dir: north + loc: [0, 0] +known: [rock] +world: + dsl: | + let patch = mask (abs(x) <= 4 && abs(y) <= 4) (if ((x + y) % 2 == 0) then {rock, dirt} else {dirt}) + in + overlay + [ patch + , imap (x+6) (y+3) patch + , imap (x-10) (y-7) patch + , imap (x-14) (y+5) patch + ] diff --git a/data/scenarios/blank.yaml b/data/scenarios/blank.yaml --- a/data/scenarios/blank.yaml +++ b/data/scenarios/blank.yaml @@ -4,8 +4,8 @@ creative: true robots: - name: base - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north heavy: true display: char: Ω diff --git a/data/scenarios/classic.yaml b/data/scenarios/classic.yaml --- a/data/scenarios/classic.yaml +++ b/data/scenarios/classic.yaml @@ -3,8 +3,8 @@ description: The classic open-world, resource-gathering version of the game. You start with a few basic supplies and have to program robots to explore and collect resources. robots: - name: base - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north heavy: true display: char: Ω diff --git a/data/scenarios/creative.yaml b/data/scenarios/creative.yaml --- a/data/scenarios/creative.yaml +++ b/data/scenarios/creative.yaml @@ -1,12 +1,11 @@ version: 1 name: Creative game -description: No constraints! Do whatever you want, create any items you - want out of thin air, build robots to your heart's content. +description: No constraints! Do whatever you want, create any items you want out of thin air, build robots to your heart's content. creative: true robots: - name: base - loc: [0,0] - dir: [0,1] + loc: [0, 0] + dir: north heavy: true display: char: Ω diff --git a/data/terrains.yaml b/data/terrains.yaml new file mode 100644 --- /dev/null +++ b/data/terrains.yaml @@ -0,0 +1,16 @@ +- name: stone + attr: stone + description: | + Solid, impenetrable material +- name: dirt + attr: dirt + description: | + Soil amenable to plant growth +- name: grass + attr: grass + description: | + Soft, verdant ground +- name: ice + attr: ice + description: | + Cold, solid, and slippery. diff --git a/data/test/standalone-topography/checkerboard.png b/data/test/standalone-topography/checkerboard.png new file mode 100644 Binary files /dev/null and b/data/test/standalone-topography/checkerboard.png differ diff --git a/data/test/standalone-topography/checkerboard.yaml b/data/test/standalone-topography/checkerboard.yaml new file mode 100644 --- /dev/null +++ b/data/test/standalone-topography/checkerboard.yaml @@ -0,0 +1,43 @@ +structures: + - name: checker pair + structure: + palette: + 't': true + 'f': false + map: | + ttttffff + ttttffff + ttttffff + ttttffff + - name: checker quad + structure: + map: "" + placements: + - src: checker pair + offset: [0, 0] + - src: checker pair + offset: [0, -4] + orient: + up: south + - name: checker octo + structure: + map: "" + placements: + - src: checker quad + offset: [0, 0] + - src: checker quad + offset: [8, 0] + - src: checker quad + offset: [0, -8] + - src: checker quad + offset: [8, -8] +placements: + - src: checker octo + offset: [0, 0] + - src: checker octo + offset: [16, 0] + - src: checker octo + offset: [0, -16] + - src: checker octo + offset: [16, -16] +map: "" diff --git a/data/test/standalone-topography/circle-and-crosses.png b/data/test/standalone-topography/circle-and-crosses.png new file mode 100644 Binary files /dev/null and b/data/test/standalone-topography/circle-and-crosses.png differ diff --git a/data/test/standalone-topography/circle-and-crosses.yaml b/data/test/standalone-topography/circle-and-crosses.yaml new file mode 100644 --- /dev/null +++ b/data/test/standalone-topography/circle-and-crosses.yaml @@ -0,0 +1,59 @@ +structures: + - name: cross + structure: + structures: + - name: beam + structure: + palette: + 't': true + 'f': false + map: | + ttt + ttt + ttt + ttt + ttt + ttt + fff + fff + fff + placements: + - src: beam + offset: [0, 3] + - src: beam + offset: [-3, -3] + orient: + up: east + map: "" + - name: disc + structure: + mask: '.' + palette: + 't': true + map: | + ..tttt.. + .tttttt. + ttt..ttt + tt....tt + tt....tt + ttt..ttt + .tttttt. + ..tttt.. +placements: + - src: cross + offset: [0, -15] + - src: cross + offset: [0, 0] + orient: + up: east + - src: cross + offset: [15, 0] + orient: + up: south + - src: cross + offset: [15, -15] + orient: + up: west + - src: disc + offset: [8, -8] +map: "" diff --git a/data/worlds/classic.world b/data/worlds/classic.world --- a/data/worlds/classic.world +++ b/data/worlds/classic.world @@ -89,6 +89,7 @@ [ {grass} , mask (hash % 20 == 10) {grass, cotton} , mask (hash % 20 == 0) {grass, flower} + , mask (hash % 1000 == 1) {grass, tea plant} ] ) , mask (small && soft && artificial) diff --git a/docs/image/sublibrary-graph.svg b/docs/image/sublibrary-graph.svg new file mode 100644 --- /dev/null +++ b/docs/image/sublibrary-graph.svg @@ -0,0 +1,127 @@ + + + + + + +plan + + + +swarm + +swarm + + + +swarm-web + +swarm-web + + + +swarm->swarm-web + + + + + +swarm-doc + +swarm-doc + + + +swarm-web->swarm-doc + + + + + +swarm-tui + +swarm-tui + + + +swarm-web->swarm-tui + + + + + +swarm-engine + +swarm-engine + + + +swarm-doc->swarm-engine + + + + + +swarm-tui->swarm-engine + + + + + +swarm-scenario + +swarm-scenario + + + +swarm-engine->swarm-scenario + + + + + +swarm-topography + +swarm-topography + + + +swarm-scenario->swarm-topography + + + + + +swarm-lang + +swarm-lang + + + +swarm-scenario->swarm-lang + + + + + +swarm-util + +swarm-util + + + +swarm-topography->swarm-util + + + + + +swarm-lang->swarm-util + + + + + 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 @@ -7,145 +7,190 @@ ;; ;; This file is not part of GNU Emacs. ;; +;;; Commentary: +;; This package provides major mode for the Swarm programming language. +;; +;; ;;; Code: (require 'lsp-mode) -(defvar swarm-mode-syntax-table nil "Syntax table for `swarm-mode'.") +(defvar swarm-mode-syntax-table + (let ((synTable (make-syntax-table))) + ;; C++ style comments ("// ..." and "/* ... */") + (modify-syntax-entry ?\/ ". 124b" synTable) + (modify-syntax-entry ?* ". 23" synTable) + (modify-syntax-entry ?\n "> b" synTable) + synTable) + "Syntax table for `swarm-mode'.") -(setq swarm-mode-syntax-table - (let ( (synTable (make-syntax-table))) +(defvar swarm-mode-operators-regexp + (regexp-opt + '( + "-" + "==" + "!=" + "<" + ">" + "<=" + ">=" + "||" + "&&" + "+" + "-" + "*" + "/" + "^" + "++" + "$" + ":" + ) + t) + "Regexp that recognizes operators for swarm language.") - ;; C++ style comments ("// ..." and "/* ... */") - (modify-syntax-entry ?\/ ". 124" synTable) - (modify-syntax-entry ?* ". 23b" synTable) - (modify-syntax-entry ?\n "> " synTable) +(defvar swarm-mode-commands-regexp + (concat + "\\b" + (regexp-opt + '( + "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" + "east" + "north" + "west" + "south" + "down" + "forward" + "left" + "back" + "right" + ) + t) + "\\b") + "Regexp that recognizes commands for swarm.") - synTable)) +(defvar swarm-mode-builtins-regexp + (concat + "\\b" + (regexp-opt + '( + "self" + "parent" + "base" + "if" + "inl" + "inr" + "case" + "fst" + "snd" + "force" + "undefined" + "fail" + "not" + "format" + "chars" + "split" + "charat" + "tochar" + "key" + ) + t) + "\\b" ) + "Regexp that recognizes builtin for swarm language.") -(setq swarm-font-lock-keywords - (let* ( - ;; Generate the current keywords with: - ;; cabal run swarm:swarm -- generate editors --emacs - (x-keywords '("def" "end" "let" "in" "require")) - (x-builtins '( - "self" - "parent" - "base" - "if" - "inl" - "inr" - "case" - "fst" - "snd" - "force" - "undefined" - "fail" - "not" - "format" - "chars" - "split" - "charat" - "tochar" - "key" - )) - (x-commands '( - "noop" - "wait" - "selfdestruct" - "move" - "backup" - "path" - "push" - "stride" - "turn" - "grab" - "harvest" - "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" - "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" - "east" - "north" - "west" - "south" - "down" - "forward" - "left" - "back" - "right" - )) - (x-types '("int" "text" "dir" "bool" "cmd" "void" "unit" "actor")) +(defvar swarm-mode-types-regexp + "\\b[A-Z][a-zA-Z_]*\\b" + "Regexp that recognizes types (all uppercase strings are supposed to be types) in swarm language.") - (x-keywords-regexp (regexp-opt x-keywords 'words)) - (x-builtins-regexp (regexp-opt x-builtins 'words)) - (x-commands-regexp (regexp-opt x-commands 'words)) - (x-types-regexp (regexp-opt x-types 'words))) +(defvar swarm-mode-keywords-regexp + (concat "\\b" (regexp-opt '("def" "tydef" "rec" "end" "let" "in" "require") t) "\\b") + "Regexp that recognizes keywords in swarm language.") - `( - (,x-keywords-regexp . 'font-lock-keyword-face) - (,x-builtins-regexp . 'font-lock-builtin-face) - (,x-types-regexp . 'font-lock-type-face) - (,x-commands-regexp . 'font-lock-constant-face) - ("[a-z_][a-z0-9_]*" . 'font-lock-function-name-face) - ))) +(defvar swarm-font-lock-keywords + `((,swarm-mode-types-regexp . 'font-lock-type-face) + (,swarm-mode-keywords-regexp . 'font-lock-keyword-face) + (,swarm-mode-builtins-regexp . 'font-lock-builtin-face) + (,swarm-mode-commands-regexp . 'font-lock-constant-face) + (,swarm-mode-operators-regexp . 'font-lock-variable-name-face))) +;;;###autoload (define-derived-mode swarm-mode prog-mode "Swarm Lang Mode" - (setq font-lock-defaults '((swarm-font-lock-keywords) nil t nil)) + "Major mode for editing Swarm language files." + (setq font-lock-defaults '((swarm-font-lock-keywords))) (set-syntax-table swarm-mode-syntax-table)) +;;;###autoload (add-to-list 'auto-mode-alist '("\\.sw\\'" . swarm-mode)) (with-eval-after-load 'lsp-mode diff --git a/editors/vim/swarm.vim b/editors/vim/swarm.vim --- a/editors/vim/swarm.vim +++ b/editors/vim/swarm.vim @@ -1,14 +1,14 @@ -syn keyword Keyword def end let in require +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 path push stride turn grab harvest 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 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 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 Direction east north west south down forward left back right -syn keyword Type int text dir bool cmd void unit actor +syn match Type "\<[A-Z][a-zA-Z_]*\>" +syn match Operators "[-=!<>|&+*/^$:]" syn match Comment "//.*$" syn region MultilineComment start="/\*" end="\*/" syn match Brackets "[\[\]\(\)\{\}]" -syn match Colon ":" syn match String "\".*\"" syn match Number "\<[-]\=\d\+\>" @@ -19,6 +19,6 @@ hi def link Comment Comment hi def link MultilineComment Comment hi def link Brackets Keyword -hi def link Colon Keyword -hi def link String String +hi def link Operators Keyword +hi def link String String hi def link Number Number diff --git a/editors/vscode/syntaxes/swarm.tmLanguage.json b/editors/vscode/syntaxes/swarm.tmLanguage.json deleted file mode 100644 --- a/editors/vscode/syntaxes/swarm.tmLanguage.json +++ /dev/null @@ -1,111 +0,0 @@ -{ - "$schema": "https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json", - "name": "swarm", - "patterns": [ - {"include": "#keywords"}, - {"include": "#comments"}, - {"include": "#strings"}, - {"include": "#variables"}, - {"include": "#constants"} - ], - "repository": { - "keywords": { - "patterns": [ - { - "name": "keyword.control.dictionary.def", - "begin": "def\\s+(\\w+)\\s*(:((\\s*(cmd|dir|string|int|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=", - "end": "end", - "beginCaptures": { - "1": {"name": "entity.name.function"}, - "3": {"name": "entity.name.type"} - }, - "patterns": [ - {"include": "#keywords"}, - {"include": "#comments"}, - {"include": "#strings"}, - {"include": "#variables"}, - {"include": "#constants"} - ] - }, - { - "name": "keyword.control.dictionary.let", - "begin": "\\s*let\\s+(\\w+)\\s*(:((\\s*(cmd|dir|text|int|void|unit|actor|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=", - "end": "\\s*in\\b", - "beginCaptures": { - "1": {"name": "entity.name.function"}, - "3": {"name": "entity.name.type"} - }, - "patterns": [ - {"include": "#keywords"}, - {"include": "#comments"}, - {"include": "#strings"}, - {"include": "#variables"}, - {"include": "#constants"} - ] - }, - { - "name": "keyword.control.require", - "match": "require" - }, - { - "name": "keyword.operator", - "match": "-|==|!=|<|>|<=|>=|\\|\\||&&|\\+|-|\\*|/(?![/|*])|\\^|\\+\\+|\\$" - }, - { - "name": "keyword.operator.lambda", - "match": "\\\\(\\w+)\\.", - "captures": { "1": {"name": "variable.other"} } - }, - { - "name": "keyword.other", - "match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|backup|path|push|stride|turn|grab|harvest|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|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" - } - ] - }, - "comments": { - "patterns": [ - { - "name": "comment.line.double-slash", - "begin": "//", - "end": "\n" - }, - { - "name":"comment.block", - "begin": "\/[*]", - "end": "[*](\/)" - } - ] - }, - "strings":{ - "patterns": [ - { - "name":"string.quoted.double", - "begin": "\"", - "end": "\"" - } - ] - }, - "variables":{ - "patterns": [ - { - "name": "variable.language.dir", - "match": "\\b(?i)(east|north|west|south|down|forward|left|back|right|)\\b" - }, - { - "name": "variable.parameter", - "match": "\\b(?i)([a-z]\\w*)\\b" - } - ] - }, - "constants": { - "patterns": [ - { - "name": "constant.numeric", - "match": "([0-9]+|0b[01]+|0o[0-8]+|0x\\x+)" - } - ] - } - - }, - "scopeName": "source.swarm" -} diff --git a/editors/vscode/syntaxes/swarm.tmLanguage.yaml b/editors/vscode/syntaxes/swarm.tmLanguage.yaml new file mode 100644 --- /dev/null +++ b/editors/vscode/syntaxes/swarm.tmLanguage.yaml @@ -0,0 +1,201 @@ +###################################################### +# # +# Syntax highlighting TextMate grammar for Swarm # +# # +###################################################### +# Read the DEVELOPING.md file for how to test this. +# +# WARNING: A SINGLE TYPO CAN BREAK THE WHOLE THING!!! +# +# Always run the snapshot test to see if half of the +# syntax is not suddenly missing and you should be OK. +$schema: https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json +name: swarm +scopeName: source.swarm +patterns: + - include: '#expression' +repository: + # ============================================================================ + # This group is recursively reused and is the root if Swarm language + expression: + # WARNING: patterns are ordered, but the named groups in repository are NOT + patterns: + - include: '#keywords' + - include: '#comments' + - include: '#definitions' + - include: '#strings' + - include: '#constants' + - include: '#variables' # must go AFTER keywords and definitions + - include: '#parens' + # ============================================================================ + keywords: + patterns: + - include: '#keyword' + - include: '#require' + - include: '#operator' + - include: '#lambda' + - include: '#chain' + - include: '#in' + - include: '#end' + repository: + # --------------------------------------------- + # GENERATED PATTERN: Functions and commands + # Get new version with: + # cabal run swarm:swarm-docs -- editors --code + # --------------------------------------------- + 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 + require: + name: keyword.control.require + match: \b(require)\b + lambda: + name: keyword.operator.lambda + match: \\(\w+)\. + captures: + '1': + name: variable.other + chain: + name: keyword.operator.chain + match: ; + # --------------------------------------------- + # GENERATED PATTERN: Operators + # Get new version with: + # cabal run swarm:swarm-docs -- editors --code + # --------------------------------------------- + operator: + name: keyword.operator + match: '-|==|!=|<|>|<=|>=|\|\||&&|\+|-|\*|/(?![/|*])|\^|\+\+|\$|:' + in: + name: keyword.control.dictionary.let.in + match: \b(in)\b + end: + name: keyword.control.dictionary.def.end + match: \b(end)\b + # ============================================================================ + variables: + patterns: + # --------------------------------------------- + # GENERATED PATTERN: Directions + # Get new version with: + # cabal run swarm:swarm-docs -- editors --code + # --------------------------------------------- + - name: variable.language.dir + match: \b(east|north|west|south|down|forward|left|back|right)\b + - name: variable.parameter + match: \b([a-z]\w*)\b + parens: + patterns: + - include: '#paren' + - include: '#brace' + repository: + paren: + begin: \( + end: \) + beginCaptures: + '0': + name: punctuation.paren.open + endCaptures: + '0': + name: punctuation.paren.close + name: expression.group + patterns: + - include: '#expression' + brace: + begin: \{ + end: \} + beginCaptures: + '0': + name: punctuation.braces.open + endCaptures: + '0': + name: punctuation.braces.close + name: expression.group + patterns: + - include: '#expression' + # ============================================================================ + comments: + patterns: + - include: '#line' + - include: '#block' + repository: + line: + name: comment.line.double-slash + begin: // + end: $\n? + block: + name: comment.block + begin: /[*] + end: '[*](/)' + # ============================================================================ + strings: + patterns: + - name: string.quoted.double + begin: '"' + end: '"' + patterns: + - name: constant.character.escape.sequence.swarm + match: \\(?:["$\\/bfnrt]) + # ============================================================================ + constants: + patterns: + - name: constant.numeric + match: ([0-9]+|0b[01]+|0o[0-8]+|0x\x+) + # ============================================================================ + definitions: + patterns: + - include: '#tydef' + - include: '#defeq' + - include: '#leteq' + repository: + tydef: + name: keyword.control.dictionary.tydef + begin: \b(tydef)\s+([^=]+)\s*(=) + end: \b(end)\b + beginCaptures: + '1': + name: keyword.control.dictionary.tydef.start + '2': + name: entity.name.type + '3': + name: keyword.control.dictionary.tydef.assignment + endCaptures: + '1': + name: keyword.control.dictionary.tydef.end + patterns: + - include: '#types' + defeq: + name: keyword.control.dictionary.def + begin: \b(def)\s+(\w+)\s*(:)? + end: '=' + beginCaptures: + '2': + name: entity.name.function + '3': + name: keyword.control.dictionary.def.annotation + endCaptures: + '0': + name: keyword.control.dictionary.def.assignment + patterns: + - include: '#types' + leteq: + name: keyword.control.dictionary.let + begin: \b(let)\s+(\w+)\s*(:)? + end: '=' + beginCaptures: + '2': + name: entity.name.function + '3': + name: keyword.control.dictionary.let.annotation + endCaptures: + '0': + name: keyword.control.dictionary.let.assignment + patterns: + - include: '#types' + # ============================================================================ + # Types are not part of #expression and are used only in #definition + types: + patterns: + - name: entity.name.type + match: \b(forall|rec|[A-Z]\w*|[a-z]\w*)\b|\(|\)|\{|\}|(\*|\+|->)|\. diff --git a/example/BFS-clear.sw b/example/BFS-clear.sw --- a/example/BFS-clear.sw +++ b/example/BFS-clear.sw @@ -2,24 +2,24 @@ // search, with robots spawning more robots. Fun, though not very practical // in classic mode. -def repeat : int -> cmd unit -> cmd unit = \n.\c. +def repeat : Int -> Cmd Unit -> Cmd Unit = \n.\c. if (n == 0) {} {c ; repeat (n-1) c} end; -def while : cmd bool -> cmd unit -> cmd unit = \test.\c. +def while : Cmd Bool -> Cmd Unit -> Cmd Unit = \test.\c. b <- test; if b {c ; while test c} {} end; -def getX : cmd int = +def getX : Cmd Int = pos <- whereami; return (fst pos); end; -def getY : cmd int = +def getY : Cmd Int = pos <- whereami; return (snd pos); end; -def gotoX : int -> cmd unit = \tgt. +def gotoX : Int -> Cmd Unit = \tgt. cur <- getX; if (cur == tgt) {} @@ -30,7 +30,7 @@ gotoX tgt } end; -def gotoY : int -> cmd unit = \tgt. +def gotoY : Int -> Cmd Unit = \tgt. cur <- getY; if (cur == tgt) {} @@ -41,8 +41,8 @@ gotoY tgt } end; -def goto : int -> int -> cmd unit = \x. \y. gotoX x; gotoY y; gotoX x; gotoY y end; -def spawnfwd : {cmd unit} -> cmd unit = \c. +def goto : Int -> Int -> Cmd Unit = \x. \y. gotoX x; gotoY y; gotoX x; gotoY y end; +def spawnfwd : {Cmd Unit} -> Cmd Unit = \c. try { move; b <- isHere "tree"; @@ -53,7 +53,7 @@ move } { turn back } end; -def clear : cmd unit = +def clear : Cmd Unit = grab; repeat 4 ( spawnfwd {clear}; @@ -63,4 +63,4 @@ give base "tree"; selfdestruct; end; -def start : cmd actor = build {turn west; repeat 7 move; clear} end +def start : Cmd Actor = build {turn west; repeat 7 move; clear} end diff --git a/example/cat.sw b/example/cat.sw --- a/example/cat.sw +++ b/example/cat.sw @@ -1,10 +1,10 @@ // A "cat" that wanders around randomly. Shows off use of the // 'random' command. -let forever : cmd unit -> cmd unit = \c. c ; forever c in -let repeat : int -> cmd unit -> cmd unit = +let forever : Cmd Unit -> Cmd Unit = \c. c ; forever c in +let repeat : Int -> Cmd Unit -> Cmd Unit = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} in -let randdir : cmd dir = +let randdir : Cmd Dir = d <- random 4; return ( if (d == 0) {north} diff --git a/example/dfs.sw b/example/dfs.sw --- a/example/dfs.sw +++ b/example/dfs.sw @@ -1,8 +1,8 @@ -def ifC : forall a. cmd bool -> {cmd a} -> {cmd a} -> cmd a = +def ifC : forall a. Cmd Bool -> {Cmd a} -> {Cmd a} -> Cmd a = \test. \thn. \els. b <- test; if b thn els end // Recursive DFS to harvest a contiguous forest -def dfs : cmd unit = +def dfs : Cmd Unit = ifC (ishere "tree") { grab; turn west; diff --git a/example/fact.sw b/example/fact.sw --- a/example/fact.sw +++ b/example/fact.sw @@ -1,10 +1,10 @@ // Defining simple recursive functions. -def repeat : int -> cmd unit -> cmd unit = \n.\c. +def repeat : Int -> Cmd Unit -> Cmd Unit = \n.\c. if (n == 0) {} {c ; repeat (n-1) c} end -def fact : int -> int = \n:int. +def fact : Int -> Int = \n:Int. if (n == 0) {1} {n * fact (n-1)} diff --git a/example/list.sw b/example/list.sw --- a/example/list.sw +++ b/example/list.sw @@ -26,10 +26,10 @@ // // 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 +// type ListI = Int /*******************************************************************/ /* LAYOUT */ @@ -39,16 +39,16 @@ // 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)] +/* 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 +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 + head tail */ /*******************************************************************/ @@ -56,31 +56,31 @@ /*******************************************************************/ // bitlength of a number (shifting by one) -def naive_len : int -> int = \i. +def naive_len : Int -> Int = \i. if (i == 0) {0} {1 + naive_len (i/2)} end // modulus function (%) -def mod : int -> int -> int = \i.\m. +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. +def shiftL : Int -> Int -> Int = \s.\i. i / 2^s end // f X Y = Y * 2^(X) -def shiftR : int -> int -> int = \s.\i. +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 +def shiftRH : Int -> Int -> Int = \s. shiftR (s*8) end // bitlength of a number (shifting by 64) -def len : int -> int = \i. +def len : Int -> Int = \i. let next = i / 2^64 in if (next == 0) {naive_len i} {64 + len next} end @@ -89,11 +89,11 @@ /* helper functions */ /*******************************************************************/ -def getLenPart : int -> int = \i. mod (i/2) (2^7) end -def setLenPart : int -> int = \i. 2 * (mod i (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 // 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 */ @@ -107,7 +107,7 @@ // Get bitlength of the first number in the list // and also the list starting at the number itself // -// getLenA : listI -> int * int +// getLenA : ListI -> Int * Int def getLenA = \xs. let isEnd = 0 == mod xs 2 in let l = getLenPart xs in @@ -123,7 +123,7 @@ /* LIST FUNCTIONS */ /*******************************************************************/ -// headTail : listI -> {int} * {listI} +// headTail : ListI -> {Int} * {ListI} def headTail = \xs. let sign = mod xs 2 in let ns = xs / 2 in @@ -135,21 +135,21 @@ ) end -// head : listI -> int -def head : int -> int = \xs. +// head : ListI -> Int +def head : Int -> Int = \xs. force $ fst $ headTail xs end -// tail : listI -> listI +// tail : ListI -> ListI def tail = \xs. force $ snd $ headTail xs end -// nil : listI +// nil : ListI def nil = 0 end // Add non-negative number to beginning of list (cons adds the sign) -// consP : nat -> listI -> int +// consP : nat -> ListI -> Int def consP = \x.\xs. if (x == 0) { 2 /* header says one bit length */ + shiftR (8+1) xs} @@ -160,7 +160,7 @@ end // Add integer to the beginning of the list -// consP : int -> listI -> listI +// consP : Int -> ListI -> ListI def cons = \x.\xs. if (x >= 0) { 2 * consP x xs } @@ -172,19 +172,19 @@ /* MORE LIST FUNCTIONS */ /*******************************************************************/ -// index : int -> listI -> int +// index : Int -> ListI -> Int def index = \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. +def for : 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 +// 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 @@ -192,7 +192,7 @@ } end -// for_each : listI int -> (int -> cmd a) -> cmd unit +// for_each : ListI Int -> (Int -> Cmd a) -> Cmd Unit def for_each = \xs.\act. for_each_i 0 xs (\i. act) end @@ -226,19 +226,19 @@ assert (ln1 == 517) "[-1] ~ 517"; assert (head ln1 == -1) "head [-1] == -1"; assert (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] == []"; - + 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] == []"; - + log "check [1,0]"; let l1_0 = cons 1 l0 in assert (l1_0 == 4612) "[1,0] ~ 4612"; @@ -304,7 +304,7 @@ 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"; end diff --git a/example/maybe.sw b/example/maybe.sw new file mode 100644 --- /dev/null +++ b/example/maybe.sw @@ -0,0 +1,9 @@ +tydef Maybe a = Unit + a end + +def just : a -> Maybe a = inr end + +def nothing : Maybe a = inl () end + +def positive : Int -> Maybe Int = \x. + if (x > 0) {just x} {nothing} +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 @@ -5,16 +5,16 @@ if (a == fst p) {snd p} {k a} end -def nil : a -> cmd unit = \a. return () end +def nil : a -> Cmd Unit = \a. return () end // The delay around the first argument is necessary to prevent // infinite recursion -def handlerB : {key -> cmd unit} -> key -> cmd unit = \hA. \k. +def handlerB : {Key -> Cmd Unit} -> Key -> Cmd Unit = \hA. \k. cons (key "b", move) nil k; installKeyHandler "" (force hA) end // Typing 'a' then 'b' in sequence will cause the robot to move. -def handlerA : key -> cmd unit = +def handlerA : Key -> Cmd Unit = cons (key "a", installKeyHandler "" (handlerB {handlerA})) nil end diff --git a/example/omega.sw b/example/omega.sw new file mode 100644 --- /dev/null +++ b/example/omega.sw @@ -0,0 +1,5 @@ +tydef D = rec d. d -> d end + +def selfApp : D -> D = \x. x x end + +def omega : D = selfApp selfApp end diff --git a/example/pilotmode.sw b/example/pilotmode.sw --- a/example/pilotmode.sw +++ b/example/pilotmode.sw @@ -2,11 +2,11 @@ if (a == fst p) {snd p} {k a} end -def nil : a -> cmd unit = \a. return () end +def nil : a -> Cmd Unit = \a. return () end // Suitable to use as e.g. // installKeyHandler "(S-)←↓↑→ [Del] [g]rab [h]arvest [d]rill [s]can [b]locked [u]pload" pilot -def pilot : key -> cmd unit = +def pilot : Key -> Cmd Unit = cons (key "Up", move) $ cons (key "Down", turn back) $ cons (key "Left", turn left) $ diff --git a/example/rectypes.sw b/example/rectypes.sw new file mode 100644 --- /dev/null +++ b/example/rectypes.sw @@ -0,0 +1,107 @@ +// 'rec t. F(t)' creates a recursive type which is the solution of t = F(t). +// For example 'rec l. Unit + Int * l' is the type l such that l = Unit + Int * l, +// that is, arbitrary-length finite lists of Int. +// +// Recursive types are equal up to alpha-renaming, so e.g. +// (rec l. Unit + Int * l) = (rec q. Unit + Int * q) + +//////////////////////////////////////////////////////////// +// Lists +//////////////////////////////////////////////////////////// + +tydef List a = rec l. Unit + a * l end + +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))) +end + +def map : (a -> b) -> List a -> List b = \f. + foldr (\y. cons (f y)) nil +end + +def append : List a -> List a -> List a = \xs. \ys. + foldr cons ys xs +end + +def concat : List (List a) -> List a = foldr append nil end + +def sum : List Int -> Int = + foldr (\x. \y. x + y) 0 +end + +def twentySeven = sum (cons 12 (cons 5 (cons 3 (cons 7 nil)))) end + +// Note that if a function returns e.g. (rec t. Unit + (Int * Int) * t), +// that is the *same type* as List (Int * Int), so we can use any List +// functions on the output. + +def someFun : Int -> (rec t. Unit + (Int * Int) * t) = \x. inr ((x, x), inl ()) end + +def doSomethingWithSomeFun : List (Int * Int) = + (cons (2,3) (cons (4,7) (someFun 5))) +end + +//////////////////////////////////////////////////////////// +// Binary trees with a at internal nodes and b at leaves +//////////////////////////////////////////////////////////// + +tydef BTree a b = rec bt. b + bt * a * bt end + +def leaf : b -> BTree a b = inl end + +def branch : BTree a b -> a -> BTree a b -> BTree a b = + \l. \a. \r. inr (l, a, r) +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)))) +end + +def max : Int -> Int -> Int = \a. \b. if (a > b) {a} {b} end + +def height : BTree a b -> Int = + foldBTree (\_. 0) (\l. \_. \r. 1 + max l r) +end + +//////////////////////////////////////////////////////////// +// Rose trees +//////////////////////////////////////////////////////////// + +// It would be better to reuse the definition of List +// and define Rose a = rec r. a * List r, +// 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)) +end + +def flatten : Rose a -> List a = + foldRose (\a. \ts. cons a (concat ts)) +end + +//////////////////////////////////////////////////////////// +// Equirecursive types +//////////////////////////////////////////////////////////// + +// Swarm has equirecursive types, which means a recursive type is +// *equal to* its unfolding. This has some interesting consequences +// including the fact that types are equal if their infinite unfoldings +// would be equal. + +// For example, U1 and U2 below are the same, and the Swarm +// typechecker can tell: + +tydef U1 = rec u1. Unit + u1 end +tydef U2 = rec u2. Unit + Unit + u2 end + +def u : U1 -> U2 = \u. u end diff --git a/example/wander.sw b/example/wander.sw --- a/example/wander.sw +++ b/example/wander.sw @@ -1,9 +1,9 @@ -def forever : {cmd unit} -> cmd unit = +def forever : {Cmd Unit} -> Cmd Unit = \c. force c ; forever c end // Wander randomly forever. -def wander : cmd unit = +def wander : Cmd Unit = forever { b <- random 2; turn (if (b == 0) {left} {right}); diff --git a/src/Control/Carrier/Accum/FixedStrict.hs b/src/Control/Carrier/Accum/FixedStrict.hs deleted file mode 100644 --- a/src/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/Data/BoolExpr/Simplify.hs b/src/Data/BoolExpr/Simplify.hs deleted file mode 100644 --- a/src/Data/BoolExpr/Simplify.hs +++ /dev/null @@ -1,60 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Simplification logic for boolean expressions that is not --- provided in the 'boolexpr' package. -module Data.BoolExpr.Simplify ( - cannotBeTrue, - replace, -) where - -import Data.BoolExpr -import Data.List qualified as L -import Data.Map (Map) -import Data.Map qualified as M -import Data.Set qualified as S - --- | Used only by "hasContradiction". --- Note that the Booleans returned in this tuple are not actually used --- as conditions, and therefore their semantic convention (e.g. associating --- True = Positive and False = Negative) is irrelevant. --- Rather, they are collected into sets --- to determine whether both True and False exist for a key. -extractConstFromSigned :: Signed a -> (a, Bool) -extractConstFromSigned v = case v of - Negative x -> (x, False) - Positive x -> (x, True) - -hasContradiction :: Ord a => Conj (Signed a) -> Bool -hasContradiction (Conj items) = - not - . M.null - . M.filter ((> 1) . S.size) - . M.fromListWith (<>) - $ fmap (fmap S.singleton . extractConstFromSigned) items - -simplifyDNF :: Ord a => DNF a -> DNF a -simplifyDNF (DNF (Disj disjunctions)) = - DNF $ Disj $ L.filter (not . hasContradiction) disjunctions - -isAlwaysFalse :: Ord a => DNF a -> Bool -isAlwaysFalse (DNF (Disj disjunctions)) = L.null disjunctions - -cannotBeTrue :: Ord a => BoolExpr a -> Bool -cannotBeTrue = isAlwaysFalse . simplifyDNF . boolTreeToDNF - -replace :: Ord a => Map a Bool -> BoolExpr a -> BoolExpr a -replace f (BAnd a b) = BAnd (replace f a) (replace f b) -replace f (BOr a b) = BOr (replace f a) (replace f b) -replace f (BNot t) = BNot (replace f t) -replace _ BTrue = BTrue -replace _ BFalse = BFalse -replace m c@(BConst x) = case M.lookup varname m of - Nothing -> c - Just val -> - if txform val - then BTrue - else BFalse - where - (varname, isPositive) = extractConstFromSigned x - txform = if isPositive then id else not diff --git a/src/Swarm/App.hs b/src/Swarm/App.hs deleted file mode 100644 --- a/src/Swarm/App.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- 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 Swarm.Game.Failure (SystemFailure) -import Swarm.Language.Pretty (prettyText) -import Swarm.Log (LogSource (SystemLog), Severity (..)) -import Swarm.ReadableIORef (mkReadonly) -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.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 s' = - 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.colorMode = colorMode opts} - initialVty <- buildVty - V.setMode (V.outputIface initialVty) V.Mouse True - - -- Run the app. - void $ customMain initialVty buildVty (Just chan) (app eventHandler) s' - --- | 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/src/Swarm/Constant.hs b/src/Swarm/Constant.hs deleted file mode 100644 --- a/src/Swarm/Constant.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Constants used throughout the UI and game. -module Swarm.Constant where - -import Data.Text (Text) - --- * Website constants - --- $convention --- By convention, all URL constants include trailing slashes --- when applicable. - --- | The URL for the Swarm repository. -swarmRepoUrl :: Text -swarmRepoUrl = "https://github.com/swarm-game/swarm/" - --- | The URL for the Swarm wiki. -wikiUrl :: Text -wikiUrl = swarmRepoUrl <> "wiki/" - --- | The URL for the Swarm commands cheat sheet. -wikiCheatSheet :: Text -wikiCheatSheet = wikiUrl <> "Commands-Cheat-Sheet" diff --git a/src/Swarm/Doc/Gen.hs b/src/Swarm/Doc/Gen.hs deleted file mode 100644 --- a/src/Swarm/Doc/Gen.hs +++ /dev/null @@ -1,597 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Auto-generation of various forms of documentation. -module Swarm.Doc.Gen ( - -- ** Main document generation function + types - generateDocs, - GenerateDocs (..), - EditorType (..), - SheetType (..), - loadStandaloneScenario, - - -- ** Formatted keyword lists - keywordsCommands, - keywordsDirections, - operatorNames, - builtinFunctionList, - - -- ** Wiki pages - PageAddress (..), -) where - -import Control.Effect.Lift -import Control.Effect.Throw (Throw, throwError) -import Control.Lens (view, (^.)) -import Control.Lens.Combinators (to) -import Control.Monad (zipWithM, zipWithM_) -import Data.Containers.ListUtils (nubOrd) -import Data.Foldable (find, toList) -import Data.List (transpose) -import Data.Map.Lazy (Map, (!)) -import Data.Map.Lazy qualified as Map -import Data.Maybe (fromMaybe, isJust, listToMaybe) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Text (Text, unpack) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import Data.Tuple (swap) -import Swarm.Doc.Pedagogy -import Swarm.Doc.Schema.Render -import Swarm.Doc.Util -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 (SystemFailure (CustomFailure)) -import Swarm.Game.Recipe (Recipe, loadRecipes, recipeCatalysts, recipeInputs, recipeOutputs, recipeTime, recipeWeight) -import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory) -import Swarm.Game.Scenario (Scenario, loadStandaloneScenario, scenarioRobots) -import Swarm.Game.World.Gen (extractEntities) -import Swarm.Game.World.Typecheck (Some (..), TTerm) -import Swarm.Language.Capability (Capability) -import Swarm.Language.Capability qualified as Capability -import Swarm.Language.Key (specialKeyNames) -import Swarm.Language.Pretty (prettyText) -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 (both, listEnums, quote) -import Swarm.Util.Effect (simpleErrorHandle) -import Swarm.Web (swarmApiMarkdown) -import Text.Dot (Dot, NodeId, (.->.)) -import Text.Dot qualified as Dot - --- ============================================================================ --- MAIN ENTRYPOINT TO CLI DOCUMENTATION GENERATOR --- ============================================================================ --- --- These are the exported functions used by the executable. --- --- ---------------------------------------------------------------------------- - --- | An enumeration of the kinds of documentation we can generate. -data GenerateDocs where - -- | Entity dependencies by recipes. - RecipeGraph :: GenerateDocs - -- | Keyword lists for editors. - EditorKeywords :: Maybe EditorType -> GenerateDocs - -- | List of special key names recognized by 'Swarm.Language.Syntax.Key' command - SpecialKeyNames :: GenerateDocs - -- | Cheat sheets for inclusion on the Swarm wiki. - CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs - -- | List command introductions by tutorial - TutorialCoverage :: GenerateDocs - -- | Web API endpoints - WebAPIEndpoints :: GenerateDocs - deriving (Eq, Show) - --- | An enumeration of the editors supported by Swarm (currently, --- Emacs and VS Code). -data EditorType = Emacs | VSCode | Vim - deriving (Eq, Show, Enum, Bounded) - --- | An enumeration of the kinds of cheat sheets we can produce. -data SheetType = Entities | Commands | Capabilities | Recipes | Scenario - deriving (Eq, Show, Enum, Bounded) - --- | A configuration record holding the URLs of the various cheat --- sheets, to facilitate cross-linking. -data PageAddress = PageAddress - { entityAddress :: Text - , commandsAddress :: Text - , capabilityAddress :: Text - , recipesAddress :: Text - } - deriving (Eq, Show) - --- | Generate the requested kind of documentation to stdout. -generateDocs :: GenerateDocs -> IO () -generateDocs = \case - RecipeGraph -> generateRecipe >>= putStrLn - EditorKeywords e -> - case e of - Just et -> generateEditorKeywords et - Nothing -> do - putStrLn "All editor completions:" - let editorGen et = do - putStrLn $ replicate 40 '-' - putStrLn $ "-- " <> show et - putStrLn $ replicate 40 '-' - generateEditorKeywords et - mapM_ editorGen listEnums - SpecialKeyNames -> generateSpecialKeyNames - CheatSheet address s -> case s of - Nothing -> error "Not implemented for all Wikis" - Just st -> case st of - Commands -> T.putStrLn commandsPage - Capabilities -> simpleErrorHandle $ do - entities <- loadEntities - sendIO $ T.putStrLn $ capabilityPage address entities - Entities -> simpleErrorHandle $ do - entities <- loadEntities - sendIO $ T.putStrLn $ entitiesPage address (Map.elems $ entitiesByName entities) - Recipes -> simpleErrorHandle $ do - entities <- loadEntities - recipes <- loadRecipes entities - sendIO $ T.putStrLn $ recipePage address recipes - Scenario -> genScenarioSchemaDocs - TutorialCoverage -> renderTutorialProgression >>= putStrLn . T.unpack - WebAPIEndpoints -> putStrLn swarmApiMarkdown - --- ---------------------------------------------------------------------------- --- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED --- ---------------------------------------------------------------------------- - --- | Generate a list of keywords in the format expected by one of the --- supported editors. -generateEditorKeywords :: EditorType -> IO () -generateEditorKeywords = \case - Emacs -> do - putStrLn "(x-builtins '(" - T.putStr $ builtinFunctionList Emacs - putStrLn "))\n(x-commands '(" - T.putStr $ keywordsCommands Emacs - T.putStr $ keywordsDirections Emacs - putStrLn "))" - VSCode -> do - putStrLn "Functions and commands:" - T.putStrLn $ builtinFunctionList VSCode <> "|" <> keywordsCommands VSCode - putStrLn "\nDirections:" - T.putStrLn $ keywordsDirections VSCode - putStrLn "\nOperators:" - T.putStrLn operatorNames - Vim -> do - putStr "syn keyword Builtins " - T.putStr $ builtinFunctionList Vim - putStr "\nsyn keyword Command " - T.putStr $ keywordsCommands Vim - putStr "\nsyn keyword Direction " - T.putStrLn $ keywordsDirections Vim - -commands :: [Const] -commands = filter Syntax.isCmd Syntax.allConst - -operators :: [Const] -operators = filter Syntax.isOperator Syntax.allConst - -builtinFunctions :: [Const] -builtinFunctions = filter Syntax.isBuiltinFunction Syntax.allConst - -builtinFunctionList :: EditorType -> Text -builtinFunctionList e = editorList e $ map constSyntax builtinFunctions - -editorList :: EditorType -> [Text] -> Text -editorList = \case - Emacs -> T.unlines . map ((" " <>) . quote) - VSCode -> T.intercalate "|" - Vim -> T.intercalate " " - -constSyntax :: Const -> Text -constSyntax = Syntax.syntax . Syntax.constInfo - --- | Get formatted list of basic functions/commands. -keywordsCommands :: EditorType -> Text -keywordsCommands e = editorList e $ map constSyntax commands - --- | Get formatted list of directions. -keywordsDirections :: EditorType -> Text -keywordsDirections e = editorList e $ map Syntax.directionSyntax Syntax.allDirs - --- | A list of the names of all the operators in the language. -operatorNames :: Text -operatorNames = T.intercalate "|" $ map (escape . constSyntax) operators - where - special :: String - special = "*+$[]|^" - slashNotComment = \case - '/' -> "/(?![/|*])" - c -> T.singleton c - escape = T.concatMap (\c -> if c `elem` special then T.snoc "\\\\" c else slashNotComment c) - --- ---------------------------------------------------------------------------- --- GENERATE SPECIAL KEY NAMES --- ---------------------------------------------------------------------------- - -generateSpecialKeyNames :: IO () -generateSpecialKeyNames = - T.putStr . T.unlines . Set.toList $ specialKeyNames - --- ---------------------------------------------------------------------------- --- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE --- ---------------------------------------------------------------------------- - -escapeTable :: Text -> Text -escapeTable = T.concatMap (\c -> if c == '|' then T.snoc "\\" c else T.singleton c) - -separatingLine :: [Int] -> Text -separatingLine ws = T.cons '|' . T.concat $ map (flip T.snoc '|' . flip T.replicate "-" . (2 +)) ws - -listToRow :: [Int] -> [Text] -> Text -listToRow mw xs = wrap '|' . T.intercalate "|" $ zipWith format mw xs - where - format w x = wrap ' ' x <> T.replicate (w - T.length x) " " - -maxWidths :: [[Text]] -> [Int] -maxWidths = map (maximum . map T.length) . transpose - --- --------- --- COMMANDS --- --------- - -commandHeader :: [Text] -commandHeader = ["Syntax", "Type", "Capability", "Description"] - -commandToList :: Const -> [Text] -commandToList c = - map - escapeTable - [ addLink ("#" <> tshow c) . codeQuote $ constSyntax c - , codeQuote . prettyText $ inferConst c - , maybe "" Capability.capabilityName $ Capability.constCaps c - , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c - ] - -constTable :: [Const] -> Text -constTable cs = T.unlines $ header <> map (listToRow mw) commandRows - where - mw = maxWidths (commandHeader : commandRows) - commandRows = map commandToList cs - header = [listToRow mw commandHeader, separatingLine mw] - -commandToSection :: Const -> Text -commandToSection c = - T.unlines $ - [ "## " <> T.pack (show c) - , "" - , "- syntax: " <> codeQuote (constSyntax c) - , "- type: " <> (codeQuote . prettyText $ inferConst c) - , maybe "" (("- required capabilities: " <>) . Capability.capabilityName) $ Capability.constCaps c - , "" - , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c - ] - <> let l = Syntax.longDoc . Syntax.constDoc $ Syntax.constInfo c - in if T.null l then [] else ["", l] - -commandsPage :: Text -commandsPage = - T.intercalate "\n\n" $ - [ "# Commands" - , constTable commands - , "# Builtin functions" - , "These functions are evaluated immediately once they have enough arguments." - , constTable builtinFunctions - , "# Operators" - , constTable operators - , "# Detailed descriptions" - ] - <> map commandToSection (commands <> builtinFunctions <> operators) - --- ------------- --- CAPABILITIES --- ------------- - -capabilityHeader :: [Text] -capabilityHeader = ["Name", "Commands", "Entities"] - -capabilityRow :: PageAddress -> EntityMap -> Capability -> [Text] -capabilityRow PageAddress {..} em cap = - map - escapeTable - [ Capability.capabilityName cap - , T.intercalate ", " (linkCommand <$> cs) - , T.intercalate ", " (linkEntity . view entityName <$> es) - ] - where - linkEntity t = - if T.null entityAddress - then t - else addLink (entityAddress <> "#" <> T.replace " " "-" t) t - linkCommand c = - ( if T.null commandsAddress - then id - else addLink (commandsAddress <> "#" <> tshow c) - ) - . codeQuote - $ constSyntax c - - cs = [c | c <- Syntax.allConst, let mcap = Capability.constCaps c, isJust $ find (== cap) mcap] - es = fromMaybe [] $ E.entitiesByCap em Map.!? cap - -capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text -capabilityTable a em cs = T.unlines $ header <> map (listToRow mw) capabilityRows - where - mw = maxWidths (capabilityHeader : capabilityRows) - capabilityRows = map (capabilityRow a em) cs - header = [listToRow mw capabilityHeader, separatingLine mw] - -capabilityPage :: PageAddress -> EntityMap -> Text -capabilityPage a em = capabilityTable a em listEnums - --- --------- --- Entities --- --------- - -entityHeader :: [Text] -entityHeader = ["?", "Name", "Capabilities", "Properties*", "Portable"] - -entityToList :: Entity -> [Text] -entityToList e = - map - escapeTable - [ codeQuote . T.singleton $ e ^. entityDisplay . to displayChar - , addLink ("#" <> linkID) $ view entityName e - , T.intercalate ", " $ Capability.capabilityName <$> Set.toList (view E.entityCapabilities e) - , T.intercalate ", " . map tshow . filter (/= E.Portable) $ toList props - , if E.Portable `elem` props - then ":heavy_check_mark:" - else ":negative_squared_cross_mark:" - ] - where - props = view E.entityProperties e - linkID = T.replace " " "-" $ view entityName e - -entityTable :: [Entity] -> Text -entityTable es = T.unlines $ header <> map (listToRow mw) entityRows - where - mw = maxWidths (entityHeader : entityRows) - entityRows = map entityToList es - header = [listToRow mw entityHeader, separatingLine mw] - -entityToSection :: Entity -> Text -entityToSection e = - T.unlines $ - [ "## " <> view E.entityName e - , "" - , " - Char: " <> (codeQuote . T.singleton $ e ^. entityDisplay . to displayChar) - ] - <> [" - Properties: " <> T.intercalate ", " (map tshow $ toList props) | not $ null props] - <> [" - Capabilities: " <> T.intercalate ", " (Capability.capabilityName <$> caps) | not $ null caps] - <> ["\n"] - <> [Markdown.docToMark $ view E.entityDescription e] - where - props = view E.entityProperties e - caps = Set.toList $ view E.entityCapabilities e - -entitiesPage :: PageAddress -> [Entity] -> Text -entitiesPage _a es = - T.intercalate "\n\n" $ - [ "# Entities" - , "This is a quick-overview table of entities - click the name for detailed description." - , "*) As a note, most entities have the Portable property, so we show it in a separate column." - , entityTable es - ] - <> map entityToSection es - --- ------------- --- RECIPES --- ------------- - -recipeHeader :: [Text] -recipeHeader = ["In", "Out", "Required", "Time", "Weight"] - -recipeRow :: PageAddress -> Recipe Entity -> [Text] -recipeRow PageAddress {..} r = - map - escapeTable - [ T.intercalate ", " (map formatCE $ view recipeInputs r) - , T.intercalate ", " (map formatCE $ view recipeOutputs r) - , T.intercalate ", " (map formatCE $ view recipeCatalysts r) - , tshow $ view recipeTime r - , tshow $ view recipeWeight r - ] - where - formatCE (c, e) = T.unwords [tshow c, linkEntity $ view entityName e] - linkEntity t = - if T.null entityAddress - then t - else addLink (entityAddress <> "#" <> T.replace " " "-" t) t - -recipeTable :: PageAddress -> [Recipe Entity] -> Text -recipeTable a rs = T.unlines $ header <> map (listToRow mw) recipeRows - where - mw = maxWidths (recipeHeader : recipeRows) - recipeRows = map (recipeRow a) rs - header = [listToRow mw recipeHeader, separatingLine mw] - -recipePage :: PageAddress -> [Recipe Entity] -> Text -recipePage = recipeTable - -getBaseRobot :: Has (Throw SystemFailure) sig m => Scenario -> m Robot -getBaseRobot s = case listToMaybe $ view scenarioRobots s of - Just r -> pure $ instantiateRobot 0 r - Nothing -> throwError $ CustomFailure "Scenario contains no robots" - --- ---------------------------------------------------------------------------- --- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES --- ---------------------------------------------------------------------------- - -generateRecipe :: IO String -generateRecipe = simpleErrorHandle $ do - (classic, (worlds, entities, recipes)) <- loadStandaloneScenario "data/scenarios/classic.yaml" - baseRobot <- getBaseRobot classic - return . Dot.showDot $ recipesToDot baseRobot (worlds ! "classic") entities recipes - -recipesToDot :: Robot -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot () -recipesToDot baseRobot classicTerm emap recipes = 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' = toList . Map.keysSet . entitiesByName $ emap - enames = filter (`Set.notMember` ignoredEntities) enames' - ebmap <- Map.fromList . zip enames <$> mapM (box . unpack) enames - -- -------------------------------------------------------------------------- - -- getters for the NodeId based on entity name or the whole entity - let safeGetEntity m e = fromMaybe (error $ unpack e <> " is not an entity!?") $ m Map.!? e - 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 = startingDevices baseRobot - inv = startingInventory baseRobot - worldEntities = case classicTerm of Some _ t -> extractEntities t - levels = recipeLevels recipes (Set.unions [worldEntities, devs]) - -- -------------------------------------------------------------------------- - -- Base inventory - (_bc, ()) <- Dot.cluster $ do - Dot.attribute ("style", "filled") - Dot.attribute ("color", "lightgrey") - mapM_ ((base ---<>) . nid) devs - mapM_ ((base .->.) . nid . fst) $ Map.toList inv - -- -------------------------------------------------------------------------- - -- World entities - (_wc, ()) <- Dot.cluster $ do - Dot.attribute ("style", "filled") - Dot.attribute ("color", "forestgreen") - mapM_ (uncurry (Dot..->.) . (world,) . getE . view entityName) (toList worldEntities) - -- -------------------------------------------------------------------------- - let -- put a hidden node above and below entities and connect them by hidden edges - wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId) - wrapBelowAbove ns = do - b <- hiddenNode - t <- hiddenNode - let ns' = map nid $ toList ns - mapM_ (b .~>.) ns' - mapM_ (.~>. t) ns' - return (b, t) - -- put set of entities in nice - subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId) - subLevel i ns = fmap snd . Dot.cluster $ do - Dot.attribute ("style", "filled") - Dot.attribute ("color", "khaki") - bt <- wrapBelowAbove ns - Dot.attribute ("rank", "sink") - -- the normal label for cluster would be cover by lines - _bigLabel <- - Dot.node - [ ("shape", "plain") - , ("label", "Bottom Label") - , ("fontsize", "20pt") - , ("label", "Level #" <> show i) - ] - return bt - -- -------------------------------------------------------------------------- - -- order entities into clusters based on how "far" they are from - -- what is available at the start - see 'recipeLevels'. - bottom <- wrapBelowAbove worldEntities - ls <- zipWithM subLevel [1 ..] (drop 1 levels) - let invisibleLine = zipWithM_ (.~>.) - tls <- mapM (const hiddenNode) levels - bls <- mapM (const hiddenNode) levels - invisibleLine tls bls - invisibleLine bls (drop 1 tls) - let sameBelowAbove (b1, t1) (b2, t2) = Dot.same [b1, b2] >> Dot.same [t1, t2] - zipWithM_ sameBelowAbove (bottom : ls) (zip bls tls) - -- -------------------------------------------------------------------------- - -- add node for the world and draw a line to each entity found in the wild - -- finally draw recipes - let recipeInOut r = [(snd i, snd o) | i <- r ^. recipeInputs, o <- r ^. recipeOutputs] - recipeReqOut r = [(snd q, snd o) | q <- r ^. recipeCatalysts, o <- r ^. recipeOutputs] - recipesToPairs f rs = both nid <$> nubOrd (concatMap f rs) - mapM_ (uncurry (.->.)) (recipesToPairs recipeInOut recipes) - mapM_ (uncurry (---<>)) (recipesToPairs recipeReqOut 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) 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 :: [Recipe Entity] -> Set Entity -> [Set Entity] -recipeLevels 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 - nextLevel known = Set.unions . 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" - ] - --- ---------------------------------------------------------------------------- --- GRAPHVIZ HELPERS --- ---------------------------------------------------------------------------- - -customNode :: [(String, String)] -> String -> Dot NodeId -customNode attrs label = Dot.node $ [("style", "filled"), ("label", label)] <> attrs - -box, diamond :: String -> Dot NodeId -box = customNode [("shape", "box")] -diamond = customNode [("shape", "diamond")] - --- | Hidden node - used for layout. -hiddenNode :: Dot NodeId -hiddenNode = Dot.node [("style", "invis")] - --- | Hidden edge - used for layout. -(.~>.) :: NodeId -> NodeId -> Dot () -i .~>. j = Dot.edge i j [("style", "invis")] - --- | Edge for recipe requirements and outputs. -(---<>) :: NodeId -> NodeId -> Dot () -e1 ---<> e2 = Dot.edge e1 e2 attrs - where - attrs = [("arrowhead", "diamond"), ("color", "blue")] diff --git a/src/Swarm/Doc/Pedagogy.hs b/src/Swarm/Doc/Pedagogy.hs deleted file mode 100644 --- a/src/Swarm/Doc/Pedagogy.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Assess pedagogical soundness of the tutorials. --- --- Approach: --- --- 1. Obtain a list of all of the tutorial scenarios, in order --- 2. Search their \"solution\" code for `commands` --- 3. "fold" over the tutorial list, noting which tutorial was first to introduce each command -module Swarm.Doc.Pedagogy ( - renderTutorialProgression, - generateIntroductionsSequence, - CoverageInfo (..), - TutorialInfo (..), -) where - -import Control.Lens (universe, view, (^.)) -import Control.Monad (guard) -import Data.List (foldl', intercalate, sort, sortOn) -import Data.List.Extra (zipFrom) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (mapMaybe) -import Data.Sequence (Seq) -import Data.Set (Set) -import Data.Set qualified as S -import Data.Text (Text) -import Data.Text qualified as T -import Swarm.Constant -import Swarm.Game.Entity (loadEntities) -import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.Scenario (Scenario, scenarioDescription, scenarioName, scenarioObjectives, scenarioSolution) -import Swarm.Game.Scenario.Objective (objectiveGoal) -import Swarm.Game.ScenarioInfo (ScenarioCollection, ScenarioInfoPair, flatten, loadScenarios, scenarioCollectionToList, scenarioPath) -import Swarm.Game.World.Load (loadWorlds) -import Swarm.Language.Module (Module (..)) -import Swarm.Language.Pipeline (ProcessedTerm (..)) -import Swarm.Language.Syntax -import Swarm.Language.Text.Markdown (docToText, findCode) -import Swarm.Language.Types (Polytype) -import Swarm.TUI.Controller (getTutorials) -import Swarm.Util.Effect (ignoreWarnings, simpleErrorHandle) - --- * Constants - -commandsWikiAnchorPrefix :: Text -commandsWikiAnchorPrefix = wikiCheatSheet <> "#" - --- * Types - --- | Tutorials augmented by the set of --- commands that they introduce. --- Generated by folding over all of the --- tutorials in sequence. -data CoverageInfo = CoverageInfo - { tutInfo :: TutorialInfo - , novelSolutionCommands :: Map Const [SrcLoc] - } - --- | Tutorial scenarios with the set of commands --- introduced in their solution and descriptions --- having been extracted -data TutorialInfo = TutorialInfo - { scenarioPair :: ScenarioInfoPair - , tutIndex :: Int - , solutionCommands :: Map Const [SrcLoc] - , descriptionCommands :: Set Const - } - --- | A private type used by the fold -data CommandAccum = CommandAccum - { _encounteredCmds :: Set Const - , tuts :: [CoverageInfo] - } - --- * Functions - --- | Extract commands from both goal descriptions and solution code. -extractCommandUsages :: Int -> ScenarioInfoPair -> TutorialInfo -extractCommandUsages idx siPair@(s, _si) = - TutorialInfo siPair idx solnCommands $ getDescCommands s - where - solnCommands = getCommands maybeSoln - maybeSoln = view scenarioSolution s - --- | Obtain the set of all commands mentioned by --- name in the tutorial's goal descriptions. -getDescCommands :: Scenario -> Set Const -getDescCommands s = S.fromList $ concatMap filterConst allCode - where - goalTextParagraphs = view objectiveGoal <$> view scenarioObjectives s - allCode = concatMap findCode goalTextParagraphs - filterConst :: Syntax -> [Const] - filterConst sx = mapMaybe toConst $ universe (sx ^. sTerm) - toConst :: Term -> Maybe Const - toConst = \case - TConst c -> Just c - _ -> Nothing - -isConsidered :: Const -> Bool -isConsidered c = isUserFunc c && c `S.notMember` ignoredCommands - where - ignoredCommands = S.fromList [Run, Return, Noop, Force] - --- | Extract the command names from the source code of the solution. --- --- NOTE: `noop` gets automatically inserted for an empty `build {}` command --- at parse time, so we explicitly ignore the `noop` in the case that --- the player did not write it explicitly in their code. --- --- Also, the code from `run` is not parsed transitively yet. -getCommands :: Maybe ProcessedTerm -> Map Const [SrcLoc] -getCommands Nothing = mempty -getCommands (Just (ProcessedTerm (Module stx _) _ _)) = - M.fromListWith (<>) $ mapMaybe isCommand nodelist - where - nodelist :: [Syntax' Polytype] - nodelist = universe stx - isCommand (Syntax' sloc t _) = case t of - TConst c -> guard (isConsidered c) >> Just (c, [sloc]) - _ -> Nothing - --- | "fold" over the tutorials in sequence to determine which --- commands are novel to each tutorial's solution. -computeCommandIntroductions :: [(Int, ScenarioInfoPair)] -> [CoverageInfo] -computeCommandIntroductions = - reverse . tuts . foldl' f initial - where - initial = CommandAccum mempty mempty - - f :: CommandAccum -> (Int, ScenarioInfoPair) -> CommandAccum - f (CommandAccum encounteredPreviously xs) (idx, siPair) = - CommandAccum updatedEncountered $ CoverageInfo usages novelCommands : xs - where - usages = extractCommandUsages idx siPair - usedCmdsForTutorial = solutionCommands usages - - updatedEncountered = encounteredPreviously `S.union` M.keysSet usedCmdsForTutorial - novelCommands = M.withoutKeys usedCmdsForTutorial encounteredPreviously - --- | Extract the tutorials from the complete scenario collection --- and derive their command coverage info. -generateIntroductionsSequence :: ScenarioCollection -> [CoverageInfo] -generateIntroductionsSequence = - computeCommandIntroductions . zipFrom 0 . getTuts - where - getTuts = - concatMap flatten - . scenarioCollectionToList - . getTutorials - --- * Rendering functions - --- | Helper for standalone rendering. --- For unit tests, can instead access the scenarios via the GameState. -loadScenarioCollection :: IO ScenarioCollection -loadScenarioCollection = simpleErrorHandle $ do - entities <- loadEntities - -- Note we ignore any warnings generated by 'loadWorlds' and - -- 'loadScenarios' below. Any warnings will be caught when loading - -- 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 entities - ignoreWarnings @(Seq SystemFailure) $ loadScenarios entities worlds - -renderUsagesMarkdown :: CoverageInfo -> Text -renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) = - T.unlines bodySections - where - bodySections = firstLine : otherLines - otherLines = - intercalate - [""] - [ pure . surround "`" . T.pack $ view scenarioPath si - , pure . surround "*" . T.strip . docToText $ view scenarioDescription s - , renderSection "Introduced in solution" . renderCmdList $ M.keysSet novelCmds - , renderSection "Referenced in description" $ renderCmdList dCmds - ] - surround x y = x <> y <> x - - renderSection title content = - ["### " <> title] <> content - - firstLine = - T.unwords - [ "##" - , renderTutorialTitle idx s - ] - -renderTutorialTitle :: (Show a) => a -> Scenario -> Text -renderTutorialTitle idx s = - T.unwords - [ T.pack $ show idx <> ":" - , view scenarioName s - ] - -linkifyCommand :: Text -> Text -linkifyCommand c = "[" <> c <> "](" <> commandsWikiAnchorPrefix <> c <> ")" - -renderList :: [Text] -> [Text] -renderList items = - if null items - then pure "(none)" - else map ("* " <>) items - -cmdSetToSortedText :: Set Const -> [Text] -cmdSetToSortedText = sort . map (T.pack . show) . S.toList - -renderCmdList :: Set Const -> [Text] -renderCmdList = renderList . map linkifyCommand . cmdSetToSortedText - --- | Generate a document which lists all the tutorial scenarios, --- highlighting for each one which commands are introduced for the --- first time in the canonical solution, and which commands are --- referenced in the tutorial description. -renderTutorialProgression :: IO Text -renderTutorialProgression = - processAndRender <$> loadScenarioCollection - where - processAndRender ss = - T.unlines allLines - where - introSection = - "# Command introductions by tutorial" - : "This document indicates which tutorials introduce various commands and keywords." - : "" - : "All used:" - : renderFullCmdList allUsed - - render (cmd, tut) = - T.unwords - [ linkifyCommand cmd - , "(" <> renderTutorialTitle (tutIndex tut) (fst $ scenarioPair tut) <> ")" - ] - renderFullCmdList = renderList . map render . sortOn fst - infos = generateIntroductionsSequence ss - allLines = introSection <> map renderUsagesMarkdown infos - allUsed = concatMap mkTuplesForTutorial infos - - mkTuplesForTutorial tut = - map (\x -> (T.pack $ show x, tutIdxScenario)) $ - M.keys $ - novelSolutionCommands tut - where - tutIdxScenario = tutInfo tut diff --git a/src/Swarm/Doc/Schema/Arrangement.hs b/src/Swarm/Doc/Schema/Arrangement.hs deleted file mode 100644 --- a/src/Swarm/Doc/Schema/Arrangement.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Graph-based heuristics for arranging the --- order of sections in the schema docs -module Swarm.Doc.Schema.Arrangement (sortAndPruneSchemas) where - -import Data.Graph -import Data.Set qualified as Set -import Swarm.Doc.Schema.Parse -import Swarm.Doc.Schema.Refined -import Swarm.Doc.Schema.SchemaType - --- | Sort the schemas in topological order. --- --- Only includes schema files that are reachable from --- the root schema --- (i.e. exclude @entities.json@ and @recipes.json@, --- which are used independently to validate @entities.yaml@ --- and @recipes.yaml@). -sortAndPruneSchemas :: - SchemaIdReference -> - [SchemaData] -> - [SchemaData] -sortAndPruneSchemas rootSchemaKey schemas = - reverse . flattenSCCs . stronglyConnComp $ reachableEdges - where - rawEdgeList = map getNodeEdgesEntry schemas - (graph, _nodeFromVertex, vertexFromKey) = graphFromEdges rawEdgeList - reachableVertices = Set.fromList $ maybe [] (reachable graph) $ vertexFromKey rootSchemaKey - - reachableEdges = filter f rawEdgeList - f (_, k, _) = maybe False (`Set.member` reachableVertices) . vertexFromKey $ k - -getNodeEdgesEntry :: - SchemaData -> - (SchemaData, SchemaIdReference, [SchemaIdReference]) -getNodeEdgesEntry sd@(SchemaData fp schem _) = - ( sd - , fromFilePath fp - , Set.toList $ extractReferences $ content schem - ) diff --git a/src/Swarm/Doc/Schema/Parse.hs b/src/Swarm/Doc/Schema/Parse.hs deleted file mode 100644 --- a/src/Swarm/Doc/Schema/Parse.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- There are no modern, comprehensive JSON Schema parsing --- libraries in Haskell, as explained in --- . --- --- Therefore, a bespoke parser for a small subset of JSON Schema is implemented here, --- simply for rendering Markdown documentation from Swarm's schema. -module Swarm.Doc.Schema.Parse where - -import Control.Applicative ((<|>)) -import Data.Aeson -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Swarm.Doc.Schema.Refined -import Text.Pandoc - --- | Includes everything needed to --- render the schema to markdown -data SchemaData = SchemaData - { schemaPath :: FilePath - , schemaContent :: ToplevelSchema - , markdownFooters :: [Pandoc] - } - -data Members - = ObjectProperties (Map Text SwarmSchema) - | ListMembers (ItemDescription SwarmSchema) - deriving (Eq, Ord, Show) - -data ToplevelSchema = ToplevelSchema - { title :: Text - , description :: Maybe Pandoc - , content :: SwarmSchema - , members :: Maybe Members - , footerPaths :: [FilePath] - } - deriving (Eq, Ord, Show) - -instance FromJSON ToplevelSchema where - parseJSON x = do - rawSchema :: rawSchema <- parseJSON x - swarmSchema <- toSwarmSchema rawSchema - - theTitle <- maybe (fail "Schema requires a title") return $ _title rawSchema - let theFooters = fromMaybe [] $ _footers rawSchema - maybeMembers = - ObjectProperties <$> properties swarmSchema - <|> ListMembers <$> itemsDescription swarmSchema - return $ ToplevelSchema theTitle (objectDescription swarmSchema) swarmSchema maybeMembers theFooters diff --git a/src/Swarm/Doc/Schema/Refined.hs b/src/Swarm/Doc/Schema/Refined.hs deleted file mode 100644 --- a/src/Swarm/Doc/Schema/Refined.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Refined JSON schema after converting --- all JSON Value types to their specific sum types -module Swarm.Doc.Schema.Refined where - -import Control.Applicative ((<|>)) -import Data.Aeson -import Data.List.Extra (replace) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics (Generic) -import Swarm.Doc.Schema.SchemaType -import System.FilePath (takeBaseName) -import Text.Pandoc -import Text.Pandoc.Builder - --- * Basic - -schemaJsonOptions :: Options -schemaJsonOptions = - defaultOptions - { fieldLabelModifier = replace "S" "$" . drop 1 -- drops leading underscore - } - --- | A single record that encompasses all possible objects --- in a JSON schema. All fields are optional. -data SchemaRaw = SchemaRaw - { _description :: Maybe Text - , _default :: Maybe Value - , _title :: Maybe Text - , _type :: Maybe (SingleOrList Text) - , _name :: Maybe Text - , _properties :: Maybe (Map Text SwarmSchema) - , _items :: Maybe (ItemDescription SwarmSchema) - , _examples :: Maybe [Value] - , _Sref :: Maybe Text - , _oneOf :: Maybe [SchemaRaw] - , _footers :: Maybe [FilePath] - , _additionalProperties :: Maybe Bool - } - deriving (Eq, Ord, Show, Generic) - -instance FromJSON SchemaRaw where - parseJSON = genericParseJSON schemaJsonOptions - -extractSchemaType :: SchemaRaw -> Maybe SchemaType -extractSchemaType rawSchema = - mkReference <$> _Sref rawSchema - <|> getTypeFromItems - <|> Simple <$> _type rawSchema - <|> Alternatives . mapMaybe extractSchemaType <$> _oneOf rawSchema - where - mkReference = Reference . SchemaIdReference . T.pack . takeBaseName . T.unpack - - getTypeFromItems :: Maybe SchemaType - getTypeFromItems = do - itemsThing <- _items rawSchema - case itemsThing of - ItemList _ -> Nothing - ItemType x -> Just $ ListOf $ schemaType x - --- * Refined - -data ItemDescription a - = ItemList [a] - | ItemType a - deriving (Eq, Ord, Show) - -instance (FromJSON a) => FromJSON (ItemDescription a) where - parseJSON x = - ItemList <$> parseJSON x - <|> ItemType <$> parseJSON x - -getSchemaReferences :: SchemaType -> [SchemaIdReference] -getSchemaReferences = \case - Simple _ -> [] - Alternatives xs -> concatMap getSchemaReferences xs - Reference x -> pure x - ListOf x -> getSchemaReferences x - --- | A subset of all JSON schemas, conforming to internal Swarm conventions. --- --- Conveniently, this extra representation layer --- is able to enforce (via 'toSwarmSchema') that all "object" --- definitions in the schema contain the @"additionalProperties": true@ attribute. -data SwarmSchema = SwarmSchema - { schemaType :: SchemaType - , defaultValue :: Maybe Value - , objectDescription :: Maybe Pandoc - , properties :: Maybe (Map Text SwarmSchema) - , itemsDescription :: Maybe (ItemDescription SwarmSchema) - , examples :: [Value] - } - deriving (Eq, Ord, Show) - -instance FromJSON SwarmSchema where - parseJSON x = do - rawSchema :: rawSchema <- parseJSON x - toSwarmSchema rawSchema - -getMarkdown :: MonadFail m => Text -> m Pandoc -getMarkdown desc = case runPure (readMarkdown def desc) of - Right d -> return d - Left err -> fail $ T.unpack $ renderError err - -toSwarmSchema :: MonadFail m => SchemaRaw -> m SwarmSchema -toSwarmSchema rawSchema = do - 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'" - - return - SwarmSchema - { schemaType = theType - , defaultValue = _default rawSchema - , objectDescription = markdownDescription <|> doc . plain . text <$> _name rawSchema - , examples = fromMaybe [] $ _examples rawSchema - , properties = _properties rawSchema - , itemsDescription = _items rawSchema - } - where - maybeType = extractSchemaType rawSchema - --- * Utilities - --- | Recursively extract references to other schemas -extractReferences :: SwarmSchema -> Set SchemaIdReference -extractReferences s = thisRefList <> otherRefLists - where - thisRefList = Set.fromList . getSchemaReferences $ schemaType s - - otherSchemas = maybe [] M.elems $ properties s - otherRefLists = Set.unions $ map extractReferences otherSchemas diff --git a/src/Swarm/Doc/Schema/Render.hs b/src/Swarm/Doc/Schema/Render.hs deleted file mode 100644 --- a/src/Swarm/Doc/Schema/Render.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Render a markdown document fragment --- from the Scenario JSON schema files. -module Swarm.Doc.Schema.Render where - -import Control.Arrow (left, (&&&)) -import Control.Monad.Except (runExceptT) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Except (except) -import Data.Aeson -import Data.List (intersperse) -import Data.Map (Map) -import Data.Map.Strict qualified as M -import Data.Maybe (fromMaybe) -import Data.Scientific (FPFormat (..), Scientific, formatScientific) -import Data.Text qualified as T -import Data.Text.IO qualified as TIO -import Data.Vector qualified as V -import Swarm.Doc.Schema.Arrangement -import Swarm.Doc.Schema.Parse -import Swarm.Doc.Schema.Refined -import Swarm.Doc.Schema.SchemaType -import Swarm.Doc.Util -import Swarm.Util (applyWhen, brackets, quote, showT) -import System.Directory (listDirectory) -import System.FilePath (splitExtension, (<.>), ()) -import Text.Pandoc -import Text.Pandoc.Builder -import Text.Pandoc.Walk (query) - -scenariosDir :: FilePath -scenariosDir = "data/scenarios" - -docFragmentsDir :: FilePath -docFragmentsDir = scenariosDir "doc-fragments" - -schemasDir :: FilePath -schemasDir = "data/schema" - -schemaExtension :: String -schemaExtension = ".json" - -propertyColumnHeadings :: [T.Text] -propertyColumnHeadings = - [ "Key" - , "Default?" - , "Type" - , "Description" - ] - -listColumnHeadings :: [T.Text] -listColumnHeadings = - [ "Index" - , "Type" - , "Description" - ] - -makeTitleMap :: [SchemaData] -> Map SchemaIdReference T.Text -makeTitleMap = M.fromList . map (fromFilePath . schemaPath &&& title . schemaContent) - -makePandocTable :: Map SchemaIdReference T.Text -> SchemaData -> Pandoc -makePandocTable titleMap (SchemaData _ (ToplevelSchema theTitle theDescription _schema theMembers _) parsedFooters) = - setTitle (text "JSON Schema for Scenarios") $ - doc (header 3 (text theTitle)) - <> fromMaybe mempty theDescription - <> maybe mempty mkTable theMembers - <> mconcat parsedFooters - where - renderItems someStuff = case someStuff of - ItemType x -> plain $ text "List of " <> listToText titleMap (schemaType x) - ItemList xs -> - makePropsTable False listColumnHeadings titleMap - . M.fromList - $ zip (map tshow [0 :: Int ..]) xs - - mkTable x = doc $ case x of - ObjectProperties props -> makePropsTable True propertyColumnHeadings titleMap props - ListMembers someStuff -> renderItems someStuff - -genPropsRow :: Bool -> Map SchemaIdReference T.Text -> (T.Text, SwarmSchema) -> [Blocks] -genPropsRow includeDefaultColumn titleMap (k, x) = - firstColumn : applyWhen includeDefaultColumn (defaultColumn :) tailColumns - where - firstColumn = plain $ code k - defaultColumn = maybe mempty (plain . code . renderValue) $ defaultValue x - tailColumns = - [ plain . listToText titleMap $ schemaType x - , fromList $ maybe [] (query id) $ objectDescription x - ] - -makePropsTable :: - Bool -> - [T.Text] -> - Map SchemaIdReference T.Text -> - Map T.Text SwarmSchema -> - Blocks -makePropsTable includeDefaultColumn headingsList titleMap = - simpleTable headerRow . map (genPropsRow includeDefaultColumn titleMap) . M.toList - where - headerRow = map (plain . text) headingsList - -type FileStemAndExtension = (FilePath, String) - -recombineExtension :: FileStemAndExtension -> FilePath -recombineExtension (filenameStem, fileExtension) = - filenameStem <.> fileExtension - -genMarkdown :: [SchemaData] -> Either T.Text T.Text -genMarkdown schemaThings = - left renderError $ - runPure $ - writeMarkdown (def {writerExtensions = extensionsFromList [Ext_pipe_tables]}) pd - where - titleMap = makeTitleMap schemaThings - pd = - mconcat $ - map (makePandocTable titleMap) $ - sortAndPruneSchemas (fromFilePath "scenario") schemaThings - -parseSchemaFile :: FileStemAndExtension -> IO (Either T.Text ToplevelSchema) -parseSchemaFile stemAndExtension = - left (prependPath . T.pack) <$> eitherDecodeFileStrict fullPath - where - prependPath = ((T.unwords ["in", quote (T.pack filename)] <> ": ") <>) - filename = recombineExtension stemAndExtension - fullPath = schemasDir filename - -loadFooterContent :: (FilePath, ToplevelSchema) -> IO SchemaData -loadFooterContent (fp, schem) = do - xs <- mapM (TIO.readFile . (scenariosDir )) $ footerPaths schem - parsedFooters <- mapM getMarkdown xs - return $ - SchemaData - fp - schem - parsedFooters - -genScenarioSchemaDocs :: IO () -genScenarioSchemaDocs = do - dirContents <- listDirectory schemasDir - let inputFiles = filter ((== schemaExtension) . snd) $ map splitExtension dirContents - xs <- mapM (sequenceA . (recombineExtension &&& parseSchemaFile)) inputFiles - - result <- runExceptT $ do - schemaTuples <- except $ traverse sequenceA xs - things <- liftIO $ mapM loadFooterContent schemaTuples - myMarkdown <- except $ genMarkdown things - docHeader <- liftIO $ TIO.readFile "data/scenarios/doc-fragments/header.md" - liftIO . writeFile (docFragmentsDir "SCHEMA.md") . T.unpack $ docHeader <> myMarkdown - - case result of - Left e -> print $ unwords ["Failed:", T.unpack e] - Right _ -> return () - -renderValue :: Value -> T.Text -renderValue = \case - Object obj -> showT obj - Array arr -> brackets . T.intercalate ", " . map renderValue $ V.toList arr - String t -> quote t - Number num -> T.pack $ formatNumberCompact num - Bool b -> showT b - Null -> "null" - -fragmentHref :: Map SchemaIdReference T.Text -> SchemaIdReference -> T.Text -fragmentHref titleMap r@(SchemaIdReference ref) = - T.cons '#' . T.toLower . T.replace " " "-" $ x - where - x = M.findWithDefault ref r titleMap - -listToText :: Map SchemaIdReference T.Text -> SchemaType -> Inlines -listToText titleMap = \case - Simple xs -> renderAlternatives $ map code $ getList xs - Alternatives xs -> renderAlternatives $ map (listToText titleMap) xs - Reference r@(SchemaIdReference x) -> schemaLink r x - ListOf x -> listToText titleMap x <> text " list" - where - renderAlternatives = mconcat . intersperse (text " or ") - schemaLink r = link (fragmentHref titleMap r) "Link to object properties" . text - --- | --- Strips trailing zeros and decimal point from a floating-point number --- when possible. --- --- Obtained from here: https://stackoverflow.com/a/35980995/105137 -formatNumberCompact :: Scientific -> String -formatNumberCompact v - | v == 0 = "0" - | abs v < 1e-5 || abs v > 1e10 = formatScientific Exponent Nothing v - | v - fromIntegral (floor v :: Integer) == 0 = formatScientific Fixed (Just 0) v - | otherwise = formatScientific Generic Nothing v diff --git a/src/Swarm/Doc/Schema/SchemaType.hs b/src/Swarm/Doc/Schema/SchemaType.hs deleted file mode 100644 --- a/src/Swarm/Doc/Schema/SchemaType.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Representation of the "type" of a schema. -module Swarm.Doc.Schema.SchemaType where - -import Control.Applicative ((<|>)) -import Data.Aeson -import Data.Text (Text) -import Data.Text qualified as T -import System.FilePath (takeBaseName) - -newtype SingleOrList a = SingleOrList - { getList :: [a] - } - deriving (Eq, Ord, Show) - -instance (FromJSON a) => FromJSON (SingleOrList a) where - parseJSON x = - fmap SingleOrList $ - pure <$> parseJSON x <|> parseJSON x - -data SchemaType - = -- | A basic built-in type - Simple (SingleOrList Text) - | -- | Any one of multiple possible schema types - Alternatives [SchemaType] - | -- | A reference to a schema defined elsewhere - Reference SchemaIdReference - | -- | Members of a list, all of the given schema type - ListOf SchemaType - deriving (Eq, Ord, Show) - -newtype SchemaIdReference = SchemaIdReference Text - deriving (Eq, Ord, Show) - -fromFilePath :: FilePath -> SchemaIdReference -fromFilePath = SchemaIdReference . T.pack . takeBaseName diff --git a/src/Swarm/Doc/Util.hs b/src/Swarm/Doc/Util.hs deleted file mode 100644 --- a/src/Swarm/Doc/Util.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Utilities for generating doc markup -module Swarm.Doc.Util where - -import Data.Text (Text) -import Data.Text qualified as T - -wrap :: Char -> Text -> Text -wrap c = T.cons c . flip T.snoc c - -codeQuote :: Text -> Text -codeQuote = wrap '`' - -addLink :: Text -> Text -> Text -addLink l t = T.concat ["[", t, "](", l, ")"] - -tshow :: (Show a) => a -> Text -tshow = T.pack . show diff --git a/src/Swarm/Game/Achievement/Attainment.hs b/src/Swarm/Game/Achievement/Attainment.hs deleted file mode 100644 --- a/src/Swarm/Game/Achievement/Attainment.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Metadata about achievements that the player has obtained. -module Swarm.Game.Achievement.Attainment ( - Attainment (..), - achievement, - maybeScenarioPath, - obtainedAt, -) where - -import Control.Lens hiding (from, (<.>)) -import Data.Aeson ( - Options (..), - defaultOptions, - genericParseJSON, - genericToJSON, - ) -import Data.Function (on) -import Data.Time (ZonedTime, zonedTimeToUTC) -import Data.Yaml as Y -import GHC.Generics (Generic) -import Swarm.Game.Achievement.Definitions - --- | A record holding an achievement along with some metadata to --- record the time at which the achievement was obtained, and the --- scenario in which it was achieved. -data Attainment = Attainment - { _achievement :: CategorizedAchievement - -- ^ The achievement. - , _maybeScenarioPath :: Maybe FilePath - -- ^ From which scenario was it obtained? - , _obtainedAt :: ZonedTime - -- ^ What time was it obtained? - } - deriving (Generic) - -makeLenses ''Attainment - -instance Eq Attainment where - (==) = (==) `on` _achievement - -instance Ord Attainment where - compare = compare `on` (zonedTimeToUTC . _obtainedAt) - -instance Semigroup Attainment where - (<>) = min - -instance FromJSON Attainment where - parseJSON = genericParseJSON achievementJsonOptions - -instance ToJSON Attainment where - toJSON = genericToJSON achievementJsonOptions - -achievementJsonOptions :: Options -achievementJsonOptions = - defaultOptions - { fieldLabelModifier = drop 1 -- drops leading underscore - } diff --git a/src/Swarm/Game/Achievement/Definitions.hs b/src/Swarm/Game/Achievement/Definitions.hs deleted file mode 100644 --- a/src/Swarm/Game/Achievement/Definitions.hs +++ /dev/null @@ -1,120 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Definitions of all possible achievements. -module Swarm.Game.Achievement.Definitions ( - -- * Achievements - CategorizedAchievement (..), - GlobalAchievement (..), - GameplayAchievement (..), - listAchievements, - - -- * Achievement info - ExpectedEffort (..), - Quotation (..), - FlavorText (..), - AchievementInfo (..), -) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics (Generic) -import Swarm.Language.Syntax (Syntax) -import Swarm.Language.Text.Markdown (Document) -import Swarm.Util - --- | How hard do we expect the achievement to be? -data ExpectedEffort - = Trivial - | Easy - | Moderate - | Gruelling - deriving (Eq, Ord, Show, Bounded, Enum, Generic, FromJSON, ToJSON) - --- | A quotation to spice up the description of an achievement. -data Quotation = Quotation - { attribution :: Text - , content :: Text - } - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | Flavor text to spice up the description of an achievement, either --- freeform text or a quotation. -data FlavorText - = Freeform (Document Syntax) - | FTQuotation Quotation - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | Information about an achievement. See --- "Swarm.Game.Achievement.Description" for a mapping from --- achievements to an corresponding 'AchievementInfo' record. -data AchievementInfo = AchievementInfo - { title :: Text - -- ^ Guidelines: - -- - -- * prefer puns, pop culture references, etc. - -- * should be a phrase in Title Case. - -- * For achievements that are "obfuscated", this can be - -- a vague "clue" as to what the attainment entails. - , humorousElaboration :: Maybe FlavorText - -- ^ Explain the reference, e.g. in the form of a full quote - -- from a movie, or something you might find - -- in a fortune cookie - , attainmentProcess :: Document Syntax - -- ^ Precisely what must be done to obtain this achievement. - , effort :: ExpectedEffort - -- ^ How hard the achievement is expected to be. - , isObfuscated :: Bool - -- ^ Hides the attainment process until after the achievement is attained. - -- Best when the title + elaboration constitute a good clue. - } - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | An achievement, categorized as either global or gameplay. -data CategorizedAchievement - = GlobalAchievement GlobalAchievement - | GameplayAchievement GameplayAchievement - deriving (Eq, Ord, Show, Generic) - -categorizedAchievementJsonOptions :: Options -categorizedAchievementJsonOptions = - defaultOptions - { sumEncoding = UntaggedValue - } - -instance ToJSON CategorizedAchievement where - toJSON = genericToJSON categorizedAchievementJsonOptions - -instance FromJSON CategorizedAchievement where - parseJSON = genericParseJSON categorizedAchievementJsonOptions - --- | Achievements that entail some aggregate of actions across --- scenarios, or are independent of any particular scenario. -data GlobalAchievement - = CompletedSingleTutorial - | CompletedAllTutorials - | LookedAtAboutScreen - deriving (Eq, Ord, Show, Bounded, Enum, Generic) - -instance FromJSON GlobalAchievement -instance ToJSON GlobalAchievement - --- | Achievements obtained while playing a single scenario. -data GameplayAchievement - = CraftedBitcoin - | RobotIntoWater - | AttemptSelfDestructBase - | DestroyedBase - | LoseScenario - | GetDisoriented - | SwapSame - deriving (Eq, Ord, Show, Bounded, Enum, Generic) - -instance FromJSON GameplayAchievement -instance ToJSON GameplayAchievement - --- | List of all possible achievements. -listAchievements :: [CategorizedAchievement] -listAchievements = - map GlobalAchievement listEnums - <> map GameplayAchievement listEnums diff --git a/src/Swarm/Game/Achievement/Description.hs b/src/Swarm/Game/Achievement/Description.hs deleted file mode 100644 --- a/src/Swarm/Game/Achievement/Description.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Flavor text about all defined achievements. -module Swarm.Game.Achievement.Description where - -import Swarm.Game.Achievement.Definitions - --- | Function mapping each 'CategorizedAchievement' to an appropriate --- 'AchievementInfo' record. This function must be updated whenever --- a new type of achievement is added. -describe :: CategorizedAchievement -> AchievementInfo -describe = \case - GlobalAchievement CompletedSingleTutorial -> - AchievementInfo - "Welcome Freshmen" - (Just $ Freeform "School is in session!") - "Complete one of the tutorials." - Easy - False - GlobalAchievement CompletedAllTutorials -> - AchievementInfo - "Autodidact" - ( Just $ - FTQuotation $ - Quotation - "Terry Pratchet" - "I didn't go to university... But I have sympathy for those who did." - ) - "Complete all of the tutorials." - Moderate - False - GlobalAchievement LookedAtAboutScreen -> - AchievementInfo - "About time!" - Nothing - "View the About screen." - Trivial - True - GameplayAchievement CraftedBitcoin -> - -- Bitcoin is the deepest level of the recipes - -- hierarchy. - AchievementInfo - "Master of Your Craft" - Nothing - "Make a Bitcoin" - Moderate - True - GameplayAchievement RobotIntoWater -> - AchievementInfo - "Watery Grave" - (Just $ Freeform "This little robot thinks he's a submarine.") - "Destroy a robot by sending it into the water." - Easy - True - GameplayAchievement AttemptSelfDestructBase -> - AchievementInfo - "Call of the Void" - (Just $ Freeform "What does that big red button do?") - "Attempt to self-destruct your base." - Easy - True - GameplayAchievement DestroyedBase -> - AchievementInfo - "That Could Have Gone Better" - (Just $ Freeform "Boom.") - "Actually destroy your base." - Moderate - True - GameplayAchievement LoseScenario -> - AchievementInfo - "Silver Lining" - (Just $ Freeform "Here's your consolation prize.") - "Lose at a scenario." - Easy - True - GameplayAchievement GetDisoriented -> - AchievementInfo - "Playing Ostrich" - ( Just $ - FTQuotation $ - Quotation - "Lil Jon" - "Fire up that loud / Another round of shots / Turn down for what?" - ) - "`turn down` without a compass. Congratulations, you are \"disoriented\". How are you supposed to move now?" - Easy - True - GameplayAchievement SwapSame -> - AchievementInfo - "Fair Trade" - (Just $ Freeform "The *Law of Equivalent Exchange*... taken literally.") - "`swap` an item for itself." - Easy - True diff --git a/src/Swarm/Game/Achievement/Persistence.hs b/src/Swarm/Game/Achievement/Persistence.hs deleted file mode 100644 --- a/src/Swarm/Game/Achievement/Persistence.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Load/save logic for achievements. --- Each achievement is saved to its own file to better --- support forward-compatibility. -module Swarm.Game.Achievement.Persistence where - -import Control.Arrow (left) -import Control.Effect.Accum -import Control.Effect.Lift -import Control.Monad (forM_) -import Data.Sequence (Seq) -import Data.Yaml qualified as Y -import Swarm.Game.Achievement.Attainment -import Swarm.Game.Achievement.Definitions -import Swarm.Game.Failure -import Swarm.Game.ResourceLoading (getSwarmXdgDataSubdir) -import Swarm.Util.Effect (forMW) -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) -import System.FilePath (()) - --- | Get a path to the directory where achievement records are --- stored. If the argument is set to @True@, create the directory if --- it does not exist. -getSwarmAchievementsPath :: Bool -> IO FilePath -getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement" - --- | Load saved info about achievements from XDG data directory. --- Returns a list of attained achievements. -loadAchievementsInfo :: - (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => - m [Attainment] -loadAchievementsInfo = do - savedAchievementsPath <- sendIO $ getSwarmAchievementsPath False - doesParentExist <- sendIO $ doesDirectoryExist savedAchievementsPath - if doesParentExist - then do - contents <- sendIO $ listDirectory savedAchievementsPath - forMW contents $ \p -> do - let fullPath = savedAchievementsPath p - isFile <- sendIO $ doesFileExist fullPath - if isFile - then do - eitherDecodedFile <- sendIO (Y.decodeFileEither fullPath) - return $ left (AssetNotLoaded Achievement p . CanNotParseYaml) eitherDecodedFile - else return . Left $ AssetNotLoaded Achievement p (EntryNot File) - else do - return [] - --- | Save info about achievements to XDG data directory. -saveAchievementsInfo :: - [Attainment] -> - IO () -saveAchievementsInfo attainmentList = do - savedAchievementsPath <- getSwarmAchievementsPath True - forM_ attainmentList $ \x -> do - let achievementName = case _achievement x of - GlobalAchievement y -> show y - GameplayAchievement y -> show y - fullPath = savedAchievementsPath achievementName - Y.encodeFile fullPath x diff --git a/src/Swarm/Game/CESK.hs b/src/Swarm/Game/CESK.hs deleted file mode 100644 --- a/src/Swarm/Game/CESK.hs +++ /dev/null @@ -1,429 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- The Swarm interpreter uses a technique known as a --- (if --- you want to read up on them, you may want to start by reading about --- --- first). Execution happens simply by iterating a step function, --- sending one state of the CESK machine to the next. In addition to --- being relatively efficient, this means we can easily run a bunch of --- robots synchronously, in parallel, without resorting to any threads --- (by stepping their machines in a round-robin fashion); pause and --- single-step the game; save and resume, and so on. --- --- Essentially, a CESK machine state has four components: --- --- - The __C__ontrol is the thing we are currently focused on: --- either a 'Term' to evaluate, or a 'Value' that we have --- just finished evaluating. --- - The __E__nvironment ('Env') is a mapping from variables that might --- occur free in the Control to their values. --- - The __S__tore ('Store') is a mapping from abstract integer --- /locations/ to values. We use it to store delayed (lazy) values, --- so they will be computed at most once. --- - The __K__ontinuation ('Cont') is a stack of 'Frame's, --- representing the evaluation context, /i.e./ what we are supposed --- to do after we finish with the currently focused thing. When we --- reduce the currently focused term to a value, the top frame on --- the stack tells us how to proceed. --- --- You can think of a CESK machine as a defunctionalization of a --- recursive big-step interpreter, where we explicitly keep track of --- the call stack and the environments that would be in effect at --- various places in the recursion. One could probably even derive --- this mechanically, by writing a recursive big-step interpreter, --- then converting it to CPS, then defunctionalizing the --- continuations. --- --- The slightly confusing thing about CESK machines is how we --- have to pass around environments everywhere. Basically, --- anywhere there can be unevaluated terms containing free --- variables (in values, in continuation stack frames, ...), we --- have to store the proper environment alongside so that when --- we eventually get around to evaluating it, we will be able to --- pull out the environment to use. -module Swarm.Game.CESK ( - -- * Frames and continuations - Frame (..), - Cont, - - -- ** Wrappers for creating delayed change of state - WorldUpdate (..), - RobotUpdate (..), - - -- * Store - Store, - Addr, - emptyStore, - MemCell (..), - allocate, - lookupStore, - setStore, - - -- * CESK machine states - CESK (..), - - -- ** Construction - initMachine, - initMachine', - cancel, - resetBlackholes, - - -- ** Extracting information - finalValue, - TickNumber (..), - addTicks, -) where - -import Control.Lens ((^.)) -import Control.Lens.Combinators (pattern Empty) -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.IntMap.Strict (IntMap) -import Data.IntMap.Strict qualified as IM -import GHC.Generics (Generic) -import Prettyprinter (Doc, Pretty (..), encloseSep, hsep, (<+>)) -import Swarm.Game.Entity (Count, Entity) -import Swarm.Game.Exception -import Swarm.Game.World (WorldUpdate (..)) -import Swarm.Language.Context -import Swarm.Language.Module -import Swarm.Language.Pipeline -import Swarm.Language.Pretty -import Swarm.Language.Requirement (ReqCtx) -import Swarm.Language.Syntax -import Swarm.Language.Types -import Swarm.Language.Value as V -import Swarm.Util.WindowedCounter (Offsettable (..)) - --- | 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, FromJSON, ToJSON) - --- | 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 - ------------------------------------------------------------- --- Frames and continuations ------------------------------------------------------------- - --- | A frame is a single component of a continuation stack, explaining --- what to do next after we finish evaluating the currently focused --- term. -data Frame - = -- | We were evaluating the first component of a pair; next, we - -- should evaluate the second component which was saved in this - -- frame (and push a 'FFst' frame on the stack to save the first component). - FSnd Term Env - | -- | We were evaluating the second component of a pair; when done, - -- we should combine it with the value of the first component saved - -- in this frame to construct a fully evaluated pair. - FFst Value - | -- | @FArg t e@ says that we were evaluating the left-hand side of - -- an application, so the next thing we should do is evaluate the - -- term @t@ (the right-hand side, /i.e./ argument of the - -- application) in environment @e@. We will also push an 'FApp' - -- frame on the stack. - FArg Term Env - | -- | @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@. - FApp Value - | -- | @FLet x t2 e@ says that we were evaluating a term @t1@ in an - -- expression of the form @let x = t1 in t2@, that is, we were - -- evaluating the definition of @x@; the next thing we should do - -- is evaluate @t2@ in the environment @e@ extended with a binding - -- for @x@. - FLet Var Term Env - | -- | We are executing inside a 'Try' block. If an exception is - -- raised, we will execute the stored term (the "catch" block). - FTry Value - | -- | We were executing a command; next we should take any - -- environment it returned and union it with this one to produce - -- the result of a bind expression. - FUnionEnv Env - | -- | We were executing a command that might have definitions; next - -- we should take the resulting 'Env' and add it to the robot's - -- 'Swarm.Game.Robot.robotEnv', along with adding this accompanying 'Ctx' and - -- 'ReqCtx' to the robot's 'Swarm.Game.Robot.robotCtx'. - FLoadEnv TCtx ReqCtx - | -- | We were executing a definition; next we should take the resulting value - -- and return a context binding the variable to the value. - FDef Var - | -- | An @FExec@ frame means the focused value is a command, which - -- we should now execute. - FExec - | -- | We are in the process of executing the first component of a - -- bind; once done, we should also execute the second component - -- in the given environment (extended by binding the variable, - -- if there is one, to the output of the first command). - FBind (Maybe Var) Term Env - | -- | Discard any environment generated as the result of executing - -- a command. - FDiscardEnv - | -- | Apply specific updates to the world and current robot. - -- - -- The 'Const' is used to track the original command for error messages. - FImmediate Const [WorldUpdate Entity] [RobotUpdate] - | -- | Update the memory cell at a certain location with the computed value. - FUpdate Addr - | -- | Signal that we are done with an atomic computation. - FFinishAtomic - | -- | We are in the middle of running a computation for all the - -- nearby robots. We have the function to run, and the list of - -- robot IDs to run it on. - FMeetAll Value [Int] - | -- | We are in the middle of evaluating a record: some fields have - -- already been evaluated; we are focusing on evaluating one - -- field; and some fields have yet to be evaluated. - FRcd Env [(Var, Value)] Var [(Var, Maybe Term)] - | -- | We are in the middle of evaluating a record field projection. - FProj Var - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | A continuation is just a stack of frames. -type Cont = [Frame] - ------------------------------------------------------------- --- Store ------------------------------------------------------------- - -type Addr = Int - --- | 'Store' represents a store, /i.e./ memory, indexing integer --- locations to 'MemCell's. -data Store = Store {next :: Addr, mu :: IntMap MemCell} - deriving (Show, Eq, Generic, FromJSON, ToJSON) - --- | A memory cell can be in one of three states. -data MemCell - = -- | A cell starts out life as an unevaluated term together with - -- its environment. - E Term Env - | -- | When the cell is 'Force'd, it is set to a 'Blackhole' while - -- being evaluated. If it is ever referenced again while still - -- a 'Blackhole', that means it depends on itself in a way that - -- would trigger an infinite loop, and we can signal an error. - -- (Of course, we - -- .) - -- - -- A 'Blackhole' saves the original 'Term' and 'Env' that are - -- being evaluated; if Ctrl-C is used to cancel a computation - -- while we are in the middle of evaluating a cell, the - -- 'Blackhole' can be reset to 'E'. - Blackhole Term Env - | -- | Once evaluation is complete, we cache the final 'Value' in - -- the 'MemCell', so that subsequent lookups can just use it - -- without recomputing anything. - V Value - deriving (Show, Eq, Generic, FromJSON, ToJSON) - -emptyStore :: Store -emptyStore = Store 0 IM.empty - --- | Allocate a new memory cell containing an unevaluated expression --- with the current environment. Return the index of the allocated --- cell. -allocate :: Env -> Term -> Store -> (Addr, Store) -allocate e t (Store n m) = (n, Store (n + 1) (IM.insert n (E t e) m)) - --- | Look up the cell at a given index. -lookupStore :: Addr -> Store -> Maybe MemCell -lookupStore n = IM.lookup n . mu - --- | Set the cell at a given index. -setStore :: Addr -> MemCell -> Store -> Store -setStore n c (Store nxt m) = Store nxt (IM.insert n c m) - ------------------------------------------------------------- --- CESK machine ------------------------------------------------------------- - --- | The overall state of a CESK machine, which can actually be one of --- four kinds of states. The CESK machine is named after the first --- kind of state, and it would probably be possible to inline a --- bunch of things and get rid of the second state, but I find it --- much more natural and elegant this way. Most tutorial --- presentations of CEK/CESK machines only have one kind of state, but --- then again, most tutorial presentations only deal with the bare --- lambda calculus, so one can tell whether a term is a value just --- by seeing whether it is syntactically a lambda. I learned this --- approach from Harper's Practical Foundations of Programming --- Languages. -data CESK - = -- | When we are on our way "in/down" into a term, we have a - -- currently focused term to evaluate in the environment, a store, - -- and a continuation. In this mode we generally pattern-match on the - -- 'Term' to decide what to do next. - In Term Env Store Cont - | -- | Once we finish evaluating a term, we end up with a 'Value' - -- and we switch into "out" mode, bringing the value back up - -- out of the depths to the context that was expecting it. In - -- this mode we generally pattern-match on the 'Cont' to decide - -- what to do next. - -- - -- Note that there is no 'Env', because we don't have anything - -- with variables to evaluate at the moment, and we maintain the - -- invariant that any unevaluated terms buried inside a 'Value' - -- or 'Cont' must carry along their environment with them. - Out Value Store Cont - | -- | An exception has been raised. Keep unwinding the - -- continuation stack (until finding an enclosing 'Try' in the - -- case of a command failure or a user-generated exception, or - -- until the stack is empty in the case of a fatal exception). - Up Exn Store Cont - | -- | The machine is waiting for the game to reach a certain time - -- to resume its execution. - Waiting TickNumber CESK - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | Is the CESK machine in a final (finished) state? If so, extract --- the final value and store. -finalValue :: CESK -> Maybe (Value, Store) -{-# INLINE finalValue #-} -finalValue (Out v s []) = Just (v, s) -finalValue _ = Nothing - --- | Initialize a machine state with a starting term along with its --- type; the term will be executed or just evaluated depending on --- whether it has a command type or not. -initMachine :: ProcessedTerm -> Env -> Store -> CESK -initMachine t e s = initMachine' t e s [] - --- | Like 'initMachine', but also take an explicit starting continuation. -initMachine' :: ProcessedTerm -> Env -> Store -> Cont -> CESK -initMachine' (ProcessedTerm (Module t' ctx) _ reqCtx) e s k = - case t' ^. sType of - -- If the starting term has a command type... - Forall _ (TyCmd _) -> - case ctx of - -- ...but doesn't contain any definitions, just create a machine - -- that will evaluate it and then execute it. - Empty -> In t e s (FExec : k) - -- Or, if it does contain definitions, then load the resulting - -- context after executing it. - _ -> In t e s (FExec : FLoadEnv ctx reqCtx : k) - -- Otherwise, for a term with a non-command type, just - -- create a machine to evaluate it. - _ -> In t e s k - where - -- Erase all type and SrcLoc annotations from the term before - -- putting it in the machine state, since those are irrelevant at - -- runtime. - t = eraseS t' - --- | Cancel the currently running computation. -cancel :: CESK -> CESK -cancel cesk = Out VUnit s' [] - where - s' = resetBlackholes $ getStore cesk - getStore (In _ _ s _) = s - getStore (Out _ s _) = s - getStore (Up _ s _) = s - getStore (Waiting _ c) = getStore c - --- | Reset any 'Blackhole's in the 'Store'. We need to use this any --- time a running computation is interrupted, either by an exception --- or by a Ctrl+C. -resetBlackholes :: Store -> Store -resetBlackholes (Store n m) = Store n (IM.map resetBlackhole m) - where - resetBlackhole (Blackhole t e) = E t e - resetBlackhole c = c - ------------------------------------------------------------- --- Pretty printing CESK machine states ------------------------------------------------------------- - -instance PrettyPrec CESK where - prettyPrec _ (In c _ _ k) = prettyCont k (11, "▶" <> ppr c <> "◀") - prettyPrec _ (Out v _ k) = prettyCont k (11, "◀" <> ppr (valueToTerm v) <> "▶") - prettyPrec _ (Up e _ k) = prettyCont k (11, "!" <> (pretty (formatExn mempty e) <> "!")) - prettyPrec _ (Waiting t cesk) = "🕑" <> pretty t <> "(" <> ppr cesk <> ")" - --- | Take a continuation, and the pretty-printed expression which is --- the focus of the continuation (i.e. the expression whose value --- will be given to the continuation) along with its top-level --- precedence, and pretty-print the whole thing. --- --- As much as possible, we try to print to look like an *expression* --- with a currently focused part, that is, we print the continuation --- from the inside out instead of as a list of frames. This makes --- it much more intuitive to read. -prettyCont :: Cont -> (Int, Doc ann) -> Doc ann -prettyCont [] (_, inner) = inner -prettyCont (f : k) inner = prettyCont k (prettyFrame f inner) - --- | Pretty-print a single continuation frame, given its already --- pretty-printed focus. In particular, given a frame and its --- "inside" (i.e. the expression or other frames being focused on, --- whose value will eventually be passed to this frame), with the --- precedence of the inside's top-level construct, return a --- pretty-printed version of the entire frame along with its --- top-level precedence. -prettyFrame :: Frame -> (Int, Doc ann) -> (Int, Doc ann) -prettyFrame (FSnd t _) (_, inner) = (11, "(" <> inner <> "," <+> ppr t <> ")") -prettyFrame (FFst v) (_, inner) = (11, "(" <> ppr (valueToTerm v) <> "," <+> inner <> ")") -prettyFrame (FArg t _) (p, inner) = (10, pparens (p < 10) inner <+> prettyPrec 11 t) -prettyFrame (FApp v) (p, inner) = (10, prettyPrec 10 (valueToTerm v) <+> pparens (p < 11) inner) -prettyFrame (FLet x t _) (_, inner) = (11, hsep ["let", pretty x, "=", inner, "in", ppr t]) -prettyFrame (FTry v) (p, inner) = (10, "try" <+> pparens (p < 11) inner <+> prettyPrec 11 (valueToTerm v)) -prettyFrame (FUnionEnv _) inner = prettyPrefix "∪·" inner -prettyFrame (FLoadEnv _ _) inner = prettyPrefix "L·" inner -prettyFrame (FDef x) (_, inner) = (11, "def" <+> pretty x <+> "=" <+> inner <+> "end") -prettyFrame FExec inner = prettyPrefix "E·" inner -prettyFrame (FBind Nothing t _) (p, inner) = (0, pparens (p < 1) inner <+> ";" <+> ppr t) -prettyFrame (FBind (Just x) t _) (p, inner) = (0, hsep [pretty x, "<-", pparens (p < 1) inner, ";", ppr t]) -prettyFrame FDiscardEnv inner = prettyPrefix "D·" inner -prettyFrame (FImmediate c _worldUpds _robotUpds) inner = prettyPrefix ("I[" <> ppr c <> "]·") inner -prettyFrame (FUpdate addr) inner = prettyPrefix ("S@" <> pretty addr) inner -prettyFrame FFinishAtomic inner = prettyPrefix "A·" inner -prettyFrame (FMeetAll _ _) inner = prettyPrefix "M·" inner -prettyFrame (FRcd _ done foc rest) (_, inner) = (11, encloseSep "[" "]" ", " (pDone ++ [pFoc] ++ pRest)) - where - pDone = map (\(x, v) -> pretty x <+> "=" <+> ppr (valueToTerm v)) (reverse done) - pFoc = pretty foc <+> "=" <+> inner - pRest = map pprEq rest - pprEq (x, Nothing) = pretty x - pprEq (x, Just t) = pretty x <+> "=" <+> ppr t -prettyFrame (FProj x) (p, inner) = (11, pparens (p < 11) inner <> "." <> pretty x) - --- | Pretty-print a special "prefix application" frame, i.e. a frame --- formatted like @X· inner@. Unlike typical applications, these --- associate to the *right*, so that we can print something like @X· --- Y· Z· inner@ with no parens. -prettyPrefix :: Doc ann -> (Int, Doc ann) -> (Int, Doc ann) -prettyPrefix pre (p, inner) = (11, pre <+> pparens (p < 11) inner) - --------------------------------------------------------------- --- Runtime robot update --------------------------------------------------------------- - --- | Enumeration of robot updates. This type is used for changes by --- /e.g./ the @drill@ command which must be carried out at a later --- tick. Using a first-order representation (as opposed to /e.g./ --- just a @Robot -> Robot@ function) allows us to serialize and --- inspect the updates. --- --- Note that this can not be in 'Swarm.Game.Robot' as it would create --- a cyclic dependency. -data RobotUpdate - = -- | Add copies of an entity to the robot's inventory. - AddEntity Count Entity - | -- | Make the robot learn about an entity. - LearnEntity Entity - deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) diff --git a/src/Swarm/Game/Display.hs b/src/Swarm/Game/Display.hs deleted file mode 100644 --- a/src/Swarm/Game/Display.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- Orphan Hashable instances needed to derive Hashable Display - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Utilities for describing how to display in-game entities in the TUI. -module Swarm.Game.Display ( - -- * The display record - Priority, - Attribute (..), - Display, - - -- ** Fields - defaultChar, - orientationMap, - curOrientation, - displayAttr, - displayPriority, - invisible, - - -- ** Rendering - displayChar, - hidden, - - -- ** Construction - defaultTerrainDisplay, - defaultEntityDisplay, - defaultRobotDisplay, -) where - -import Control.Lens hiding (Const, from, (.=)) -import Data.Hashable (Hashable) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromMaybe, isJust) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Yaml -import GHC.Generics (Generic) -import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..)) -import Swarm.Util (maxOn) -import Swarm.Util.Lens (makeLensesNoSigs) -import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE) - --- | Display priority. Entities with higher priority will be drawn on --- top of entities with lower priority. -type Priority = Int - --- | An internal attribute name. -data Attribute = ADefault | ARobot | AEntity | AWorld Text | ATerrain Text - deriving (Eq, Ord, Show, Generic, Hashable) - -terrainPrefix :: Text -terrainPrefix = "terrain_" - -instance FromJSON Attribute where - parseJSON = - withText "attribute" $ - pure . \case - "robot" -> ARobot - "entity" -> AEntity - "default" -> ADefault - t | terrainPrefix `T.isPrefixOf` t -> ATerrain $ T.drop (T.length terrainPrefix) t - w -> AWorld w - -instance ToJSON Attribute where - toJSON = \case - ADefault -> String "default" - ARobot -> String "robot" - AEntity -> String "entity" - AWorld w -> String w - ATerrain t -> String $ terrainPrefix <> t - --- | A record explaining how to display an entity in the TUI. -data Display = Display - { _defaultChar :: Char - , _orientationMap :: Map AbsoluteDir Char - , _curOrientation :: Maybe Direction - , _displayAttr :: Attribute - , _displayPriority :: Priority - , _invisible :: Bool - } - deriving (Eq, Ord, Show, Generic, Hashable) - -instance Semigroup Display where - d1 <> d2 - | _invisible d1 = d2 - | _invisible d2 = d1 - | otherwise = maxOn _displayPriority d1 d2 - -makeLensesNoSigs ''Display - --- | The default character to use for display. -defaultChar :: Lens' Display Char - --- | For robots or other entities that have an orientation, this map --- optionally associates different display characters with --- different orientations. If an orientation is not in the map, --- the 'defaultChar' will be used. -orientationMap :: Lens' Display (Map AbsoluteDir Char) - --- | The display caches the current orientation of the entity, so we --- know which character to use from the orientation map. -curOrientation :: Lens' Display (Maybe Direction) - --- | The attribute to use for display. -displayAttr :: Lens' Display Attribute - --- | This entity's display priority. Higher priorities are drawn --- on top of lower. -displayPriority :: Lens' Display Priority - --- | Whether the entity is currently invisible. -invisible :: Lens' Display Bool - -instance FromJSON Display where - parseJSON v = runE (parseJSONE v) (defaultEntityDisplay ' ') - -instance FromJSONE Display Display where - parseJSONE = withObjectE "Display" $ \v -> do - defD <- getE - mc <- liftE $ v .:? "char" - let c = fromMaybe (defD ^. defaultChar) mc - let dOM = if isJust mc then mempty else defD ^. orientationMap - liftE $ - Display c - <$> v .:? "orientationMap" .!= dOM - <*> v .:? "curOrientation" .!= (defD ^. curOrientation) - <*> (v .:? "attr") .!= (defD ^. displayAttr) - <*> v .:? "priority" .!= (defD ^. displayPriority) - <*> v .:? "invisible" .!= (defD ^. invisible) - -instance ToJSON Display where - toJSON d = - object $ - [ "char" .= (d ^. defaultChar) - , "attr" .= (d ^. displayAttr) - , "priority" .= (d ^. 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) - --- | Modify a display to use a @?@ character for entities that are --- hidden/unknown. -hidden :: Display -> Display -hidden = (defaultChar .~ '?') . (curOrientation .~ Nothing) - --- | The default way to display some terrain using the given character --- and attribute, with priority 0. -defaultTerrainDisplay :: Char -> Attribute -> Display -defaultTerrainDisplay c attr = - defaultEntityDisplay c - & displayPriority .~ 0 - & displayAttr .~ attr - --- | Construct a default display for an entity that uses only a single --- display character, the default entity attribute, and priority 1. -defaultEntityDisplay :: Char -> Display -defaultEntityDisplay c = - Display - { _defaultChar = c - , _orientationMap = M.empty - , _curOrientation = Nothing - , _displayAttr = AEntity - , _displayPriority = 1 - , _invisible = False - } - --- | Construct a default robot display for a given orientation, with --- display characters @"X^>v<"@, the default robot attribute, and --- priority 10. --- --- Note that the 'defaultChar' is used for direction 'DDown' --- and is overridden for the special base robot. -defaultRobotDisplay :: Display -defaultRobotDisplay = - Display - { _defaultChar = 'X' - , _orientationMap = - M.fromList - [ (DEast, '>') - , (DWest, '<') - , (DSouth, 'v') - , (DNorth, '^') - ] - , _curOrientation = Nothing - , _displayAttr = ARobot - , _displayPriority = 10 - , _invisible = False - } - -instance Monoid Display where - mempty = defaultEntityDisplay ' ' & invisible .~ True diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs deleted file mode 100644 --- a/src/Swarm/Game/Entity.hs +++ /dev/null @@ -1,713 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- An 'Entity' represents an object that exists in the world. Each --- entity has a way to be displayed, some metadata such as a name and --- description, some properties, and possibly an inventory of other --- entities. --- --- This module also defines the 'Inventory' type, since the two types --- are mutually recursive (an inventory contains entities, which can --- have inventories). -module Swarm.Game.Entity ( - -- * Entity properties - EntityName, - EntityProperty (..), - GrowthTime (..), - defaultGrowthTime, - Combustibility (..), - defaultCombustibility, - - -- * Entities - Entity, - mkEntity, - - -- ** Fields - -- $lenses - entityDisplay, - entityName, - entityPlural, - entityNameFor, - entityDescription, - entityOrientation, - entityGrowth, - entityCombustion, - entityYields, - entityProperties, - hasProperty, - entityCapabilities, - entityInventory, - entityHash, - - -- ** Entity map - EntityMap (..), - buildEntityMap, - loadEntities, - lookupEntityName, - deviceForCap, - - -- * Inventories - Inventory, - Count, - - -- ** Construction - empty, - singleton, - fromList, - fromElems, - - -- ** Lookup - lookup, - lookupByName, - countByName, - contains, - contains0plus, - elems, - isSubsetOf, - isEmpty, - inventoryCapabilities, - extantElemsWithCapability, - entitiesByCapability, - - -- ** Modification - insert, - insertCount, - delete, - deleteCount, - deleteAll, - union, - difference, -) where - -import Control.Algebra (Has) -import Control.Arrow ((&&&)) -import Control.Carrier.Throw.Either (liftEither) -import Control.Effect.Lift (Lift, sendIO) -import Control.Effect.Throw (Throw, throwError) -import Control.Lens (Getter, Lens', lens, to, view, (^.)) -import Control.Monad ((<=<)) -import Data.Bifunctor (first) -import Data.Char (toLower) -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 (fromMaybe, isJust, listToMaybe) -import Data.Set (Set) -import Data.Set qualified as Set (fromList, member, toList, unions) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Yaml -import GHC.Generics (Generic) -import Swarm.Game.Display -import Swarm.Game.Failure -import Swarm.Game.Location -import Swarm.Game.ResourceLoading (getDataFileNameSafe) -import Swarm.Language.Capability -import Swarm.Language.Syntax (Syntax) -import Swarm.Language.Text.Markdown (Document, docToText) -import Swarm.Util (binTuples, failT, findDup, plural, (?)) -import Swarm.Util.Effect (withThrow) -import Swarm.Util.Yaml -import Text.Read (readMaybe) -import Witch -import Prelude hiding (lookup) - ------------------------------------------------------------- --- Properties ------------------------------------------------------------- - --- | A type representing entity names, currently a synonym for 'Text'. --- In the future it is conceivable that it might become more complex. -type EntityName = Text - --- | Various properties that an entity can have, which affect how --- robots can interact with it. -data EntityProperty - = -- | Robots can't move onto a cell containing this entity. - Unwalkable - | -- | Robots can pick this up (via 'Swarm.Language.Syntax.Grab' or 'Swarm.Language.Syntax.Harvest'). - Portable - | -- | Obstructs the view of robots that attempt to "scout" - Opaque - | -- | Regrows from a seed after it is harvested. - Growable - | -- | Can burn when ignited (either via 'Swarm.Language.Syntax.Ignite' or by - -- an adjacent burning entity). - Combustible - | -- | Regenerates infinitely when grabbed or harvested. - Infinite - | -- | Robots drown if they walk on this without a boat. - Liquid - | -- | Robots automatically know what this is without having to scan it. - Known - deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable) - -instance ToJSON EntityProperty where - toJSON = String . from . map toLower . show - -instance FromJSON EntityProperty where - parseJSON = withText "EntityProperty" tryRead - where - tryRead :: Text -> Parser EntityProperty - tryRead t = case readMaybe . from . T.toTitle $ t of - Just c -> return c - Nothing -> failT ["Unknown entity property", t] - --- | How long an entity takes to regrow. This represents the minimum --- and maximum amount of time taken by one growth stage (there are --- two stages). The actual time for each stage will be chosen --- uniformly at random between these two values. -newtype GrowthTime = GrowthTime (Integer, Integer) - deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON) - --- | The default growth time (100, 200) for a growable entity with no --- growth time specification. -defaultGrowthTime :: GrowthTime -defaultGrowthTime = GrowthTime (100, 200) - --- | Properties of combustion. -data Combustibility = Combustibility - { ignition :: Double - -- ^ Rate of ignition by a neighbor, per tick. - -- If this rate is denoted \(\lambda\), the probability of - -- ignition over a period of \(t\) ticks is \(1 - e^{-\lambda t}\). - -- See . - , duration :: (Integer, Integer) - -- ^ min and max tick counts for combustion to persist - , product :: Maybe EntityName - -- ^ what entity, if any, is left over after combustion - } - deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON) - --- | The default combustion specification for a combustible entity --- with no combustion specification: --- --- * ignition rate 0.5 --- * duration (100, 200) --- * product @ash@ -defaultCombustibility :: Combustibility -defaultCombustibility = Combustibility 0.5 (100, 200) (Just "ash") - ------------------------------------------------------------- --- Entity ------------------------------------------------------------- - --- | A record to hold information about an entity. --- --- The constructor for 'Entity' is intentionally not exported. To --- construct one manually, use the 'mkEntity' function. --- --- There are two main constraints on the way entities are stored: --- --- 1. We want to be able to easily modify an entity in one --- particular cell of the world (for example, painting one --- tree red). --- 2. In an inventory, we want to store identical entities only --- once, along with a count. --- --- We could get (2) nicely by storing only names of entities, and --- having a global lookup table from names to entity records. --- However, storing names instead of actual entity records in the --- world makes (1) more complex: every time we modify an entity we --- would have to generate a fresh name for the modified entity and --- add it to the global entity table. This approach is also --- annoying because it means we can't just uses lenses to drill down --- into the properties of an entity in the world or in an inventory, --- but have to do an intermediate lookup in the global (mutable!) --- entity table. --- --- On the other hand, if we just store entity records everywhere, --- checking them for equality becomes expensive. Having an --- inventory be a map with entities themselves as keys sounds awful. --- --- The solution we adopt here is that every @Entity@ record carries --- along a hash value of all the other fields. We just assume that --- these hashes are unique (a collision is of course possible but --- extremely unlikely). Entities can be efficiently compared just --- by looking at their hashes; they can be stored in a map using --- hash values as keys; and we provide lenses which automatically --- recompute the hash value when modifying a field of an entity --- record. Note also that world storage is still efficient, too: --- thanks to referential transparency, in practice most of the --- entities stored in the world that are the same will literally --- just be stored as pointers to the same shared record. -data Entity = Entity - { _entityHash :: Int - -- ^ A hash value computed from the other fields - , _entityDisplay :: Display - -- ^ The way this entity should be displayed on the world map. - , _entityName :: EntityName - -- ^ The name of the entity, used /e.g./ in an inventory display. - , _entityPlural :: Maybe Text - -- ^ The plural of the entity name, in case it is irregular. If - -- this field is @Nothing@, default pluralization heuristics - -- will be used (see 'plural'). - , _entityDescription :: Document Syntax - -- ^ A longer-form description. Each 'Text' value is one - -- paragraph. - , _entityOrientation :: Maybe Heading - -- ^ The entity's orientation (if it has one). For example, when - -- a robot moves, it moves in the direction of its orientation. - , _entityGrowth :: Maybe GrowthTime - -- ^ If this entity grows, how long does it take? - , _entityCombustion :: Maybe Combustibility - -- ^ If this entity is combustible, how spreadable is it? - , _entityYields :: Maybe Text - -- ^ The name of a different entity obtained when this entity is - -- grabbed. - , _entityProperties :: Set EntityProperty - -- ^ Properties of the entity. - , _entityCapabilities :: Set Capability - -- ^ Capabilities provided by this entity. - , _entityInventory :: Inventory - -- ^ Inventory of other entities held by this entity. - } - -- Note that an entity does not have a location, because the - -- location of an entity is implicit in the way it is stored (by - -- location). - - deriving (Show, Generic) - --- | The @Hashable@ instance for @Entity@ ignores the cached hash --- value and simply combines the other fields. -instance Hashable Entity where - hashWithSalt s (Entity _ disp nm pl descr orient grow combust yld props caps inv) = - s - `hashWithSalt` disp - `hashWithSalt` nm - `hashWithSalt` pl - `hashWithSalt` docToText descr - `hashWithSalt` orient - `hashWithSalt` grow - `hashWithSalt` combust - `hashWithSalt` yld - `hashWithSalt` props - `hashWithSalt` caps - `hashWithSalt` inv - --- | Entities are compared by hash for efficiency. -instance Eq Entity where - (==) = (==) `on` _entityHash - --- | Entities are compared by hash for efficiency. -instance Ord Entity where - compare = compare `on` _entityHash - --- | Recompute an entity's hash value. -rehashEntity :: Entity -> Entity -rehashEntity e = e {_entityHash = hash e} - --- | Create an entity with no orientation, an empty inventory, --- providing no capabilities (automatically filling in the hash --- value). -mkEntity :: - -- | Display - Display -> - -- | Entity name - Text -> - -- | Entity description - Document Syntax -> - -- | Properties - [EntityProperty] -> - -- | Capabilities - [Capability] -> - Entity -mkEntity disp nm descr props caps = - rehashEntity $ - Entity - 0 - disp - nm - Nothing - descr - Nothing - Nothing - Nothing - Nothing - (Set.fromList props) - (Set.fromList caps) - empty - ------------------------------------------------------------- --- Entity map ------------------------------------------------------------- - --- | An 'EntityMap' is a data structure containing all the loaded --- entities, allowing them to be looked up either by name or by what --- capabilities they provide (if any). -data EntityMap = EntityMap - { entitiesByName :: Map Text Entity - , entitiesByCap :: Map Capability [Entity] - } - deriving (Eq, Show, Generic, FromJSON, ToJSON) - -instance Semigroup EntityMap where - EntityMap n1 c1 <> EntityMap n2 c2 = EntityMap (n1 <> n2) (M.unionWith (<>) c1 c2) - -instance Monoid EntityMap where - mempty = EntityMap M.empty M.empty - mappend = (<>) - --- | Find an entity with the given name. -lookupEntityName :: Text -> EntityMap -> Maybe Entity -lookupEntityName nm = M.lookup nm . entitiesByName - --- | Find all entities which are devices that provide the given --- capability. -deviceForCap :: Capability -> EntityMap -> [Entity] -deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap - --- | Build an 'EntityMap' from a list of entities. The idea is that --- this will be called once at startup, when loading the entities --- 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 - return $ - EntityMap - { entitiesByName = M.fromList namedEntities - , entitiesByCap = M.fromListWith (<>) . concatMap (\e -> map (,[e]) (Set.toList $ e ^. entityCapabilities)) $ es - } - where - namedEntities = map (view entityName &&& id) es - ------------------------------------------------------------- --- Serialization ------------------------------------------------------------- - -instance FromJSON Entity where - parseJSON = withObject "Entity" $ \v -> - rehashEntity - <$> ( Entity 0 - <$> v .: "display" - <*> v .: "name" - <*> v .:? "plural" - <*> (v .: "description") - <*> v .:? "orientation" - <*> v .:? "growth" - <*> v .:? "combustion" - <*> v .:? "yields" - <*> v .:? "properties" .!= mempty - <*> v .:? "capabilities" .!= mempty - <*> pure empty - ) - --- | If we have access to an 'EntityMap', we can parse the name of an --- 'Entity' as a string and look it up in the map. -instance FromJSONE EntityMap Entity where - parseJSONE = withTextE "entity name" $ \name -> - E $ \em -> case lookupEntityName name em of - Nothing -> failT ["Unknown entity:", name] - Just e -> return e - -instance ToJSON Entity where - toJSON e = - object $ - [ "display" .= (e ^. entityDisplay) - , "name" .= (e ^. entityName) - , "description" .= (e ^. entityDescription) - ] - ++ ["plural" .= (e ^. entityPlural) | isJust (e ^. entityPlural)] - ++ ["orientation" .= (e ^. entityOrientation) | isJust (e ^. entityOrientation)] - ++ ["growth" .= (e ^. entityGrowth) | isJust (e ^. entityGrowth)] - ++ ["yields" .= (e ^. entityYields) | isJust (e ^. entityYields)] - ++ ["properties" .= (e ^. entityProperties) | not . null $ e ^. entityProperties] - ++ ["capabilities" .= (e ^. entityCapabilities) | not . null $ e ^. entityCapabilities] - --- | Load entities from a data file called @entities.yaml@, producing --- either an 'EntityMap' or a parse error. -loadEntities :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - m EntityMap -loadEntities = do - let entityFile = "entities.yaml" - entityFailure = AssetNotLoaded (Data Entities) entityFile - fileName <- getDataFileNameSafe Entities entityFile - decoded <- - withThrow (entityFailure . CanNotParseYaml) . (liftEither <=< sendIO) $ - decodeFileEither fileName - withThrow entityFailure $ buildEntityMap decoded - ------------------------------------------------------------- --- Entity lenses ------------------------------------------------------------- - --- $lenses --- Our own custom lenses which properly recompute the cached hash --- value each time something gets updated. See --- https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ --- for the approach used here. - --- | Make a lens for Entity that recomputes the hash after setting. -hashedLens :: (Entity -> a) -> (Entity -> a -> Entity) -> Lens' Entity a -hashedLens get set = lens get (\e a -> rehashEntity $ set e a) - --- | Get the hash of an entity. Note that this is a getter, not a --- lens; the "Swarm.Game.Entity" module carefully maintains some --- internal invariants ensuring that hashes work properly, and by --- golly, no one else is going to mess that up. -entityHash :: Getter Entity Int -entityHash = to _entityHash - --- | The 'Display' explaining how to draw this entity in the world display. -entityDisplay :: Lens' Entity Display -entityDisplay = hashedLens _entityDisplay (\e x -> e {_entityDisplay = x}) - --- | The name of the entity. -entityName :: Lens' Entity EntityName -entityName = hashedLens _entityName (\e x -> e {_entityName = x}) - --- | The irregular plural version of the entity's name, if there is --- one. -entityPlural :: Lens' Entity (Maybe Text) -entityPlural = hashedLens _entityPlural (\e x -> e {_entityPlural = x}) - --- | Get a version of the entity's name appropriate to the --- number---the singular name for 1, and a plural name for any other --- number. The plural name is obtained either by looking it up if --- irregular, or by applying standard heuristics otherwise. -entityNameFor :: Int -> Getter Entity Text -entityNameFor 1 = entityName -entityNameFor _ = to $ \e -> - case e ^. entityPlural of - Just pl -> pl - Nothing -> plural (e ^. entityName) - --- | A longer, free-form description of the entity. Each 'Text' value --- represents a paragraph. -entityDescription :: Lens' Entity (Document Syntax) -entityDescription = hashedLens _entityDescription (\e x -> e {_entityDescription = x}) - --- | The direction this entity is facing (if it has one). -entityOrientation :: Lens' Entity (Maybe Heading) -entityOrientation = hashedLens _entityOrientation (\e x -> e {_entityOrientation = x}) - --- | How long this entity takes to grow, if it regrows. -entityGrowth :: Lens' Entity (Maybe GrowthTime) -entityGrowth = hashedLens _entityGrowth (\e x -> e {_entityGrowth = x}) - --- | Susceptibility to and duration of combustion -entityCombustion :: Lens' Entity (Maybe Combustibility) -entityCombustion = hashedLens _entityCombustion (\e x -> e {_entityCombustion = x}) - --- | The name of a different entity yielded when this entity is --- grabbed, if any. -entityYields :: Lens' Entity (Maybe Text) -entityYields = hashedLens _entityYields (\e x -> e {_entityYields = x}) - --- | The properties enjoyed by this entity. -entityProperties :: Lens' Entity (Set EntityProperty) -entityProperties = hashedLens _entityProperties (\e x -> e {_entityProperties = x}) - --- | Test whether an entity has a certain property. -hasProperty :: Entity -> EntityProperty -> Bool -hasProperty e p = p `elem` (e ^. entityProperties) - --- | The capabilities this entity provides when equipped. -entityCapabilities :: Lens' Entity (Set Capability) -entityCapabilities = hashedLens _entityCapabilities (\e x -> e {_entityCapabilities = x}) - --- | The inventory of other entities carried by this entity. -entityInventory :: Lens' Entity Inventory -entityInventory = hashedLens _entityInventory (\e x -> e {_entityInventory = x}) - ------------------------------------------------------------- --- Inventory ------------------------------------------------------------- - --- | A convenient synonym to remind us when an 'Int' is supposed to --- represent /how many/ of something we have. -type Count = Int - --- | An inventory is really just a bag/multiset of entities. That is, --- it contains some entities, along with the number of times each --- occurs. Entities can be looked up directly, or by name. -data Inventory = Inventory - { -- Main map - counts :: IntMap (Count, Entity) - , -- Mirrors the main map; just caching the ability to look up by - -- name. - byName :: Map Text IntSet - , -- Cached hash of the inventory, using a homomorphic hashing scheme - -- (see https://github.com/swarm-game/swarm/issues/229). - -- - -- Invariant: equal to Sum_{(k,e) \in counts} (k+1) * (e ^. entityHash). - -- The k+1 is so the hash distinguishes between having a 0 count of something - -- and not having it as a key in the map at all. - inventoryHash :: Int - } - deriving (Show, Generic, FromJSON, ToJSON) - -instance Hashable Inventory where - -- Just return cached hash value. - hash = inventoryHash - hashWithSalt s = hashWithSalt s . inventoryHash - --- | Inventories are compared by hash for efficiency. -instance Eq Inventory where - (==) = (==) `on` hash - --- | Look up an entity in an inventory, returning the number of copies --- contained. -lookup :: Entity -> Inventory -> Count -lookup e (Inventory cs _ _) = maybe 0 fst $ IM.lookup (e ^. entityHash) cs - --- | Look up an entity by name in an inventory, returning a list of --- matching entities. Note, if this returns some entities, it does --- /not/ mean we necessarily have any in our inventory! It just --- means we /know about/ them. If you want to know whether you have --- any, use 'lookup' and see whether the resulting 'Count' is --- 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) - --- | 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 --- just picks the first one returned from 'lookupByName'. -countByName :: Text -> Inventory -> Count -countByName name inv = - maybe 0 (`lookup` inv) (listToMaybe (lookupByName name inv)) - --- | The empty inventory. -empty :: Inventory -empty = Inventory IM.empty M.empty 0 - --- | Create an inventory containing one entity. -singleton :: Entity -> Inventory -singleton = flip insert empty - --- | Insert an entity into an inventory. If the inventory already --- contains this entity, then only its count will be incremented. -insert :: Entity -> Inventory -> Inventory -insert = insertCount 1 - --- | Create an inventory from a list of entities. -fromList :: [Entity] -> Inventory -fromList = foldl' (flip insert) empty - --- | Create an inventory from a list of entities and their counts. -fromElems :: [(Count, Entity)] -> Inventory -fromElems = foldl' (flip (uncurry insertCount)) empty - --- | Insert a certain number of copies of an entity into an inventory. --- If the inventory already contains this entity, then only its --- count will be incremented. -insertCount :: Count -> Entity -> Inventory -> Inventory -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) - (h + (k + extra) * (e ^. entityHash)) -- homomorphic hashing - where - -- Include the hash of an entity once just for "knowing about" it; - -- then include the hash once per actual copy of the entity. In - -- other words, having k copies of e in the inventory contributes - -- (k+1)*(e ^. entityHash) to the inventory hash. The reason for - -- doing this is so that the inventory hash changes even when we - -- insert 0 copies of something, since having 0 copies of something - -- is different than not having it as a key at all; having 0 copies - -- signals that we at least "know about" the entity. - extra = if (e ^. entityHash) `IM.member` cs then 0 else 1 - --- | Check whether an inventory contains at least one of a given entity. -contains :: Inventory -> Entity -> Bool -contains inv e = lookup e inv > 0 - --- | Check whether an inventory has an entry for the given entity, --- even if there are 0 copies. In particular this is used to --- indicate whether a robot "knows about" an entity. -contains0plus :: Entity -> Inventory -> Bool -contains0plus e = isJust . IM.lookup (e ^. entityHash) . counts - --- | Check if the first inventory is a subset of the second. --- Note that entities with a count of 0 are ignored. -isSubsetOf :: Inventory -> Inventory -> Bool -isSubsetOf inv1 inv2 = all (\(n, e) -> lookup e inv2 >= n) (elems inv1) - --- | Check whether an inventory is empty, meaning that it contains 0 --- total entities (although it may still /know about/ some entities, that --- is, have them as keys with a count of 0). -isEmpty :: Inventory -> Bool -isEmpty = all ((== 0) . fst) . elems - --- | Compute the set of capabilities provided by the devices in an inventory. -inventoryCapabilities :: Inventory -> Set Capability -inventoryCapabilities = Set.unions . map (^. entityCapabilities) . nonzeroEntities - --- | List elements that have at least one copy in the inventory. -nonzeroEntities :: Inventory -> [Entity] -nonzeroEntities = map snd . filter ((> 0) . fst) . elems - --- | List elements that possess a given Capability and --- exist with nonzero count in the inventory. -extantElemsWithCapability :: Capability -> Inventory -> [Entity] -extantElemsWithCapability cap = - filter (Set.member cap . (^. entityCapabilities)) . nonzeroEntities - --- | Groups entities by the capabilities they offer. -entitiesByCapability :: Inventory -> Map Capability (NE.NonEmpty Entity) -entitiesByCapability inv = - binTuples entityCapabilityPairs - where - getCaps = Set.toList . (^. entityCapabilities) - entityCapabilityPairs = concatMap ((\e -> map (,e) $ getCaps e) . snd) $ elems inv - --- | Delete a single copy of a certain entity from an inventory. -delete :: Entity -> Inventory -> Inventory -delete = deleteCount 1 - --- | Delete a specified number of copies of an entity from an inventory. -deleteCount :: Count -> Entity -> Inventory -> Inventory -deleteCount k e (Inventory cs byN h) = Inventory cs' byN h' - where - m = (fst <$> IM.lookup (e ^. entityHash) cs) ? 0 - cs' = IM.adjust removeCount (e ^. entityHash) cs - h' = h - min k m * (e ^. entityHash) - - removeCount :: (Count, a) -> (Count, a) - removeCount (n, a) = (max 0 (n - k), a) - --- | Delete all copies of a certain entity from an inventory. -deleteAll :: Entity -> Inventory -> Inventory -deleteAll e (Inventory cs byN h) = - Inventory - (IM.adjust (first (const 0)) (e ^. entityHash) cs) - byN - (h - n * (e ^. entityHash)) - where - n = (fst <$> IM.lookup (e ^. entityHash) cs) ? 0 - --- | Get the entities in an inventory and their associated counts. -elems :: Inventory -> [(Count, Entity)] -elems (Inventory cs _ _) = IM.elems cs - --- | Union two inventories. -union :: Inventory -> Inventory -> Inventory -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) - (h1 + h2 - common) - where - -- Need to subtract off the sum of the hashes in common, because - -- of the way each entity with count k contributes (k+1) times its - -- hash. So if the two inventories share an entity e, just adding their - -- hashes would mean e now contributes (k+2) times its hash. - common = IS.foldl' (+) 0 $ IM.keysSet cs1 `IS.intersection` IM.keysSet cs2 - --- | Subtract the second inventory from the first. -difference :: Inventory -> Inventory -> Inventory -difference inv1 = foldl' (flip (uncurry deleteCount)) inv1 . elems diff --git a/src/Swarm/Game/Exception.hs b/src/Swarm/Game/Exception.hs deleted file mode 100644 --- a/src/Swarm/Game/Exception.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Runtime exceptions for the Swarm language interpreter. -module Swarm.Game.Exception ( - Exn (..), - IncapableFix (..), - formatExn, - - -- * Helper functions - formatIncapable, - formatIncapableFix, -) where - -import Control.Lens ((^.)) -import Data.Aeson (FromJSON, ToJSON) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Map qualified as M -import Data.Set qualified as S -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics (Generic) -import Swarm.Constant -import Swarm.Game.Achievement.Definitions -import Swarm.Game.Entity (EntityMap, deviceForCap, entityName) -import Swarm.Language.Capability (Capability (CGod), capabilityName) -import Swarm.Language.Pretty (prettyText) -import Swarm.Language.Requirement (Requirements (..)) -import Swarm.Language.Syntax (Const, Term) -import Swarm.Util -import Witch (from) - --- ------------------------------------------------------------------ --- SETUP FOR DOCTEST - --- $setup --- >>> :set -XOverloadedStrings --- >>> import Control.Lens --- >>> import Data.Text (unpack) --- >>> import Swarm.Language.Syntax --- >>> import Swarm.Language.Capability --- >>> import Swarm.Game.Entity --- >>> import Swarm.Game.Display --- >>> import qualified Swarm.Language.Requirement as R - --- ------------------------------------------------------------------ - --- | Suggested way to fix things when a robot does not meet the --- requirements to run a command. -data IncapableFix - = -- | 'Swarm.Language.Syntax.Equip' the missing device on yourself/target - FixByEquip - | -- | Add the missing device to your inventory - FixByObtain - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | The type of exceptions that can be thrown by robot programs. -data Exn - = -- | Something went very wrong. This is a bug in Swarm and cannot - -- be caught by a @try@ block (but at least it will not crash - -- the entire UI). - Fatal Text - | -- | An infinite loop was detected via a blackhole. This cannot - -- be caught by a @try@ block. - InfiniteLoop - | -- | A robot tried to do something for which it does not have some - -- of the required capabilities. This cannot be caught by a - -- @try@ block. Also contains the missing requirements, the - -- term that caused the problem, and a suggestion for how to fix - -- things. - Incapable IncapableFix Requirements Term - | -- | A command failed in some "normal" way (/e.g./ a 'Swarm.Language.Syntax.Move' - -- command could not move, or a 'Swarm.Language.Syntax.Grab' command found nothing to - -- grab, /etc./). Can be caught by a @try@ block. - CmdFailed Const Text (Maybe GameplayAchievement) - | -- | The user program explicitly called 'Swarm.Language.Syntax.Undefined' or 'Swarm.Language.Syntax.Fail'. Can - -- be caught by a @try@ block. - User Text - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | Pretty-print an exception for displaying to the player. -formatExn :: EntityMap -> Exn -> Text -formatExn em = \case - Fatal t -> - T.unlines - [ "Fatal error: " <> t - , "Please report this as a bug at" - , "<" <> swarmRepoUrl <> "issues/new>." - ] - InfiniteLoop -> "Infinite loop detected!" - (CmdFailed c t _) -> T.concat [prettyText c, ": ", t] - (User t) -> "Player exception: " <> t - (Incapable f caps tm) -> formatIncapable em f caps tm - --- ------------------------------------------------------------------ --- INCAPABLE HELPERS --- ------------------------------------------------------------------ - --- | Pretty-print an 'IncapableFix': either "equip" or "obtain". -formatIncapableFix :: IncapableFix -> Text -formatIncapableFix = \case - FixByEquip -> "equip" - FixByObtain -> "obtain" - --- | Pretty print the incapable exception with an actionable suggestion --- on how to fix it. --- --- >>> import Data.Either (fromRight) --- >>> import Control.Carrier.Throw.Either (runThrow) --- >>> import Control.Algebra (run) --- >>> import Swarm.Game.Failure (LoadingFailure) --- >>> :set -XTypeApplications --- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty [CAppear] --- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" mempty mempty [CAppear] --- >>> m = fromRight mempty . run . runThrow @LoadingFailure $ buildEntityMap [w,r] --- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByEquip cs t --- --- >>> incapableError (R.singletonCap CGod) (TConst As) --- Thou shalt not utter such blasphemy: --- '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 devices required for: --- 'appear' --- Please equip: --- - the one ring or magic wand --- --- >>> incapableError (R.singletonCap CRandom) (TConst Random) --- Missing the random capability for: --- 'random' --- but no device yet provides it. See --- https://github.com/swarm-game/swarm/issues/26 --- --- >>> incapableError (R.singletonInv 3 "tree") (TConst Noop) --- You are missing required inventory for: --- 'noop' --- Please obtain: --- - tree (3) -formatIncapable :: EntityMap -> IncapableFix -> Requirements -> Term -> Text -formatIncapable em f (Requirements caps _ inv) tm - | CGod `S.member` caps = - unlinesExText $ - "Thou shalt not utter such blasphemy:" - :| [ squote $ prettyText tm - , "If God in troth thou wantest to play, try thou a Creative game." - ] - | not (null capsNone) = - unlinesExText $ - "Missing the " <> capMsg <> " for:" - :| [ squote $ prettyText tm - , "but no device yet provides it. See" - , swarmRepoUrl <> "issues/26" - ] - | not (S.null caps) = - unlinesExText - ( "You do not have the devices required for:" - :| squote (prettyText tm) - : "Please " <> formatIncapableFix f <> ":" - : (("- " <>) . formatDevices <$> filter (not . null) deviceSets) - ) - | otherwise = - unlinesExText - ( "You are missing required inventory for:" - :| squote (prettyText tm) - : "Please obtain:" - : (("- " <>) . formatEntity <$> M.assocs inv) - ) - where - capList = S.toList caps - deviceSets = map (`deviceForCap` em) capList - devicePerCap = zip capList deviceSets - -- capabilities not provided by any device - capsNone = map (capabilityName . fst) $ filter (null . snd) devicePerCap - capMsg = case capsNone of - [ca] -> ca <> " capability" - cas -> "capabilities " <> T.intercalate ", " cas - formatDevices = T.intercalate " or " . map (^. entityName) - formatEntity (e, 1) = e - formatEntity (e, n) = e <> " (" <> from (show n) <> ")" - --- | Exceptions that span multiple lines should be indented. -unlinesExText :: NonEmpty Text -> Text -unlinesExText (t :| ts) = T.unlines $ (t :) $ map (" " <>) ts diff --git a/src/Swarm/Game/Failure.hs b/src/Swarm/Game/Failure.hs deleted file mode 100644 --- a/src/Swarm/Game/Failure.hs +++ /dev/null @@ -1,141 +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 (..), - AssetData (..), - Asset (..), - Entry (..), - LoadingFailure (..), - OrderFileWarning (..), -) where - -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 | Recipes | Worlds | Scenarios | Script - deriving (Eq, Show) - --- | Overarching enumeration of various assets we can attempt to load. -data Asset = Achievement | Data AssetData | History | 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) - ------------------------------------------------------------- --- 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/Game/Location.hs b/src/Swarm/Game/Location.hs deleted file mode 100644 --- a/src/Swarm/Game/Location.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- Orphan JSON instances for Location and Heading - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Locations and headings. -module Swarm.Game.Location ( - Location, - pattern Location, - - -- ** Heading and Direction functions - Heading, - applyTurn, - relativeTo, - toDirection, - toAbsDirection, - nearestDirection, - fromDirection, - isCardinal, - north, - south, - east, - west, - - -- ** Utility functions - manhattan, - euclidean, - getElemsInArea, - - -- ** Re-exports for convenience - Affine (..), - Point (..), - origin, -) where - -import Control.Arrow ((&&&)) -import Data.Aeson (FromJSONKey, ToJSONKey) -import Data.Function (on, (&)) -import Data.Int (Int32) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Yaml (FromJSON (parseJSON), ToJSON (toJSON)) -import Linear (Additive (..), V2 (..), negated, norm, perp, unangle) -import Linear.Affine (Affine (..), Point (..), origin) -import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..), PlanarRelativeDir (..), RelativeDir (..), isCardinal) -import Swarm.Util qualified as Util - --- $setup --- >>> import qualified Data.Map as Map --- >>> import Linear --- >>> import Swarm.Language.Direction - --- | A t'Location' is a pair of @(x,y)@ coordinates, both up to 32 bits. --- The positive x-axis points east and the positive y-axis points --- north. These are the coordinates that are shown to players. --- --- See also the 'Swarm.Game.World.Coords' type defined in "Swarm.Game.World", which --- use a (row, column) format instead, which is more convenient for --- internal use. The "Swarm.Game.World" module also defines --- conversions between t'Location' and 'Swarm.Game.World.Coords'. -type Location = Point V2 Int32 - --- | A convenient way to pattern-match on t'Location' values. -pattern Location :: Int32 -> Int32 -> Location -pattern Location x y = P (V2 x y) - -{-# COMPLETE Location #-} - -instance FromJSON Location where - parseJSON = fmap P . parseJSON - -instance ToJSON Location where - toJSON (P v) = toJSON v - --- | A @Heading@ is a 2D vector, with 32-bit coordinates. --- --- t'Location' and 'Heading' are both represented using types from --- the @linear@ package, so they can be manipulated using a large --- number of operators from that package. For example: --- --- * Two headings can be added with '^+^'. --- * The difference between two t'Location's is a 'Heading' (via '.-.'). --- * A t'Location' plus a 'Heading' is another t'Location' (via 'Linear.Affine..^+'). -type Heading = V2 Int32 - -deriving instance ToJSON (V2 Int32) -deriving instance FromJSON (V2 Int32) - -deriving instance FromJSONKey (V2 Int32) -deriving instance ToJSONKey (V2 Int32) - -toHeading :: AbsoluteDir -> Heading -toHeading = \case - DNorth -> north - DSouth -> south - DEast -> east - DWest -> west - --- | The cardinal direction north = @V2 0 1@. -north :: Heading -north = V2 0 1 - --- | The cardinal direction south = @V2 0 (-1)@. -south :: Heading -south = V2 0 (-1) - --- | The cardinal direction east = @V2 1 0@. -east :: Heading -east = V2 1 0 - --- | The cardinal direction west = @V2 (-1) 0@. -west :: Heading -west = V2 (-1) 0 - --- | The direction for viewing the current cell = @V2 0 0@. -down :: Heading -down = zero - --- | The 'applyTurn' function gives the meaning of each 'Direction' by --- turning relative to the given heading or by turning to an absolute --- heading. --- --- >>> applyTurn (DRelative (DPlanar DLeft)) (V2 5 3) --- V2 (-3) 5 --- >>> applyTurn (DAbsolute DWest) (V2 5 3) --- V2 (-1) 0 -applyTurn :: Direction -> Heading -> Heading -applyTurn d = case d of - DRelative e -> case e of - DPlanar DLeft -> perp - DPlanar DRight -> negated . perp - DPlanar DBack -> negated - DPlanar DForward -> id - DDown -> const down - DAbsolute e -> const $ toHeading e - --- | Mapping from heading to their corresponding cardinal directions. --- Only absolute directions are mapped. -cardinalDirs :: M.Map Heading AbsoluteDir -cardinalDirs = - M.fromList $ map (toHeading &&& id) Util.listEnums - --- | Possibly convert a heading into a 'Direction'---that is, if the --- vector happens to be a unit vector in one of the cardinal --- directions. --- --- >>> toDirection (V2 0 (-1)) --- Just (DAbsolute DSouth) --- >>> toDirection (V2 3 7) --- Nothing -toDirection :: Heading -> Maybe Direction -toDirection = fmap DAbsolute . toAbsDirection - --- | Like 'toDirection', but preserve the type guarantee of an absolute direction -toAbsDirection :: Heading -> Maybe AbsoluteDir -toAbsDirection v = M.lookup v cardinalDirs - --- | Return the 'PlanarRelativeDir' which would result in turning to --- the first (target) direction from the second (reference) direction. --- --- >>> DWest `relativeTo` DSouth --- DRight --- >>> DWest `relativeTo` DWest --- DForward -relativeTo :: AbsoluteDir -> AbsoluteDir -> PlanarRelativeDir -relativeTo targetDir referenceDir = - toEnum indexDiff - where - enumCount = length (Util.listEnums :: [AbsoluteDir]) - indexDiff = ((-) `on` fromEnum) targetDir referenceDir `mod` enumCount - --- | Compute the absolute direction nearest to a given 'Heading'. --- --- Logic adapted from . -nearestDirection :: Heading -> AbsoluteDir -nearestDirection coord = - Util.indexWrapNonEmpty orderedDirs index - where - angle :: Double - angle = unangle (fmap fromIntegral coord) / (2 * pi) - - index :: Int - index = round $ fromIntegral (length orderedDirs) * angle - orderedDirs = Util.listEnumsNonempty - --- | 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) - --- | Euclidean distance between world locations. -euclidean :: Location -> Location -> Double -euclidean p1 p2 = norm (fromIntegral <$> (p2 .-. p1)) - --- | Get elements that are within a certain manhattan distance from location. --- --- >>> v2s i = [(p, manhattan origin p) | x <- [-i..i], y <- [-i..i], let p = Location x y] --- >>> v2s 0 --- [(P (V2 0 0),0)] --- >>> map (\i -> length (getElemsInArea origin i (Map.fromList $ v2s i))) [0..8] --- [1,5,13,25,41,61,85,113,145] --- --- The last test is the sequence "Centered square numbers": --- https://oeis.org/A001844 -getElemsInArea :: Location -> Int32 -> Map Location e -> [e] -getElemsInArea o@(Location x y) d m = M.elems sm' - where - -- to be more efficient we basically split on first coordinate - -- (which is logarithmic) and then we have to linearly filter - -- the second coordinate to get a square - this is how it looks: - -- ▲▲▲▲ - -- ││││ the arrows mark points that are greater then A - -- ││s│ and lesser then B - -- │sssB (2,1) - -- ssoss <-- o=(x=0,y=0) with d=2 - -- (-2,-1) Asss│ - -- │s││ the point o and all s are in manhattan - -- ││││ distance 2 from point o - -- ▼▼▼▼ - sm = - m - & M.split (Location (x - d) (y - 1)) -- A - & snd -- A< - & M.split (Location (x + d) (y + 1)) -- B - & fst -- B> - sm' = M.filterWithKey (const . (<= d) . manhattan o) sm diff --git a/src/Swarm/Game/Recipe.hs b/src/Swarm/Game/Recipe.hs deleted file mode 100644 --- a/src/Swarm/Game/Recipe.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A recipe represents some kind of process for transforming --- some input entities into some output entities. --- --- Recipes support a number of different game mechanics, including: --- --- * crafting --- * mining --- * randomized "loot boxes" --- * unlocking doors --- --- == Synchronous vs Async --- Recipes can be completed either within the same tick --- as execution is started, or execution may span --- multiple ticks. It is possible for the execution --- of multi-tick recipes to be interrupted in one way or --- another, in which case the recipe fails without producing --- the "outputs". -module Swarm.Game.Recipe ( - -- * Ingredient lists and recipes - IngredientList, - Recipe (..), - - -- ** Fields - recipeInputs, - recipeOutputs, - recipeCatalysts, - recipeTime, - recipeWeight, - - -- * Loading recipes - loadRecipes, - outRecipeMap, - inRecipeMap, - catRecipeMap, - - -- * Looking up recipes - MissingIngredient (..), - MissingType (..), - knowsIngredientsFor, - recipesFor, - make, - make', -) where - -import Control.Algebra (Has) -import Control.Arrow (left) -import Control.Effect.Lift (Lift, sendIO) -import Control.Effect.Throw (Throw, liftEither) -import Control.Lens hiding (from, (.=)) -import Control.Monad ((<=<)) -import Data.Bifunctor (second) -import Data.Either.Validation -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.Game.Entity as E -import Swarm.Game.Failure -import Swarm.Game.ResourceLoading (getDataFileNameSafe) -import Swarm.Util.Effect (withThrow) -import Swarm.Util.Lens (makeLensesNoSigs) -import Swarm.Util.Yaml -import Witch - --- | An ingredient list is a list of entities with multiplicity. It --- is polymorphic in the entity type so that we can use either --- entity names when serializing, or actual entity objects while the --- game is running. -type IngredientList e = [(Count, e)] - --- | A recipe represents some kind of process where inputs are --- transformed into outputs. -data Recipe e = Recipe - { _recipeInputs :: IngredientList e - , _recipeOutputs :: IngredientList e - , _recipeCatalysts :: IngredientList e - , _recipeTime :: Integer - , _recipeWeight :: Integer - } - deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) - -deriving instance ToJSON (Recipe Entity) -deriving instance FromJSON (Recipe Entity) - -makeLensesNoSigs ''Recipe - --- | The inputs to a recipe. -recipeInputs :: Lens' (Recipe e) (IngredientList e) - --- | The outputs from a recipe. -recipeOutputs :: Lens' (Recipe e) (IngredientList e) - --- | The time required to finish a recipe. -recipeTime :: Lens' (Recipe e) Integer - --- | Other entities which the recipe requires you to have, but which --- are not consumed by the recipe (e.g. a @\"furnace\"@). -recipeCatalysts :: Lens' (Recipe e) (IngredientList e) - --- | How this recipe is weighted against other recipes. Any time --- there are multiple valid recipes that fit certain criteria, one --- of the recipes will be randomly chosen with probability --- proportional to its weight. -recipeWeight :: Lens' (Recipe e) Integer - ------------------------------------------------------------- --- Serializing ------------------------------------------------------------- - -instance ToJSON (Recipe Text) where - toJSON (Recipe ins outs cats time weight) = - object $ - [ "in" .= ins - , "out" .= outs - ] - ++ ["required" .= cats | not (null cats)] - ++ ["time" .= time | time /= 1] - ++ ["weight" .= weight | weight /= 1] - -instance FromJSON (Recipe Text) where - parseJSON = withObject "Recipe" $ \v -> - Recipe - <$> v - .: "in" - <*> v - .: "out" - <*> v - .:? "required" - .!= [] - <*> v - .:? "time" - .!= 1 - <*> v - .:? "weight" - .!= 1 - --- | Given an 'EntityMap', turn a list of recipes containing /names/ --- of entities into a list of recipes containing actual 'Entity' --- records; or. -resolveRecipes :: EntityMap -> [Recipe Text] -> Validation [Text] [Recipe Entity] -resolveRecipes em = (traverse . traverse) (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) - -instance FromJSONE EntityMap (Recipe Entity) where - parseJSONE v = do - rt <- liftE $ parseJSON @(Recipe Text) v - em <- getE - let erEnt :: Validation [Text] (Recipe Entity) - erEnt = traverse (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) rt - case validationToEither erEnt of - Right rEnt -> return rEnt - Left err -> fail . from @Text . T.unlines $ err - --- | Given an already loaded 'EntityMap', try to load a list of --- recipes from the data file @recipes.yaml@. -loadRecipes :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - EntityMap -> - m [Recipe Entity] -loadRecipes em = do - fileName <- getDataFileNameSafe Recipes f - textRecipes <- - withThrow (AssetNotLoaded (Data Recipes) fileName . CanNotParseYaml) - . (liftEither <=< sendIO) - $ decodeFileEither @[Recipe Text] fileName - withThrow (AssetNotLoaded (Data Recipes) fileName . CustomMessage) - . liftEither - . left (T.append "Unknown entities in recipe(s): " . T.intercalate ", ") - . validationToEither - $ resolveRecipes em textRecipes - where - f = "recipes.yaml" - ------------------------------------------------------------- - --- | Build a map of recipes either by inputs or outputs. -buildRecipeMap :: - Getter (Recipe Entity) (IngredientList Entity) -> - [Recipe Entity] -> - IntMap [Recipe Entity] -buildRecipeMap select recipeList = - IM.fromListWith (++) (map (second (: [])) (concatMap mk recipeList)) - where - mk r = [(e ^. entityHash, r) | (_, e) <- r ^. select] - --- | Build a map of recipes indexed by output ingredients. -outRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity] -outRecipeMap = buildRecipeMap recipeOutputs - --- | Build a map of recipes indexed by input ingredients. -inRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity] -inRecipeMap = buildRecipeMap recipeInputs - --- | Build a map of recipes indexed by catalysts. -catRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity] -catRecipeMap = buildRecipeMap recipeCatalysts - --- | Get a list of all the recipes for the given entity. Look up an --- entity in either an 'inRecipeMap' or 'outRecipeMap' depending on --- whether you want to know recipes that consume or produce the --- given entity, respectively. -recipesFor :: IntMap [Recipe Entity] -> Entity -> [Recipe Entity] -recipesFor rm e = fromMaybe [] $ IM.lookup (e ^. entityHash) rm - --- | Record information about something missing from a recipe. -data MissingIngredient = MissingIngredient MissingType Count Entity - deriving (Show, Eq) - --- | What kind of thing is missing? -data MissingType = MissingInput | MissingCatalyst - deriving (Show, Eq) - --- | Figure out which ingredients (if any) are lacking from an --- inventory to be able to carry out the recipe. Catalysts are not --- consumed and so can be used even when equipped. -missingIngredientsFor :: (Inventory, Inventory) -> Recipe Entity -> [MissingIngredient] -missingIngredientsFor (inv, ins) (Recipe inps _ cats _ _) = - mkMissing MissingInput (findLacking inv inps) - <> mkMissing MissingCatalyst (findLacking ins (findLacking inv cats)) - where - mkMissing k = map (uncurry (MissingIngredient k)) - findLacking inven = filter ((> 0) . fst) . map (countNeeded inven) - countNeeded inven (need, entity) = (need - E.lookup entity inven, entity) - --- | Figure out if a recipe is available, /i.e./ if we at least know --- about all the ingredients. Note it does not matter whether we have --- enough of the ingredients. -knowsIngredientsFor :: (Inventory, Inventory) -> Recipe Entity -> Bool -knowsIngredientsFor (inv, ins) recipe = - knowsAll inv (recipe ^. recipeInputs) && knowsAll ins (recipe ^. recipeCatalysts) - where - knowsAll xs = all (E.contains xs . snd) - --- | Try to make a recipe, deleting the recipe's inputs from the --- inventory. Return either a description of which items are --- lacking, if the inventory does not contain sufficient inputs, --- or an inventory without inputs and function adding outputs if --- it was successful. -make :: - -- | The robot's inventory and equipped devices - (Inventory, Inventory) -> - -- | The recipe we are trying to make - Recipe Entity -> - Either - [MissingIngredient] - (Inventory, IngredientList Entity, Recipe Entity) -make invs r = finish <$> make' invs r - where - finish (invTaken, out) = (invTaken, out, r) - --- | Try to make a recipe, but do not insert it yet. -make' :: (Inventory, Inventory) -> Recipe Entity -> Either [MissingIngredient] (Inventory, IngredientList Entity) -make' invs@(inv, _) r = - case missingIngredientsFor invs r of - [] -> - let removed = foldl' (flip (uncurry deleteCount)) inv (r ^. recipeInputs) - in Right (removed, r ^. recipeOutputs) - missing -> Left missing diff --git a/src/Swarm/Game/ResourceLoading.hs b/src/Swarm/Game/ResourceLoading.hs deleted file mode 100644 --- a/src/Swarm/Game/ResourceLoading.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Various utilities related to loading game data files. -module Swarm.Game.ResourceLoading 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 (XdgData), - 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 - --- | Get a nice message suggesting to download @data@ directory to 'XdgData'. -dataNotFound :: FilePath -> IO LoadingFailure -dataNotFound f = do - d <- getSwarmXdgDataSubdir False "" - let squotes = squote . T.pack - return $ - CustomMessage $ - T.unlines - [ "Could not find the data: " <> squotes f - , "Try downloading the Swarm 'data' directory to: " <> squotes (d "data") - ] - --- | 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" - --- | 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/Game/Robot.hs b/src/Swarm/Game/Robot.hs deleted file mode 100644 --- a/src/Swarm/Game/Robot.hs +++ /dev/null @@ -1,656 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A data type to represent robots. -module Swarm.Game.Robot ( - -- * Robots data - - -- * Robots - RobotPhase (..), - RID, - RobotR, - Robot, - TRobot, - - -- ** Runtime robot update - RobotUpdate (..), - - -- * Robot context - RobotContext, - defTypes, - defReqs, - defVals, - defStore, - emptyRobotContext, - - -- ** Lenses - robotEntity, - robotName, - trobotName, - unwalkableEntities, - robotCreatedAt, - robotDisplay, - robotLocation, - unsafeSetRobotLocation, - trobotLocation, - robotOrientation, - robotInventory, - equippedDevices, - robotLog, - robotLogUpdated, - inventoryHash, - robotCapabilities, - robotContext, - trobotContext, - robotID, - robotParentID, - robotHeavy, - machine, - systemRobot, - selfDestruct, - runningAtomic, - activityCounts, - tickStepBudget, - tangibleCommandCount, - commandsHistogram, - lifetimeStepCount, - activityWindow, - - -- ** Creation & instantiation - mkRobot, - instantiateRobot, - - -- ** Query - robotKnows, - isActive, - wantsToStep, - waitingUntil, - getResult, - - -- ** Constants - hearingDistance, -) where - -import Control.Lens hiding (Const, contains) -import Data.Aeson qualified as Ae (FromJSON, Key, KeyValue, ToJSON (..), object, (.=)) -import Data.Hashable (hashWithSalt) -import Data.Kind qualified -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe, isNothing) -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Data.Set (Set) -import Data.Text (Text) -import Data.Yaml ((.!=), (.:), (.:?)) -import GHC.Generics (Generic) -import Linear -import Servant.Docs (ToSample) -import Servant.Docs qualified as SD -import Swarm.Game.CESK -import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible) -import Swarm.Game.Entity hiding (empty) -import Swarm.Game.Location (Heading, Location, toDirection) -import Swarm.Game.Universe -import Swarm.Language.Capability (Capability) -import Swarm.Language.Context qualified as Ctx -import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Requirement (ReqCtx) -import Swarm.Language.Syntax (Const, Syntax) -import Swarm.Language.Text.Markdown (Document) -import Swarm.Language.Typed (Typed (..)) -import Swarm.Language.Types (TCtx) -import Swarm.Language.Value as V -import Swarm.Log -import Swarm.Util.Lens (makeLensesExcluding, makeLensesNoSigs) -import Swarm.Util.WindowedCounter -import Swarm.Util.Yaml -import System.Clock (TimeSpec) - --- | A record that stores the information --- for all definitions stored in a 'Robot' -data RobotContext = RobotContext - { _defTypes :: TCtx - -- ^ Map definition names to their types. - , _defReqs :: ReqCtx - -- ^ Map definition names to the capabilities - -- required to evaluate/execute them. - , _defVals :: Env - -- ^ Map definition names to their values. Note that since - -- definitions are delayed, the values will just consist of - -- 'VRef's pointing into the store. - , _defStore :: Store - -- ^ A store containing memory cells allocated to hold - -- definitions. - } - deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON) - -makeLenses ''RobotContext - -emptyRobotContext :: RobotContext -emptyRobotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty emptyStore - -type instance Index RobotContext = Ctx.Var -type instance IxValue RobotContext = Typed Value - -instance Ixed RobotContext -instance At RobotContext where - at name = lens getter setter - where - getter ctx = - do - typ <- Ctx.lookup name (ctx ^. defTypes) - val <- Ctx.lookup name (ctx ^. defVals) - req <- Ctx.lookup name (ctx ^. defReqs) - return $ Typed val typ req - setter ctx Nothing = - ctx - & defTypes %~ Ctx.delete name - & defVals %~ Ctx.delete name - & defReqs %~ Ctx.delete name - setter ctx (Just (Typed val typ req)) = - ctx - & defTypes %~ Ctx.addBinding name typ - & defVals %~ Ctx.addBinding name val - & defReqs %~ Ctx.addBinding name req - --- | A unique identifier for a robot. -type RID = Int - --- | The phase of a robot description record. -data RobotPhase - = -- | The robot record has just been read in from a scenario - -- description; it represents a /template/ that may later be - -- instantiated as one or more concrete robots. - TemplateRobot - | -- | The robot record represents a concrete robot in the world. - ConcreteRobot - -data ActivityCounts = ActivityCounts - { _tickStepBudget :: Int - , _tangibleCommandCount :: Int - , _commandsHistogram :: Map Const Int - , _lifetimeStepCount :: Int - , _activityWindow :: WindowedCounter TickNumber - } - deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON) - -emptyActivityCount :: ActivityCounts -emptyActivityCount = - ActivityCounts - { _tickStepBudget = 0 - , _tangibleCommandCount = 0 - , _commandsHistogram = mempty - , _lifetimeStepCount = 0 - , -- NOTE: This value was chosen experimentally. - -- TODO(#1341): Make this dynamic based on game speed. - _activityWindow = mkWindow 64 - } - -makeLensesNoSigs ''ActivityCounts - --- | A counter that is decremented upon each step of the robot within the --- CESK machine. Initially set to 'Swarm.Game.State.robotStepsPerTick' --- at each new tick. --- --- The need for 'tickStepBudget' is a bit technical, and I hope I can --- eventually find a different, better way to accomplish it. --- Ideally, we would want each robot to execute a single --- /command/ at every game tick, so that /e.g./ two robots --- executing @move;move;move@ and @repeat 3 move@ (given a --- suitable definition of @repeat@) will move in lockstep. --- However, the second robot actually has to do more computation --- than the first (it has to look up the definition of @repeat@, --- reduce its application to the number 3, etc.), so its CESK --- machine will take more steps. It won't do to simply let each --- robot run until executing a command---because robot programs --- can involve arbitrary recursion, it is very easy to write a --- program that evaluates forever without ever executing a --- command, which in this scenario would completely freeze the --- UI. (It also wouldn't help to ensure all programs are --- terminating---it would still be possible to effectively do --- the same thing by making a program that takes a very, very --- long time to terminate.) So instead, we allocate each robot --- a certain maximum number of computation steps per tick --- (defined in 'Swarm.Game.Step.evalStepsPerTick'), and it --- suspends computation when it either executes a command or --- reaches the maximum number of steps, whichever comes first. --- --- It seems like this really isn't something the robot should be --- keeping track of itself, but that seemed the most technically --- convenient way to do it at the time. The robot needs some --- way to signal when it has executed a command, which it --- currently does by setting tickStepBudget to zero. However, that --- has the disadvantage that when tickStepBudget becomes zero, we --- can't tell whether that happened because the robot ran out of --- steps, or because it executed a command and set it to zero --- manually. --- --- Perhaps instead, each robot should keep a counter saying how --- many commands it has executed. The loop stepping the robot --- can tell when the counter increments. -tickStepBudget :: Lens' ActivityCounts Int - --- | Total number of tangible commands executed over robot's lifetime -tangibleCommandCount :: Lens' ActivityCounts Int - --- | Histogram of commands executed over robot's lifetime -commandsHistogram :: Lens' ActivityCounts (Map Const Int) - --- | Total number of CESK steps executed over robot's lifetime. --- This could be thought of as "CPU cycles" consumed, and is labeled --- as "cycles" in the F2 dialog in the UI. -lifetimeStepCount :: Lens' ActivityCounts Int - --- | Sliding window over a span of ticks indicating ratio of activity -activityWindow :: Lens' ActivityCounts (WindowedCounter TickNumber) - --- | With a robot template, we may or may not have a location. With a --- concrete robot we must have a location. -type family RobotLocation (phase :: RobotPhase) :: Data.Kind.Type where - RobotLocation 'TemplateRobot = Maybe (Cosmic Location) - RobotLocation 'ConcreteRobot = Cosmic Location - --- | Robot templates have no ID; concrete robots definitely do. -type family RobotID (phase :: RobotPhase) :: Data.Kind.Type where - RobotID 'TemplateRobot = () - RobotID 'ConcreteRobot = RID - --- | A value of type 'RobotR' is a record representing the state of a --- single robot. The @f@ parameter is for tracking whether or not --- the robot has been assigned a unique ID. -data RobotR (phase :: RobotPhase) = RobotR - { _robotEntity :: Entity - , _equippedDevices :: Inventory - , _robotCapabilities :: Set Capability - -- ^ A cached view of the capabilities this robot has. - -- Automatically generated from '_equippedDevices'. - , _robotLog :: Seq LogEntry - , _robotLogUpdated :: Bool - , _robotLocation :: RobotLocation phase - , _robotContext :: RobotContext - , _robotID :: RobotID phase - , _robotParentID :: Maybe RID - , _robotHeavy :: Bool - , _machine :: CESK - , _systemRobot :: Bool - , _selfDestruct :: Bool - , _activityCounts :: ActivityCounts - , _runningAtomic :: Bool - , _unwalkableEntities :: Set EntityName - , _robotCreatedAt :: TimeSpec - } - deriving (Generic) - -deriving instance (Show (RobotLocation phase), Show (RobotID phase)) => Show (RobotR phase) -deriving instance (Eq (RobotLocation phase), Eq (RobotID phase)) => Eq (RobotR phase) - --- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ --- for the approach used here with lenses. - -makeLensesExcluding ['_robotCapabilities, '_equippedDevices, '_robotLog] ''RobotR - --- | A template robot, i.e. a template robot record without a unique ID number, --- and possibly without a location. -type TRobot = RobotR 'TemplateRobot - --- | A concrete robot, with a unique ID number and a specific location. -type Robot = RobotR 'ConcreteRobot - -instance ToSample Robot where - toSamples _ = SD.singleSample sampleBase - where - sampleBase :: Robot - sampleBase = - mkRobot - 0 - Nothing - "base" - "The starting robot." - defaultCosmicLocation - zero - defaultRobotDisplay - (initMachine [tmQ| move |] mempty emptyStore) - [] - [] - False - False - mempty - 0 - --- In theory we could make all these lenses over (RobotR phase), but --- that leads to lots of type ambiguity problems later. In practice --- we only need lenses for Robots. - --- | Robots are not entities, but they have almost all the --- characteristics of one (or perhaps we could think of robots as --- very special sorts of entities), so for convenience each robot --- carries an 'Entity' record to store all the information it has in --- common with any 'Entity'. --- --- Note there are various lenses provided for convenience that --- directly reference fields inside this record; for example, one --- can use 'robotName' instead of writing @'robotEntity' --- . 'entityName'@. -robotEntity :: Lens' (RobotR phase) Entity - --- | Entities that the robot cannot move onto -unwalkableEntities :: Lens' Robot (Set EntityName) - --- | The creation date of the robot. -robotCreatedAt :: Lens' Robot TimeSpec - --- robotName and trobotName could be generalized to --- @robotName' :: Lens' (RobotR phase) Text@. --- However, type inference does not work --- very well with the polymorphic version, so we export both --- monomorphic versions instead. - --- | The name of a robot. -robotName :: Lens' Robot Text -robotName = robotEntity . entityName - --- | The name of a robot template. -trobotName :: Lens' TRobot Text -trobotName = robotEntity . entityName - --- | The 'Display' of a robot. This is a special lens that --- automatically sets the 'curOrientation' to the orientation of the --- robot every time you do a @get@ operation. Technically this does --- not satisfy the lens laws---in particular, the get/put law does --- not hold. But we should think of the 'curOrientation' as being --- simply a cache of the displayed entity's direction. -robotDisplay :: Lens' Robot Display -robotDisplay = lens getDisplay setDisplay - where - getDisplay r = - (r ^. robotEntity . entityDisplay) - & curOrientation .~ ((r ^. robotOrientation) >>= toDirection) - setDisplay r d = r & robotEntity . entityDisplay .~ d - --- | The robot's current location, represented as @(x,y)@. This is only --- a getter, since when changing a robot's location we must remember --- to update the 'Swarm.Game.State.robotsByLocation' map as well. You can use the --- 'Swarm.Game.Step.updateRobotLocation' function for this purpose. -robotLocation :: Getter Robot (Cosmic Location) - --- | Set a robot's location. This is unsafe and should never be --- called directly except by the 'Swarm.Game.Step.updateRobotLocation' function. --- The reason is that we need to make sure the 'Swarm.Game.State.robotsByLocation' --- map stays in sync. -unsafeSetRobotLocation :: Cosmic Location -> Robot -> Robot -unsafeSetRobotLocation loc r = r {_robotLocation = loc} - --- | A template robot's location. Unlike 'robotLocation', this is a --- lens, since when dealing with robot templates there is as yet no --- 'Swarm.Game.State.robotsByLocation' map to keep up-to-date. -trobotLocation :: Lens' TRobot (Maybe (Cosmic Location)) -trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l}) - --- | Which way the robot is currently facing. -robotOrientation :: Lens' Robot (Maybe Heading) -robotOrientation = robotEntity . entityOrientation - --- | The robot's inventory. -robotInventory :: Lens' Robot Inventory -robotInventory = robotEntity . entityInventory - --- | The robot's context. -robotContext :: Lens' Robot RobotContext - --- | The robot's context. -trobotContext :: Lens' TRobot RobotContext -trobotContext = lens _robotContext (\r c -> r {_robotContext = c}) - --- | The (unique) ID number of the robot. This is only a Getter since --- the robot ID is immutable. -robotID :: Getter Robot RID - --- | Instantiate a robot template to make it into a concrete robot, by --- providing a robot ID. Concrete robots also require a location; --- if the robot template didn't have a location already, just set --- the location to (0,0) by default. If you want a different location, --- set it via 'trobotLocation' before calling 'instantiateRobot'. -instantiateRobot :: RID -> TRobot -> Robot -instantiateRobot i r = - r - { _robotID = i - , _robotLocation = fromMaybe defaultCosmicLocation $ _robotLocation r - } - --- | The ID number of the robot's parent, that is, the robot that --- built (or most recently reprogrammed) this robot, if there is --- one. -robotParentID :: Lens' Robot (Maybe RID) - --- | Is this robot extra heavy (thus requiring tank treads to move)? -robotHeavy :: Lens' Robot Bool - --- | A separate inventory for equipped devices, which provide the --- robot with certain capabilities. --- --- Note that every time the inventory of equipped devices is --- modified, this lens recomputes a cached set of the capabilities --- the equipped devices provide, to speed up subsequent lookups to --- see whether the robot has a certain capability (see 'robotCapabilities') -equippedDevices :: Lens' Robot Inventory -equippedDevices = lens _equippedDevices setEquipped - where - setEquipped r inst = - r - { _equippedDevices = inst - , _robotCapabilities = inventoryCapabilities inst - } - --- | The robot's own private message log, most recent message last. --- Messages can be added both by explicit use of the 'Swarm.Language.Syntax.Log' command, --- and by uncaught exceptions. Stored as a 'Seq' so that --- we can efficiently add to the end and also process from beginning --- to end. Note that updating via this lens will also set the --- 'robotLogUpdated'. -robotLog :: Lens' Robot (Seq LogEntry) -robotLog = lens _robotLog setLog - where - setLog r newLog = - r - { _robotLog = newLog - , -- Flag the log as updated if (1) if already was, or (2) the new - -- log is a different length than the old. (This would not - -- catch updates that merely modify an entry, but we don't want - -- to have to compare the entire logs, and we only ever append - -- to logs anyway.) - _robotLogUpdated = - _robotLogUpdated r || Seq.length (_robotLog r) /= Seq.length newLog - } - --- | Has the 'robotLog' been updated since the last time it was --- viewed? -robotLogUpdated :: Lens' Robot Bool - --- | A hash of a robot's entity record and equipped devices, to --- facilitate quickly deciding whether we need to redraw the robot --- info panel. -inventoryHash :: Getter Robot Int -inventoryHash = to (\r -> 17 `hashWithSalt` (r ^. (robotEntity . entityHash)) `hashWithSalt` (r ^. equippedDevices)) - --- | Does a robot know of an entity's existence? -robotKnows :: Robot -> Entity -> Bool -robotKnows r e = contains0plus e (r ^. robotInventory) || contains0plus e (r ^. equippedDevices) - --- | Get the set of capabilities this robot possesses. This is only a --- getter, not a lens, because it is automatically generated from --- the 'equippedDevices'. The only way to change a robot's --- capabilities is to modify its 'equippedDevices'. -robotCapabilities :: Getter Robot (Set Capability) -robotCapabilities = to _robotCapabilities - --- | The robot's current CEK machine state. -machine :: Lens' Robot CESK - --- | Is this robot a "system robot"? System robots are generated by --- the system (as opposed to created by the user) and are not --- subject to the usual capability restrictions. -systemRobot :: Lens' Robot Bool - --- | Does this robot wish to self destruct? -selfDestruct :: Lens' Robot Bool - --- | Diagnostic and operational tracking of CESK steps or other activity -activityCounts :: Lens' Robot ActivityCounts - --- | Is the robot currently running an atomic block? -runningAtomic :: Lens' Robot Bool - --- | A general function for creating robots. -mkRobot :: - -- | ID number of the robot. - RobotID phase -> - -- | ID number of the robot's parent, if it has one. - Maybe Int -> - -- | Name of the robot. - Text -> - -- | Description of the robot. - Document Syntax -> - -- | Initial location. - RobotLocation phase -> - -- | Initial heading/direction. - Heading -> - -- | Robot display. - Display -> - -- | Initial CESK machine. - CESK -> - -- | Equipped devices. - [Entity] -> - -- | Initial inventory. - [(Count, Entity)] -> - -- | Should this be a system robot? - Bool -> - -- | Is this robot heavy? - Bool -> - -- | Unwalkable entities - Set EntityName -> - -- | Creation date - TimeSpec -> - RobotR phase -mkRobot rid pid name descr loc dir disp m devs inv sys heavy unwalkables ts = - RobotR - { _robotEntity = - mkEntity disp name descr [] [] - & entityOrientation ?~ dir - & entityInventory .~ fromElems inv - , _equippedDevices = inst - , _robotCapabilities = inventoryCapabilities inst - , _robotLog = Seq.empty - , _robotLogUpdated = False - , _robotLocation = loc - , _robotContext = emptyRobotContext - , _robotID = rid - , _robotParentID = pid - , _robotHeavy = heavy - , _robotCreatedAt = ts - , _machine = m - , _systemRobot = sys - , _selfDestruct = False - , _activityCounts = emptyActivityCount - , _runningAtomic = False - , _unwalkableEntities = unwalkables - } - where - inst = fromList devs - --- | We can parse a robot from a YAML file if we have access to an --- 'EntityMap' in which we can look up the names of entities. -instance FromJSONE EntityMap TRobot where - parseJSONE = withObjectE "robot" $ \v -> do - -- Note we can't generate a unique ID here since we don't have - -- access to a 'State GameState' effect; a unique ID will be - -- filled in later when adding the robot to the world. - sys <- liftE $ v .:? "system" .!= False - let defDisplay = defaultRobotDisplay & invisible .~ sys - - mkRobot () Nothing - <$> liftE (v .: "name") - <*> liftE (v .:? "description" .!= mempty) - <*> liftE (v .:? "loc") - <*> liftE (v .:? "dir" .!= zero) - <*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay) - <*> liftE (mkMachine <$> (v .:? "program")) - <*> v ..:? "devices" ..!= [] - <*> v ..:? "inventory" ..!= [] - <*> pure sys - <*> liftE (v .:? "heavy" .!= False) - <*> liftE (v .:? "unwalkable" ..!= mempty) - <*> pure 0 - where - mkMachine Nothing = Out VUnit emptyStore [] - mkMachine (Just pt) = initMachine pt mempty emptyStore - -(.=?) :: (Ae.KeyValue a, Ae.ToJSON v, Eq v) => Ae.Key -> v -> v -> Maybe a -(.=?) n v defaultVal = if defaultVal /= v then Just $ n Ae..= v else Nothing - -(.==) :: (Ae.KeyValue a, Ae.ToJSON v) => Ae.Key -> v -> Maybe a -(.==) n v = Just $ n Ae..= v - -instance Ae.ToJSON Robot where - toJSON r = - Ae.object $ - catMaybes - [ "id" .== (r ^. robotID) - , "name" .== (r ^. robotEntity . entityDisplay) - , "description" .=? (r ^. robotEntity . entityDescription) $ mempty - , "loc" .== (r ^. robotLocation) - , "dir" .=? (r ^. robotEntity . entityOrientation) $ zero - , "display" .=? (r ^. robotDisplay) $ (defaultRobotDisplay & invisible .~ sys) - , "program" .== (r ^. machine) - , "devices" .=? (map (^. _2 . entityName) . elems $ r ^. equippedDevices) $ [] - , "inventory" .=? (map (_2 %~ view entityName) . elems $ r ^. robotInventory) $ [] - , "system" .=? sys $ False - , "heavy" .=? (r ^. robotHeavy) $ False - , "log" .=? (r ^. robotLog) $ mempty - , -- debug - "capabilities" .=? (r ^. robotCapabilities) $ mempty - , "logUpdated" .=? (r ^. robotLogUpdated) $ False - , "context" .=? (r ^. robotContext) $ emptyRobotContext - , "parent" .=? (r ^. robotParentID) $ Nothing - , "createdAt" .=? (r ^. robotCreatedAt) $ 0 - , "selfDestruct" .=? (r ^. selfDestruct) $ False - , "activity" .=? (r ^. activityCounts) $ emptyActivityCount - , "runningAtomic" .=? (r ^. runningAtomic) $ False - ] - where - sys = r ^. systemRobot - --- | Is the robot actively in the middle of a computation? -isActive :: Robot -> Bool -{-# INLINE isActive #-} -isActive = isNothing . getResult - --- | "Active" robots include robots that are waiting; 'wantsToStep' is --- true if the robot actually wants to take another step right now --- (this is a /subset/ of active robots). -wantsToStep :: TickNumber -> Robot -> Bool -wantsToStep now robot - | not (isActive robot) = False - | otherwise = maybe True (now >=) (waitingUntil robot) - --- | The time until which the robot is waiting, if any. -waitingUntil :: Robot -> Maybe TickNumber -waitingUntil robot = - case _machine robot of - Waiting time _ -> Just time - _ -> Nothing - --- | Get the result of the robot's computation if it is finished. -getResult :: Robot -> Maybe (Value, Store) -{-# INLINE getResult #-} -getResult = finalValue . view machine - -hearingDistance :: (Num i) => i -hearingDistance = 32 diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario.hs +++ /dev/null @@ -1,305 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Scenarios are standalone worlds with specific starting and winning --- 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, - - -- * Scenario - Scenario (..), - - -- ** Fields - scenarioVersion, - scenarioName, - scenarioAuthor, - scenarioDescription, - scenarioCreative, - scenarioSeed, - scenarioAttrs, - scenarioEntities, - scenarioRecipes, - scenarioKnown, - scenarioWorlds, - scenarioNavigation, - scenarioRobots, - scenarioObjectives, - scenarioSolution, - scenarioStepsPerTick, - - -- * Loading from disk - loadScenario, - loadScenarioFile, - getScenarioPath, - loadStandaloneScenario, -) where - -import Control.Arrow ((&&&)) -import Control.Carrier.Throw.Either (runThrow) -import Control.Effect.Lift (Lift, sendIO) -import Control.Effect.Throw -import Control.Lens hiding (from, (.=), (<.>)) -import Control.Monad (filterM, unless, (<=<)) -import Data.Aeson -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M -import Data.Maybe (catMaybes, isNothing, listToMaybe) -import Data.Sequence (Seq) -import Data.Text (Text) -import Data.Text qualified as T -import Swarm.Game.Entity -import Swarm.Game.Failure -import Swarm.Game.Location -import Swarm.Game.Recipe -import Swarm.Game.ResourceLoading (getDataFileNameSafe) -import Swarm.Game.Robot (TRobot) -import Swarm.Game.Scenario.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.Navigation.Portal -import Swarm.Game.Scenario.Topography.Structure qualified as Structure -import Swarm.Game.Scenario.Topography.WorldDescription -import Swarm.Game.Universe -import Swarm.Game.World.Load (loadWorlds) -import Swarm.Game.World.Typecheck (WorldMap) -import Swarm.Language.Pipeline (ProcessedTerm) -import Swarm.Language.Pretty (prettyText) -import Swarm.Language.Syntax (Syntax) -import Swarm.Language.Text.Markdown (Document) -import Swarm.Util (binTuples, failT) -import Swarm.Util.Effect (ignoreWarnings, throwToMaybe, withThrow) -import Swarm.Util.Lens (makeLensesNoSigs) -import Swarm.Util.Yaml -import System.Directory (doesFileExist) -import System.FilePath ((<.>), ()) - ------------------------------------------------------------- --- Scenario ------------------------------------------------------------- - --- | A 'Scenario' contains all the information to describe a --- scenario. -data Scenario = Scenario - { _scenarioVersion :: Int - , _scenarioName :: Text - , _scenarioAuthor :: Maybe Text - , _scenarioDescription :: Document Syntax - , _scenarioCreative :: Bool - , _scenarioSeed :: Maybe Int - , _scenarioAttrs :: [CustomAttr] - , _scenarioEntities :: EntityMap - , _scenarioRecipes :: [Recipe Entity] - , _scenarioKnown :: [Text] - , _scenarioWorlds :: NonEmpty WorldDescription - , _scenarioNavigation :: Navigation (M.Map SubworldName) Location - , _scenarioRobots :: [TRobot] - , _scenarioObjectives :: [Objective] - , _scenarioSolution :: Maybe ProcessedTerm - , _scenarioStepsPerTick :: Maybe Int - } - deriving (Show) - -makeLensesNoSigs ''Scenario - -instance FromJSONE (EntityMap, WorldMap) Scenario where - parseJSONE = withObjectE "scenario" $ \v -> do - -- parse custom entities - emRaw <- liftE (v .:? "entities" .!= []) - em <- case run . runThrow $ buildEntityMap emRaw of - Right x -> return x - Left x -> failT [prettyText @LoadingFailure x] - - -- Save the passed in WorldMap for later - worldMap <- snd <$> getE - - -- Get rid of WorldMap from context locally, and combine EntityMap - -- with any custom entities parsed above - localE fst $ withE em $ do - -- parse 'known' entity names and make sure they exist - known <- liftE (v .:? "known" .!= []) - em' <- getE - case filter (isNothing . (`lookupEntityName` em')) known of - [] -> return () - unk -> failT ["Unknown entities in 'known' list:", T.intercalate ", " unk] - - -- parse robots and build RobotMap - rs <- v ..: "robots" - let rsMap = buildRobotMap rs - - rootLevelSharedStructures :: Structure.InheritedStructureDefs <- - localE (,rsMap) $ - v ..:? "structures" ..!= [] - - allWorlds <- localE (worldMap,rootLevelSharedStructures,,rsMap) $ do - rootWorld <- v ..: "world" - subworlds <- v ..:? "subworlds" ..!= [] - return $ rootWorld :| subworlds - - let worldsByName = binTuples $ NE.toList $ NE.map (worldName &&& id) allWorlds - dupedNames = M.keys $ M.filter ((> 1) . length) worldsByName - unless (null dupedNames) $ - failT - [ "Subworld names are not unique:" - , T.intercalate ", " $ map renderWorldName dupedNames - ] - - let mergedWaypoints = - M.fromList $ - map (worldName &&& runIdentity . waypoints . navigation) $ - NE.toList allWorlds - - mergedPortals <- - validatePortals - . Navigation mergedWaypoints - . M.unions - . map (portals . navigation) - $ NE.toList allWorlds - - let mergedNavigation = Navigation mergedWaypoints mergedPortals - - Scenario - <$> liftE (v .: "version") - <*> liftE (v .: "name") - <*> liftE (v .:? "author") - <*> liftE (v .:? "description" .!= "") - <*> liftE (v .:? "creative" .!= False) - <*> liftE (v .:? "seed") - <*> liftE (v .:? "attrs" .!= []) - <*> pure em - <*> v ..:? "recipes" ..!= [] - <*> pure known - <*> pure allWorlds - <*> pure mergedNavigation - <*> pure rs - <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives) - <*> liftE (v .:? "solution") - <*> liftE (v .:? "stepsPerTick") - --------------------------------------------------- --- Lenses - --- | The version number of the scenario schema. Currently, this --- should always be 1, but it is ignored. In the future, this may --- be used to convert older formats to newer ones, or simply to --- print a nice error message when we can't read an older format. -scenarioVersion :: Lens' Scenario Int - --- | The name of the scenario. -scenarioName :: Lens' Scenario Text - --- | The author of the scenario. -scenarioAuthor :: Lens' Scenario (Maybe Text) - --- | A high-level description of the scenario, shown /e.g./ in the --- menu. -scenarioDescription :: Lens' Scenario (Document Syntax) - --- | Whether the scenario should start in creative mode. -scenarioCreative :: Lens' Scenario Bool - --- | The seed used for the random number generator. If @Nothing@, use --- a random seed / prompt the user for the seed. -scenarioSeed :: Lens' Scenario (Maybe Int) - --- | Custom attributes defined in the scenario. -scenarioAttrs :: Lens' Scenario [CustomAttr] - --- | Any custom entities used for this scenario. -scenarioEntities :: Lens' Scenario EntityMap - --- | Any custom recipes used in this scenario. -scenarioRecipes :: Lens' Scenario [Recipe Entity] - --- | List of entities that should be considered "known", so robots do --- not have to scan them. -scenarioKnown :: Lens' Scenario [Text] - --- | The subworlds of the scenario. --- The "root" subworld shall always be at the head of the list, by construction. -scenarioWorlds :: Lens' Scenario (NonEmpty WorldDescription) - --- | Waypoints and inter-world portals -scenarioNavigation :: Lens' Scenario (Navigation (M.Map SubworldName) Location) - --- | The starting robots for the scenario. Note this should --- include the base. -scenarioRobots :: Lens' Scenario [TRobot] - --- | A sequence of objectives for the scenario (if any). -scenarioObjectives :: Lens' Scenario [Objective] - --- | An optional solution of the scenario, expressed as a --- program of type @cmd a@. This is useful for automated --- testing of the win condition. -scenarioSolution :: Lens' Scenario (Maybe ProcessedTerm) - --- | Optionally, specify the maximum number of steps each robot may --- take during a single tick. -scenarioStepsPerTick :: Lens' Scenario (Maybe Int) ------------------------------------------------------------- --- Loading scenarios ------------------------------------------------------------- - -getScenarioPath :: - (Has (Lift IO) sig m) => - FilePath -> - m (Maybe FilePath) -getScenarioPath scenario = do - libScenario <- throwToMaybe @SystemFailure $ getDataFileNameSafe Scenarios $ "scenarios" scenario - libScenarioExt <- throwToMaybe @SystemFailure $ getDataFileNameSafe Scenarios $ "scenarios" scenario <.> "yaml" - let candidates = catMaybes [Just scenario, libScenarioExt, libScenario] - listToMaybe <$> sendIO (filterM doesFileExist candidates) - --- | Load a scenario with a given name from disk, given an entity map --- to use. This function is used if a specific scenario is --- requested on the command line. -loadScenario :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - FilePath -> - EntityMap -> - WorldMap -> - m (Scenario, FilePath) -loadScenario scenario em worldMap = do - mfileName <- getScenarioPath scenario - fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName - (,fileName) <$> loadScenarioFile em worldMap fileName - --- | Load a scenario from a file. -loadScenarioFile :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - EntityMap -> - WorldMap -> - FilePath -> - m Scenario -loadScenarioFile em worldMap fileName = - (withThrow adaptError . (liftEither <=< sendIO)) $ - decodeFileEitherE (em, worldMap) fileName - where - adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml - -loadStandaloneScenario :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - FilePath -> - m (Scenario, (WorldMap, EntityMap, [Recipe Entity])) -loadStandaloneScenario fp = do - entities <- loadEntities - recipes <- loadRecipes entities - worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities - scene <- fst <$> loadScenario fp entities worlds - return (scene, (worlds, entities, recipes)) diff --git a/src/Swarm/Game/Scenario/Objective.hs b/src/Swarm/Game/Scenario/Objective.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Objective.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Game.Scenario.Objective where - -import Control.Applicative ((<|>)) -import Control.Lens hiding (from, (<.>)) -import Data.Aeson -import Data.Set qualified as Set -import Data.Text (Text) -import GHC.Generics (Generic) -import Servant.Docs (ToSample) -import Servant.Docs qualified as SD -import Swarm.Game.Achievement.Definitions -import Swarm.Game.Scenario.Objective.Logic as L -import Swarm.Language.Pipeline (ProcessedTerm) -import Swarm.Language.Syntax (Syntax) -import Swarm.Language.Text.Markdown qualified as Markdown -import Swarm.Util.Lens (makeLensesNoSigs) - ------------------------------------------------------------- --- Scenario objectives ------------------------------------------------------------- - -data PrerequisiteConfig = PrerequisiteConfig - { previewable :: Bool - -- ^ Typically, only the currently "active" objectives are - -- displayed to the user in the Goals dialog. An objective - -- is "active" if all of its prerequisites are met. - -- - -- However, some objectives may be "high-level", in that they may - -- explain the broader intention behind potentially multiple - -- prerequisites. - -- - -- Set this option to 'True' to display this goal in the "upcoming" section even - -- if the objective has currently unmet prerequisites. - , logic :: Prerequisite ObjectiveLabel - -- ^ Boolean expression of dependencies upon other objectives. Variables in this expression - -- are the "id"s of other objectives, and become "true" if the corresponding objective is completed. - -- The "condition" of the objective at hand shall not be evaluated until its - -- prerequisite expression evaluates as 'True'. - -- - -- Note that the achievement of these objective dependencies is - -- persistent; once achieved, they still count even if their "condition" - -- might not still hold. The condition is never re-evaluated once true. - } - deriving (Eq, Show, Generic, ToJSON) - -instance FromJSON PrerequisiteConfig where - -- Parsing JSON/YAML 'PrerequisiteConfig' has a shorthand option - -- in which the boolean expression can be written directly, - -- bypassing the "logic" key. - -- Furthermore, an "Id" in a boolean expressions can be written - -- as a bare string without needing the "id" key. - parseJSON val = preLogic val <|> preObject val - where - preObject = withObject "prerequisite" $ \v -> - PrerequisiteConfig - <$> (v .:? "previewable" .!= False) - <*> v .: "logic" - preLogic = fmap (PrerequisiteConfig False) . parseJSON - --- | An objective is a condition to be achieved by a player in a --- scenario. -data Objective = Objective - { _objectiveGoal :: Markdown.Document Syntax - , _objectiveTeaser :: Maybe Text - , _objectiveCondition :: ProcessedTerm - , _objectiveId :: Maybe ObjectiveLabel - , _objectiveOptional :: Bool - , _objectivePrerequisite :: Maybe PrerequisiteConfig - , _objectiveHidden :: Bool - , _objectiveAchievement :: Maybe AchievementInfo - } - deriving (Eq, Show, Generic, ToJSON) - -makeLensesNoSigs ''Objective - -instance ToSample Objective where - toSamples _ = SD.noSamples - --- | An explanation of the goal of the objective, shown to the player --- during play. It is represented as a list of paragraphs. -objectiveGoal :: Lens' Objective (Markdown.Document Syntax) - --- | A very short (3-5 words) description of the goal for --- displaying on the left side of the Objectives modal. -objectiveTeaser :: Lens' Objective (Maybe Text) - --- | A winning condition for the objective, expressed as a --- program of type @cmd bool@. By default, this program will be --- run to completion every tick (the usual limits on the number --- of CESK steps per tick do not apply). -objectiveCondition :: Lens' Objective ProcessedTerm - --- | Optional name by which this objective may be referenced --- as a prerequisite for other objectives. -objectiveId :: Lens' Objective (Maybe Text) - --- | Indicates whether the objective is not required in order --- to "win" the scenario. Useful for (potentially hidden) achievements. --- If the field is not supplied, it defaults to False (i.e. the --- objective is mandatory to "win"). -objectiveOptional :: Lens' Objective Bool - --- | Dependencies upon other objectives -objectivePrerequisite :: Lens' Objective (Maybe PrerequisiteConfig) - --- | Whether the goal is displayed in the UI before completion. --- The goal will always be revealed after it is completed. --- --- This attribute often goes along with an Achievement. -objectiveHidden :: Lens' Objective Bool - --- | An optional achievement that is to be registered globally --- when this objective is completed. -objectiveAchievement :: Lens' Objective (Maybe AchievementInfo) - -instance FromJSON Objective where - parseJSON = withObject "objective" $ \v -> - Objective - <$> (v .:? "goal" .!= mempty) - <*> (v .:? "teaser") - <*> (v .: "condition") - <*> (v .:? "id") - <*> (v .:? "optional" .!= False) - <*> (v .:? "prerequisite") - <*> (v .:? "hidden" .!= False) - <*> (v .:? "achievement") - -data CompletionBuckets = CompletionBuckets - { incomplete :: [Objective] - , completed :: [Objective] - , unwinnable :: [Objective] - } - deriving (Show, Generic, FromJSON, ToJSON) - --- | TODO: #1044 Could also add an "ObjectiveFailed" constructor... -newtype Announcement - = ObjectiveCompleted Objective - deriving (Show, Generic, ToJSON) - -data ObjectiveCompletion = ObjectiveCompletion - { completionBuckets :: CompletionBuckets - -- ^ This is the authoritative "completion status" - -- for all objectives. - -- Note that there is a separate Set to store the - -- completion status of prerequisite objectives, which - -- must be carefully kept in sync with this. - -- Those prerequisite objectives are required to have - -- labels, but other objectives are not. - -- Therefore only prerequisites exist in the completion - -- map keyed by label. - , completedIDs :: Set.Set ObjectiveLabel - } - deriving (Show, Generic, FromJSON, ToJSON) - --- | Concatenates all incomplete and completed objectives. -listAllObjectives :: CompletionBuckets -> [Objective] -listAllObjectives (CompletionBuckets x y z) = x <> y <> z - -addCompleted :: Objective -> ObjectiveCompletion -> ObjectiveCompletion -addCompleted obj (ObjectiveCompletion buckets cmplIds) = - ObjectiveCompletion newBuckets newCmplById - where - newBuckets = - buckets - { completed = obj : completed buckets - } - newCmplById = case _objectiveId obj of - Nothing -> cmplIds - Just lbl -> Set.insert lbl cmplIds - -addUnwinnable :: Objective -> ObjectiveCompletion -> ObjectiveCompletion -addUnwinnable obj (ObjectiveCompletion buckets cmplIds) = - ObjectiveCompletion newBuckets cmplIds - where - newBuckets = - buckets - { unwinnable = obj : unwinnable buckets - } - -setIncomplete :: - ([Objective] -> [Objective]) -> - ObjectiveCompletion -> - ObjectiveCompletion -setIncomplete f (ObjectiveCompletion buckets cmplIds) = - ObjectiveCompletion newBuckets cmplIds - where - newBuckets = - buckets - { incomplete = f $ incomplete buckets - } - -addIncomplete :: Objective -> ObjectiveCompletion -> ObjectiveCompletion -addIncomplete obj = setIncomplete (obj :) - --- | Returns the "ObjectiveCompletion" with the "incomplete" goals --- extracted to a separate tuple member. --- This is intended as input to a "fold". -extractIncomplete :: ObjectiveCompletion -> (ObjectiveCompletion, [Objective]) -extractIncomplete oc = - (withoutIncomplete, incompleteGoals) - where - incompleteGoals = incomplete $ completionBuckets oc - withoutIncomplete = setIncomplete (const []) oc diff --git a/src/Swarm/Game/Scenario/Objective/Graph.hs b/src/Swarm/Game/Scenario/Objective/Graph.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Objective/Graph.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Utilities for performing graph analysis on Objective prerequisites -module Swarm.Game.Scenario.Objective.Graph where - -import Control.Arrow ((&&&)) -import Data.Aeson -import Data.BoolExpr (Signed (Positive)) -import Data.BoolExpr qualified as BE -import Data.Graph (Graph, SCC (AcyclicSCC), graphFromEdges, stronglyConnComp) -import Data.Map (Map) -import Data.Map.Strict qualified as M -import Data.Maybe (mapMaybe) -import Data.Set qualified as Set -import Data.Text qualified as T -import Data.Tuple (swap) -import GHC.Generics (Generic) -import Servant.Docs (ToSample) -import Servant.Docs qualified as SD -import Swarm.Game.Scenario.Objective -import Swarm.Game.Scenario.Objective.Logic as L -import Swarm.Game.Scenario.Objective.WinCheck - --- | This is only needed for constructing a Graph, --- which requires all nodes to have a key. -data ObjectiveId - = Label (Signed ObjectiveLabel) - | -- | for unlabeled objectives - Ordinal Int - deriving (Eq, Ord, Show, Generic, ToJSON) - -data GraphInfo = GraphInfo - { actualGraph :: Graph - , isAcyclic :: Bool - , sccInfo :: [SCC Objective] - , nodeIDs :: [ObjectiveId] - } - deriving (Show, Generic, ToJSON) - -instance ToJSON (SCC Objective) where - toJSON = String . T.pack . show - -instance ToJSON Graph where - toJSON = String . T.pack . show - -instance ToSample GraphInfo where - toSamples _ = SD.noSamples - -getConstFromSigned :: BE.Signed a -> a -getConstFromSigned = \case - BE.Positive x -> x - BE.Negative x -> x - --- | Collect all of the constants that have a negation. --- This is necessary for enumerating all of the distinct --- nodes when constructing a Graph, as we treat a constant --- and its negation as distinct nodes. -getNegatedIds :: [Objective] -> Map ObjectiveLabel Objective -getNegatedIds objs = - M.fromList $ mapMaybe f allConstants - where - objectivesById = getObjectivesById objs - - allPrereqExpressions = mapMaybe _objectivePrerequisite objs - allConstants = - mapMaybe onlyNegative - . Set.toList - . Set.unions - . map (getDistinctConstants . logic) - $ allPrereqExpressions - - f = sequenceA . \x -> (x, M.lookup x objectivesById) - - onlyNegative = \case - BE.Negative x -> Just x - _ -> Nothing - -getObjectivesById :: [Objective] -> Map ObjectiveLabel Objective -getObjectivesById objs = - M.fromList $ - map swap $ - mapMaybe (sequenceA . (id &&& _objectiveId)) objs - --- | Uses the textual labels for those objectives that --- have them, and assigns arbitrary integer IDs for --- the remaining. --- --- Only necessary for constructing a "Graph". -assignIds :: [Objective] -> Map ObjectiveId Objective -assignIds objs = - unlabeledObjsMap <> labeledObjsMap - where - objectivesById = getObjectivesById objs - - labeledObjsMap = M.mapKeys (Label . Positive) objectivesById - - unlabeledObjs = filter (null . _objectiveId) objs - unlabeledObjsMap = M.fromList $ zipWith (\x y -> (Ordinal x, y)) [0 ..] unlabeledObjs - -type Edges = [(Objective, ObjectiveId, [ObjectiveId])] - --- | NOTE: Based strictly on the goal labels, the graph could --- potentially contain a cycle, if there exist --- mutually-exclusive goals. That is, if goal A depends on the NOT --- of "goal B". Goal B could then also depend on "NOT Goal A" (re-enforcing the --- mutual-exclusivity), or it could mandate a completion order, e.g.: --- Goal A and Goal B are simultaneously available to pursue. However, if the --- player completes Goal B first, then it closes off the option to complete --- Goal A. However, if Goal A is completed first, then the user is also allowed --- to complete Goal B. --- --- To avoid a "cycle" in this circumstance, "A" needs to exist as a distinct node --- from "NOT A" in the graph. -makeGraph :: Edges -> Graph -makeGraph edges = - myGraph - where - (myGraph, _, _) = graphFromEdges edges - -makeGraphEdges :: [Objective] -> Edges -makeGraphEdges objectives = - rootTuples <> negatedTuples - where - rootTuples = map f $ M.toList $ assignIds objectives - negatedTuples = map gg $ M.toList $ getNegatedIds objectives - gg (k, v) = (v, Label $ BE.Negative k, []) - - f (k, v) = (v, k, maybe [] (map Label . g) $ _objectivePrerequisite v) - g = Set.toList . getDistinctConstants . logic - -isAcyclicGraph :: [SCC Objective] -> Bool -isAcyclicGraph = - all isAcyclicVertex - where - isAcyclicVertex = \case - AcyclicSCC _ -> True - _ -> False - -makeGraphInfo :: ObjectiveCompletion -> GraphInfo -makeGraphInfo oc = - GraphInfo - (makeGraph edges) - (isAcyclicGraph connectedComponents) - connectedComponents - (M.keys $ assignIds objs) - where - edges = makeGraphEdges objs - connectedComponents = stronglyConnComp edges - objs = listAllObjectives $ completionBuckets oc diff --git a/src/Swarm/Game/Scenario/Objective/Logic.hs b/src/Swarm/Game/Scenario/Objective/Logic.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Objective/Logic.hs +++ /dev/null @@ -1,49 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A model for defining boolean expressions for Objective prerequisites. --- --- This model is intended to be user-facing in the .yaml files, and is --- distinct from that in 'Data.BoolExpr'. -module Swarm.Game.Scenario.Objective.Logic where - -import Control.Applicative ((<|>)) -import Data.Aeson -import Data.BoolExpr -import Data.Char (toLower) -import Data.List.NonEmpty (NonEmpty) -import Data.Text (Text) -import GHC.Generics (Generic) - -type ObjectiveLabel = Text - --- | In contrast with the "BoolExpr" type, --- "And" and "Or" can have /one or more/ children --- instead of /exactly two/. -data Prerequisite a - = And (NonEmpty (Prerequisite a)) - | Or (NonEmpty (Prerequisite a)) - | Not (Prerequisite a) - | Id a - deriving (Eq, Show, Generic, Functor, Foldable) - -prerequisiteOptions :: Options -prerequisiteOptions = - defaultOptions - { sumEncoding = ObjectWithSingleField - , constructorTagModifier = map toLower - } - -instance ToJSON (Prerequisite ObjectiveLabel) where - toJSON = genericToJSON prerequisiteOptions - -instance FromJSON (Prerequisite ObjectiveLabel) where - parseJSON x = preString x <|> genericParseJSON prerequisiteOptions x - where - preString = withText "prerequisite" $ pure . Id - -toBoolExpr :: Prerequisite a -> BoolExpr a -toBoolExpr (And xs) = foldr1 BAnd (fmap toBoolExpr xs) -toBoolExpr (Or xs) = foldr1 BOr (fmap toBoolExpr xs) -toBoolExpr (Not x) = BNot $ toBoolExpr x -toBoolExpr (Id x) = BConst $ pure x diff --git a/src/Swarm/Game/Scenario/Objective/Validation.hs b/src/Swarm/Game/Scenario/Objective/Validation.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Objective/Validation.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Validity checking for 'Objective' prerequisites -module Swarm.Game.Scenario.Objective.Validation where - -import Control.Monad (unless) -import Data.Foldable (for_, toList) -import Data.Graph (stronglyConnComp) -import Data.Maybe (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) - --- | Performs monadic validation before returning --- the "pure" construction of a wrapper record. --- This validation entails: --- --- 1. Ensuring that all goal references utilized in prerequisites --- actually exist --- 2. Ensuring that the graph of dependencies is acyclic. -validateObjectives :: - MonadFail m => - [Objective] -> - m [Objective] -validateObjectives objectives = do - for_ objectives $ \x -> case _objectivePrerequisite x 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 () - - unless (isAcyclicGraph connectedComponents) $ - failT ["There are dependency cycles in the prerequisites."] - - return objectives - where - connectedComponents = stronglyConnComp $ makeGraphEdges objectives - allIds = Set.fromList $ mapMaybe _objectiveId objectives diff --git a/src/Swarm/Game/Scenario/Objective/WinCheck.hs b/src/Swarm/Game/Scenario/Objective/WinCheck.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Objective/WinCheck.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Utilities to check whether conditions are met for a game win/loss. -module Swarm.Game.Scenario.Objective.WinCheck where - -import Data.Aeson -import Data.BoolExpr qualified as BE -import Data.BoolExpr.Simplify qualified as Simplify -import Data.List (partition) -import Data.Map qualified as M -import Data.Set (Set) -import Data.Set qualified as Set -import GHC.Generics (Generic) -import Servant.Docs (ToSample) -import Servant.Docs qualified as SD -import Swarm.Game.Scenario.Objective -import Swarm.Game.Scenario.Objective.Logic as L - --- | We have "won" if all of the "unwinnable" or remaining "incomplete" objectives are "optional". -didWin :: ObjectiveCompletion -> Bool -didWin oc = all _objectiveOptional $ incomplete buckets <> unwinnable buckets - where - buckets = completionBuckets oc - --- | We have "lost" if any of the "unwinnable" objectives not "optional". -didLose :: ObjectiveCompletion -> Bool -didLose oc = not $ all _objectiveOptional $ unwinnable buckets - where - buckets = completionBuckets oc - -isPrereqsSatisfied :: ObjectiveCompletion -> Objective -> Bool -isPrereqsSatisfied completions = - maybe True f . _objectivePrerequisite - where - f = BE.evalBoolExpr getTruth . L.toBoolExpr . logic - - getTruth :: ObjectiveLabel -> Bool - getTruth label = Set.member label $ completedIDs completions - -isUnwinnablePrereq :: Set ObjectiveLabel -> Prerequisite ObjectiveLabel -> Bool -isUnwinnablePrereq completedObjectives = - Simplify.cannotBeTrue . Simplify.replace boolMap . L.toBoolExpr - where - boolMap = - M.fromList $ - map (,True) $ - Set.toList completedObjectives - -isUnwinnable :: ObjectiveCompletion -> Objective -> Bool -isUnwinnable completions obj = - maybe False (isUnwinnablePrereq (completedIDs completions) . logic) $ _objectivePrerequisite obj - --- | The first element of the returned tuple consists of "active" objectives, --- the second element "inactive". -partitionActiveObjectives :: ObjectiveCompletion -> ([Objective], [Objective]) -partitionActiveObjectives oc = - partition (isPrereqsSatisfied oc) $ - incomplete $ - completionBuckets oc - -getActiveObjectives :: ObjectiveCompletion -> [Objective] -getActiveObjectives = - fst . partitionActiveObjectives - -deriving instance Generic (BE.Signed ObjectiveLabel) -deriving instance ToJSON (BE.Signed ObjectiveLabel) - --- | For debugging only (via Web API) -data PrereqSatisfaction = PrereqSatisfaction - { objective :: Objective - , deps :: Set (BE.Signed ObjectiveLabel) - , prereqsSatisfied :: Bool - } - deriving (Generic, ToJSON) - -instance ToSample PrereqSatisfaction where - toSamples _ = SD.noSamples - --- | Used only by the web interface for debugging -getSatisfaction :: ObjectiveCompletion -> [PrereqSatisfaction] -getSatisfaction oc = - map f $ - listAllObjectives $ - completionBuckets oc - where - f y = - PrereqSatisfaction - y - (maybe mempty (getDistinctConstants . logic) $ _objectivePrerequisite y) - (isPrereqsSatisfied oc y) - -getDistinctConstants :: (Ord a) => Prerequisite a -> Set (BE.Signed a) -getDistinctConstants = Set.fromList . BE.constants . toBoolExpr diff --git a/src/Swarm/Game/Scenario/RobotLookup.hs b/src/Swarm/Game/Scenario/RobotLookup.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/RobotLookup.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Game.Scenario.RobotLookup where - -import Control.Lens hiding (from, (<.>)) -import Data.Aeson (FromJSON) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics (Generic) -import Swarm.Game.Entity -import Swarm.Game.Robot (TRobot, trobotName) -import Swarm.Util (failT, quote) -import Swarm.Util.Yaml - ------------------------------------------------------------- --- Robot map ------------------------------------------------------------- - -newtype RobotName = RobotName Text - deriving (Show, Eq, Ord, Generic, FromJSON) - --- | A robot template paired with its definition's index within --- the Scenario file -type IndexedTRobot = (Int, TRobot) - --- | A map from names to robots, used to look up robots in scenario --- descriptions. -type RobotMap = Map RobotName IndexedTRobot - --- | Create a 'RobotMap' from a list of robot templates. -buildRobotMap :: [TRobot] -> RobotMap -buildRobotMap rs = M.fromList $ zipWith (\x y -> (RobotName $ view trobotName y, (x, y))) [0 ..] rs - ------------------------------------------------------------- --- Lookup utilities ------------------------------------------------------------- - --- | Look up a thing by name, throwing a parse error if it is not --- found. -getThing :: Show k => Text -> (k -> m -> Maybe a) -> k -> ParserE m a -getThing thing lkup name = do - m <- getE - case lkup name m of - Nothing -> failT ["Unknown", thing, "name:", quote $ T.pack $ show name] - Just a -> return a - --- | Look up an entity by name in an 'EntityMap', throwing a parse --- error if it is not found. -getEntity :: Text -> ParserE EntityMap Entity -getEntity = getThing "entity" lookupEntityName - --- | Look up a robot by name in a 'RobotMap', throwing a parse error --- if it is not found. -getRobot :: RobotName -> ParserE RobotMap IndexedTRobot -getRobot = getThing "robot" M.lookup diff --git a/src/Swarm/Game/Scenario/Scoring/Best.hs b/src/Swarm/Game/Scenario/Scoring/Best.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Scoring/Best.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Types and records for updating and retrieving --- the best scores for a scenario. -module Swarm.Game.Scenario.Scoring.Best where - -import Control.Arrow ((&&&)) -import Control.Lens hiding (from, (<.>)) -import Data.Aeson ( - genericParseJSON, - genericToEncoding, - genericToJSON, - ) -import Data.Function (on) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import Data.Time (ZonedTime, zonedTimeToUTC) -import Data.Yaml as Y -import GHC.Generics (Generic) -import Swarm.Game.Scenario.Scoring.CodeSize -import Swarm.Game.Scenario.Scoring.ConcreteMetrics -import Swarm.Game.Scenario.Scoring.GenericMetrics -import Swarm.Util.Lens (makeLensesNoSigs) - --- * Some orphan ZonedTime instances - -instance Eq ZonedTime where - (==) = (==) `on` zonedTimeToUTC - -instance Ord ZonedTime where - (<=) = (<=) `on` zonedTimeToUTC - --- * High scores by various criteria - -data BestByCriteria - = BestByTime - | BestByTicks - | BestByCharCount - | BestByAstSize - deriving (Eq, Ord, Bounded, Enum, Show) - -describeCriteria :: BestByCriteria -> Text -describeCriteria = \case - BestByTime -> "time" - BestByTicks -> "ticks" - BestByCharCount -> "char count" - BestByAstSize -> "AST size" - -data ProgressStats = ProgressStats - { _scenarioStarted :: ZonedTime - -- ^ Time when the scenario was started including time zone. - , _scenarioAttemptMetrics :: AttemptMetrics - } - deriving (Eq, Ord, Show, Read, Generic) - -makeLenses ''ProgressStats - -instance FromJSON ProgressStats where - parseJSON = genericParseJSON scenarioOptions - -instance ToJSON ProgressStats where - toEncoding = genericToEncoding scenarioOptions - toJSON = genericToJSON scenarioOptions - -type ProgressMetric = Metric ProgressStats - --- * High scores by various criteria - -data BestRecords = BestRecords - { _scenarioBestByTime :: ProgressMetric - , _scenarioBestByTicks :: ProgressMetric - , _scenarioBestByCharCount :: ProgressMetric - , _scenarioBestByAstSize :: ProgressMetric - } - deriving (Eq, Ord, Read, Generic) - -instance Show BestRecords where - show (BestRecords a b c d) = - unlines $ - map - angleBracket - [ show a - , show b - , show c - , show d - ] - where - angleBracket :: String -> String - angleBracket x = "<" <> x <> ">" - -emptyBest :: ZonedTime -> BestRecords -emptyBest t = BestRecords x x x x - where - x = Metric Attempted $ ProgressStats t emptyAttemptMetric - -updateBest :: ProgressMetric -> BestRecords -> BestRecords -updateBest newPlayMetric (BestRecords oldA oldB oldC oldD) = - BestRecords - (bestTime oldA scenarioElapsed) - (bestTime oldB scenarioElapsedTicks) - (bestSize oldC sourceTextLength) - (bestSize oldD astSize) - where - f x y = chooseBetter y newPlayMetric x - bestTime x y = f x (Just . view (scenarioAttemptMetrics . scenarioDurationMetrics . y)) - bestSize x y = f x (fmap y . view (scenarioAttemptMetrics . scenarioCodeMetrics)) - -makeLensesNoSigs ''BestRecords - --- | The best status of the scenario, measured in real world time. -scenarioBestByTime :: Lens' BestRecords ProgressMetric - --- | The best status of the scenario, measured in game ticks. -scenarioBestByTicks :: Lens' BestRecords ProgressMetric - --- | The best code size of the scenario, measured in character count. -scenarioBestByCharCount :: Lens' BestRecords ProgressMetric - --- | The best code size of the scenario, measured in AST size. -scenarioBestByAstSize :: Lens' BestRecords ProgressMetric - -instance FromJSON BestRecords where - parseJSON = genericParseJSON scenarioOptions - -instance ToJSON BestRecords where - toEncoding = genericToEncoding scenarioOptions - toJSON = genericToJSON scenarioOptions - --- | Uses the start time of the play-attempt to de-dupe --- records that are from the same game. The start time should --- be sufficient to uniquely identify a game. -getBestGroups :: - BestRecords -> - [(Metric ProgressStats, NonEmpty BestByCriteria)] -getBestGroups = - rearrangeTuples . M.toList . bestToMap - where - groupByStartTime = NE.groupAllWith $ view scenarioStarted . getMetric . snd - rearrangeTuples = map (snd . NE.head &&& NE.map fst) . groupByStartTime - - bestToMap :: BestRecords -> Map BestByCriteria ProgressMetric - bestToMap (BestRecords t1 t2 s1 s2) = - M.fromList $ durationElements <> mapMaybe (traverse ensurePresent) codeSizeElements - where - durationElements = - [ (BestByTime, t1) - , (BestByTicks, t2) - ] - codeSizeElements = - [ (BestByCharCount, s1) - , (BestByAstSize, s2) - ] - - ensurePresent x = - (getMetric x ^. scenarioAttemptMetrics . scenarioCodeMetrics) >> Just x diff --git a/src/Swarm/Game/Scenario/Scoring/CodeSize.hs b/src/Swarm/Game/Scenario/Scoring/CodeSize.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Scoring/CodeSize.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Types and utilities to compute code size --- in terms of textual length and AST nodes. -module Swarm.Game.Scenario.Scoring.CodeSize where - -import Control.Monad (guard) -import Data.Aeson -import GHC.Generics (Generic) -import Swarm.Language.Module -import Swarm.Language.Pipeline -import Swarm.Language.Syntax - -data CodeSizeDeterminators = CodeSizeDeterminators - { initialCode :: Maybe ProcessedTerm - , hasUsedREPL :: Bool - } - deriving (Show) - -data ScenarioCodeMetrics = ScenarioCodeMetrics - { sourceTextLength :: Int - , astSize :: Int - } - deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON) - -codeSizeFromDeterminator :: CodeSizeDeterminators -> Maybe ScenarioCodeMetrics -codeSizeFromDeterminator (CodeSizeDeterminators maybeInitialCode usedRepl) = do - guard $ not usedRepl - ProcessedTerm (Module s@(Syntax' srcLoc _ _) _) _ _ <- maybeInitialCode - return $ ScenarioCodeMetrics (charCount srcLoc) (measureAstSize s) - where - charCount :: SrcLoc -> Int - charCount NoLoc = 0 - charCount (SrcLoc start end) = end - start diff --git a/src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs b/src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Data types and instances for specific scoring methods -module Swarm.Game.Scenario.Scoring.ConcreteMetrics where - -import Control.Lens hiding (from, (<.>)) -import Data.Aeson -import Data.Char (toLower) -import Data.Time (NominalDiffTime) -import GHC.Generics (Generic) -import Swarm.Game.CESK (TickNumber (..)) -import Swarm.Game.Scenario.Scoring.CodeSize - -scenarioOptions :: Options -scenarioOptions = - defaultOptions - { fieldLabelModifier = map toLower . drop (length ("_scenario" :: String)) - } - -data DurationMetrics = DurationMetrics - { _scenarioElapsed :: NominalDiffTime - -- ^ Time elapsed until winning the scenario. - , _scenarioElapsedTicks :: TickNumber - -- ^ Ticks elapsed until winning the scenario. - } - deriving (Eq, Ord, Show, Read, Generic) - -makeLenses ''DurationMetrics - -emptyDurationMetric :: DurationMetrics -emptyDurationMetric = DurationMetrics 0 $ TickNumber 0 - -instance FromJSON DurationMetrics where - parseJSON = genericParseJSON scenarioOptions - -instance ToJSON DurationMetrics where - toEncoding = genericToEncoding scenarioOptions - toJSON = genericToJSON scenarioOptions - -data AttemptMetrics = AttemptMetrics - { _scenarioDurationMetrics :: DurationMetrics - , _scenarioCodeMetrics :: Maybe ScenarioCodeMetrics - -- ^ Size of the user's program. - } - deriving (Eq, Ord, Show, Read, Generic) - -emptyAttemptMetric :: AttemptMetrics -emptyAttemptMetric = AttemptMetrics emptyDurationMetric Nothing - -makeLenses ''AttemptMetrics - -instance FromJSON AttemptMetrics where - parseJSON = genericParseJSON scenarioOptions - -instance ToJSON AttemptMetrics where - toEncoding = genericToEncoding scenarioOptions - toJSON = genericToJSON scenarioOptions diff --git a/src/Swarm/Game/Scenario/Scoring/GenericMetrics.hs b/src/Swarm/Game/Scenario/Scoring/GenericMetrics.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Scoring/GenericMetrics.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Data types and functions applicable across different --- scoring methods. -module Swarm.Game.Scenario.Scoring.GenericMetrics where - -import Data.Aeson -import Data.Ord (Down (Down)) -import GHC.Generics (Generic) -import Swarm.Util (maxOn) - --- | This is a subset of the "ScenarioStatus" type --- that excludes the "NotStarted" case. -data Progress - = Attempted - | Completed - deriving (Eq, Ord, Show, Read, Generic) - -untaggedJsonOptions :: Options -untaggedJsonOptions = - defaultOptions - { sumEncoding = UntaggedValue - } - -instance FromJSON Progress where - parseJSON = genericParseJSON untaggedJsonOptions - -instance ToJSON Progress where - toJSON = genericToJSON untaggedJsonOptions - -data Metric a = Metric Progress a - deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON) - -getMetric :: Metric a -> a -getMetric (Metric _ x) = x - --- | This encodes the notion of "more play is better" --- for incomplete games (rationale: more play = more fun), --- whereas "smaller inputs are better" for completed games. --- --- Since 'Maybe' has its own 'Ord' instance where --- @Nothing < Just x@ regardless of @x@, when we want to --- choose the minimum value we @fmap Down@ to ensure that --- the 'Just' is selected while inverting the ordering of --- the inner member. -chooseBetter :: - Ord a => - -- | criteria; record field extractor - (b -> Maybe a) -> - -- | x - Metric b -> - -- | y - Metric b -> - Metric b -chooseBetter criteria (Metric Attempted x) (Metric Attempted y) = - Metric Attempted $ maxOn criteria x y -chooseBetter criteria (Metric Completed x) (Metric Completed y) = - Metric Completed $ maxOn (fmap Down . criteria) x y --- Having exhausted the possibilities where either both --- are Completed or both are Attempted, now we can just --- choose the Completed one. -chooseBetter _ x@(Metric Completed _) _ = x -chooseBetter _ _ y@(Metric Completed _) = y diff --git a/src/Swarm/Game/Scenario/Status.hs b/src/Swarm/Game/Scenario/Status.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Status.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- High-level status of scenario play. --- Representation of progress, logic for updating. -module Swarm.Game.Scenario.Status where - -import Control.Lens hiding (from, (<.>)) -import Data.Aeson ( - genericParseJSON, - genericToEncoding, - genericToJSON, - ) -import Data.Function (on) -import Data.Time (ZonedTime, diffUTCTime, zonedTimeToUTC) -import Data.Yaml as Y -import GHC.Generics (Generic) -import Swarm.Game.CESK (TickNumber) -import Swarm.Game.Scenario -import Swarm.Game.Scenario.Scoring.Best -import Swarm.Game.Scenario.Scoring.CodeSize -import Swarm.Game.Scenario.Scoring.ConcreteMetrics -import Swarm.Game.Scenario.Scoring.GenericMetrics -import Swarm.Game.World.Gen (Seed) -import Swarm.Util.Lens (makeLensesNoSigs) - --- | These launch parameters are used in a number of ways: --- --- * Serializing the seed/script path for saves --- * Holding parse status from form fields, including error info --- * Carrying fully-validated launch parameters. --- --- Type parameters are utilized to support all of these use cases. -data ParameterizableLaunchParams code f = LaunchParams - { seedVal :: f (Maybe Seed) - , initialCode :: f (Maybe code) - } - -type SerializableLaunchParams = ParameterizableLaunchParams FilePath Identity -deriving instance Eq SerializableLaunchParams -deriving instance Ord SerializableLaunchParams -deriving instance Show SerializableLaunchParams -deriving instance Read SerializableLaunchParams -deriving instance Generic SerializableLaunchParams -deriving instance FromJSON SerializableLaunchParams -deriving instance ToJSON SerializableLaunchParams - --- | A 'ScenarioStatus' stores the status of a scenario along with --- appropriate metadata: 'NotStarted', or 'Played'. --- The 'Played' status has two sub-states: 'Attempted' or 'Completed'. -data ScenarioStatus - = NotStarted - | Played - SerializableLaunchParams - ProgressMetric - BestRecords - deriving (Eq, Ord, Show, Read, Generic) - -instance FromJSON ScenarioStatus where - parseJSON = genericParseJSON scenarioOptions - -instance ToJSON ScenarioStatus where - toEncoding = genericToEncoding scenarioOptions - toJSON = genericToJSON scenarioOptions - -emptyLaunchParams :: Applicative f => ParameterizableLaunchParams a f -emptyLaunchParams = LaunchParams (pure Nothing) (pure Nothing) - -getLaunchParams :: ScenarioStatus -> SerializableLaunchParams -getLaunchParams = \case - NotStarted -> emptyLaunchParams - Played x _ _ -> x - --- | 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 - , _scenarioStatus :: ScenarioStatus - } - deriving (Eq, Ord, Show, Read, Generic) - -instance FromJSON ScenarioInfo where - parseJSON = genericParseJSON scenarioOptions - -instance ToJSON ScenarioInfo where - toEncoding = genericToEncoding scenarioOptions - toJSON = genericToJSON scenarioOptions - -type ScenarioInfoPair = (Scenario, ScenarioInfo) - -makeLensesNoSigs ''ScenarioInfo - --- | The path of the scenario, relative to @data/scenarios@. -scenarioPath :: Lens' ScenarioInfo FilePath - --- | The status of the scenario. -scenarioStatus :: Lens' ScenarioInfo ScenarioStatus - --- | Update the current 'ScenarioInfo' record when quitting a game. --- --- Note that when comparing \"best\" times, shorter is not always better! --- As long as the scenario is not completed (e.g. some do not have win condition) --- we consider having fun /longer/ to be better. -updateScenarioInfoOnFinish :: - CodeSizeDeterminators -> - ZonedTime -> - TickNumber -> - Bool -> - ScenarioInfo -> - ScenarioInfo -updateScenarioInfoOnFinish - csd - z - ticks - completed - si@(ScenarioInfo p prevPlayState) = case prevPlayState of - Played launchParams (Metric _ (ProgressStats start _currentPlayMetrics)) prevBestRecords -> - ScenarioInfo p $ - Played launchParams newPlayMetric $ - updateBest newPlayMetric prevBestRecords - where - el = (diffUTCTime `on` zonedTimeToUTC) z start - cs = codeSizeFromDeterminator csd - newCompletionFlag = if completed then Completed else Attempted - newPlayMetric = - Metric newCompletionFlag $ - ProgressStats start $ - AttemptMetrics (DurationMetrics el ticks) cs - _ -> si diff --git a/src/Swarm/Game/Scenario/Style.hs b/src/Swarm/Game/Scenario/Style.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Style.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Types for styling custom entity attributes -module Swarm.Game.Scenario.Style where - -import Data.Aeson -import Data.Set (Set) -import Data.Text (Text) -import GHC.Generics (Generic) - -data StyleFlag - = Standout - | Italic - | Strikethrough - | Underline - | ReverseVideo - | Blink - | Dim - | Bold - deriving (Eq, Ord, Show, Generic) - -styleFlagJsonOptions :: Options -styleFlagJsonOptions = - defaultOptions - { sumEncoding = UntaggedValue - } - -instance FromJSON StyleFlag where - parseJSON = genericParseJSON styleFlagJsonOptions - -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, Show, Generic, FromJSON, ToJSON) - -data CustomAttr = CustomAttr - { name :: String - , fg :: Maybe HexColor - , bg :: Maybe HexColor - , style :: Maybe (Set StyleFlag) - } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CustomAttr where - toJSON = - genericToJSON - defaultOptions - { omitNothingFields = True - } diff --git a/src/Swarm/Game/Scenario/Topography/Area.hs b/src/Swarm/Game/Scenario/Topography/Area.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/Area.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Game.Scenario.Topography.Area where - -import Data.Int (Int32) -import Data.List qualified as L -import Data.Maybe (listToMaybe) -import Linear (V2 (..)) -import Swarm.Game.Location - --- | Height and width of a 2D map region -data AreaDimensions = AreaDimensions - { rectWidth :: Int32 - , rectHeight :: Int32 - } - -renderRectDimensions :: AreaDimensions -> String -renderRectDimensions (AreaDimensions w h) = - L.intercalate "x" $ map show [w, h] - -invertY :: V2 Int32 -> V2 Int32 -invertY (V2 x y) = V2 x (-y) - --- | Incorporates an offset by @-1@, since the area is --- "inclusive" of the lower-right coordinate. --- Inverse of 'cornersToArea'. -upperLeftToBottomRight :: AreaDimensions -> Location -> Location -upperLeftToBottomRight (AreaDimensions w h) upperLeft = - upperLeft .+^ displacement - where - displacement = invertY $ subtract 1 <$> V2 w h - --- | Converts the displacement vector between the two --- diagonal corners of the rectangle into an 'AreaDimensions' record. --- Adds one to both dimensions since the corner coordinates are "inclusive". --- Inverse of 'upperLeftToBottomRight'. -cornersToArea :: Location -> Location -> AreaDimensions -cornersToArea upperLeft lowerRight = - AreaDimensions x y - where - V2 x y = (+ 1) <$> invertY (lowerRight .-. upperLeft) - --- | Has zero width or height. -isEmpty :: AreaDimensions -> Bool -isEmpty (AreaDimensions w h) = w == 0 || h == 0 - --- | Extracts the dimensions of a map grid. -getAreaDimensions :: [[a]] -> AreaDimensions -getAreaDimensions cellGrid = - AreaDimensions w h - where - w = fromIntegral $ maybe 0 length $ listToMaybe cellGrid -- column count - h = fromIntegral $ length cellGrid -- row count diff --git a/src/Swarm/Game/Scenario/Topography/Cell.hs b/src/Swarm/Game/Scenario/Topography/Cell.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/Cell.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Game.Scenario.Topography.Cell ( - PCell (..), - Cell, - AugmentedCell (..), - CellPaintDisplay, -) where - -import Control.Lens hiding (from, (.=), (<.>)) -import Control.Monad.Extra (mapMaybeM) -import Data.List.NonEmpty qualified as NE -import Data.Maybe (catMaybes, listToMaybe) -import Data.Text (Text) -import Data.Vector qualified as V -import Data.Yaml as Y -import Swarm.Game.Entity hiding (empty) -import Swarm.Game.Scenario.RobotLookup -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig) -import Swarm.Game.Terrain -import Swarm.Util.Erasable (Erasable (..)) -import Swarm.Util.Yaml - ------------------------------------------------------------- --- World cells ------------------------------------------------------------- - --- | A single cell in a world map, which contains a terrain value, --- and optionally an entity and robot. --- It is parameterized on the 'Entity' type to facilitate less --- stateful versions of the 'Entity' type in rendering scenario data. -data PCell e = Cell - { cellTerrain :: TerrainType - , cellEntity :: Erasable e - , cellRobots :: [IndexedTRobot] - } - deriving (Eq, Show) - --- | A single cell in a world map, which contains a terrain value, --- and optionally an entity and robot. -type Cell = PCell Entity - --- | Supplements a cell with waypoint information -data AugmentedCell e = AugmentedCell - { waypointCfg :: Maybe WaypointConfig - , standardCell :: PCell e - } - deriving (Eq, Show) - --- | Re-usable serialization for variants of 'PCell' -mkPCellJson :: ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value -mkPCellJson modifier x = - toJSON $ - catMaybes - [ Just . toJSON . getTerrainWord $ cellTerrain x - , fmap toJSON . modifier $ cellEntity x - , listToMaybe [] - ] - -instance ToJSON Cell where - toJSON = mkPCellJson $ \case - EErase -> Just "erase" - ENothing -> Nothing - EJust e -> Just (e ^. entityName) - -instance FromJSONE (EntityMap, RobotMap) Cell where - parseJSONE = withArrayE "tuple" $ \v -> do - let tupRaw = V.toList v - tup <- case NE.nonEmpty tupRaw of - Nothing -> fail "palette entry must have nonzero length (terrain, optional entity and then robots if any)" - Just x -> return x - - terr <- liftE $ parseJSON (NE.head tup) - - ent <- case tup ^? ix 1 of - Nothing -> return ENothing - Just e -> do - meName <- liftE $ parseJSON @(Maybe Text) e - case meName of - Nothing -> return ENothing - Just "erase" -> return EErase - Just name -> fmap EJust . localE fst $ getEntity name - - let name2rob r = do - mrName <- liftE $ parseJSON @(Maybe RobotName) r - traverse (localE snd . getRobot) mrName - - robs <- mapMaybeM name2rob (drop 2 tupRaw) - - return $ Cell terr ent robs - --- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'. The --- entity and robot, if present, are immediately looked up and --- converted into 'Entity' and 'TRobot' values. If they are not --- found, a parse error results. -instance FromJSONE (EntityMap, RobotMap) (AugmentedCell Entity) where - parseJSONE x = case x of - Object v -> objParse v - z -> AugmentedCell Nothing <$> parseJSONE z - where - objParse v = - AugmentedCell - <$> liftE (v .:? "waypoint") - <*> v - ..: "cell" - ------------------------------------------------------------- --- World editor ------------------------------------------------------------- - --- | Stateless cells used for the World Editor. --- These cells contain the bare minimum display information --- for rendering. -type CellPaintDisplay = PCell EntityFacade - --- Note: This instance is used only for the purpose of 'WorldPalette' -instance ToJSON CellPaintDisplay where - toJSON = mkPCellJson $ \case - ENothing -> Nothing - EErase -> Just $ EntityFacade "erase" mempty - EJust e -> Just e diff --git a/src/Swarm/Game/Scenario/Topography/EntityFacade.hs b/src/Swarm/Game/Scenario/Topography/EntityFacade.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/EntityFacade.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DerivingVia #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Stand-in type for an "Entity" for purposes --- that do not require carrying around the entire state --- of an Entity. --- --- Useful for simplified serialization, debugging, --- and equality checking, particularly for the World Editor. -module Swarm.Game.Scenario.Topography.EntityFacade where - -import Control.Lens ((^.)) -import Data.Yaml as Y (ToJSON (toJSON)) -import Swarm.Game.Display (Display) -import Swarm.Game.Entity qualified as E - --- | This datatype is a lightweight stand-in for the --- full-fledged "Entity" type without the baggage of all --- of its other fields. --- It contains the bare minimum display information --- for rendering. -data EntityFacade = EntityFacade E.EntityName Display - deriving (Eq) - --- Note: This instance is used only for the purpose of WorldPalette -instance ToJSON EntityFacade where - toJSON (EntityFacade eName _display) = toJSON eName - -mkFacade :: E.Entity -> EntityFacade -mkFacade e = - EntityFacade - (e ^. E.entityName) - (e ^. E.entityDisplay) diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Type definitions and validation logic for portals. --- --- Portals can be inter-world or intra-world. --- It is legal for a portal exit to be on the same cell as its entrance. --- --- By default, passage through a portal preserves the orientation --- of the robot, but an extra portal parameter can specify --- that the robot should be re-oriented. -module Swarm.Game.Scenario.Topography.Navigation.Portal where - -import Control.Arrow ((&&&)) -import Control.Lens (view) -import Control.Monad (forM, forM_, unless) -import Data.Aeson -import Data.Bifunctor (first) -import Data.BoolExpr (Signed (..)) -import Data.Function (on) -import Data.Functor.Identity -import Data.Int (Int32) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Text qualified as T -import Data.Tuple (swap) -import GHC.Generics (Generic) -import Linear (V2, negated) -import Swarm.Game.Location -import Swarm.Game.Scenario.Topography.Navigation.Waypoint -import Swarm.Game.Universe -import Swarm.Language.Direction -import Swarm.Util (allEqual, binTuples, both, failT, quote, showT) - -type WaypointMap = M.Map WaypointName (NonEmpty Location) - -data AnnotatedDestination a = AnnotatedDestination - { enforceConsistency :: Bool - , reorientation :: Direction - , destination :: Cosmic a - } - deriving (Show, Eq) - --- | Parameterized on waypoint dimensionality ('additionalDimension') and --- on the portal location specification method ('portalExitLoc'). --- --- == @additionalDimension@ --- As a member of the 'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription', waypoints are only known within a --- a single subworld, so 'additionalDimension' is 'Identity' for the map --- of waypoint names to planar locations. --- At the Scenario level, in contrast, we have access to all subworlds, so --- we nest this map to planar locations in additional mapping layer by subworld. --- --- == @portalExitLoc@ --- At the subworld parsing level, we only can obtain the planar location --- for portal /entrances/, but the /exits/ remain as waypoint names. --- At the Scenario-parsing level, we finally have --- access to the waypoints across all subworlds, and can therefore translate --- the portal exits to concrete planar locations. -data Navigation additionalDimension portalExitLoc = Navigation - { waypoints :: additionalDimension WaypointMap - -- ^ Note that waypoints defined at the "root" level are still relative to - -- the top-left corner of the map rectangle; they are not in absolute world - -- coordinates (as with applying the "ul" offset). - , portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc) - } - -deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b) -deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b) - -data PortalExit = PortalExit - { exit :: WaypointName - , subworldName :: Maybe SubworldName - -- ^ Note: 'Nothing' indicates that references a waypoint within the same subworld. - } - deriving (Show, Eq, Generic, FromJSON) - -data Portal = Portal - { entrance :: WaypointName - , exitInfo :: PortalExit - , consistent :: Bool - , reorient :: PlanarRelativeDir - } - deriving (Show, Eq) - -instance FromJSON Portal where - parseJSON = withObject "Portal" $ \v -> - Portal - <$> v - .: "entrance" - <*> v - .: "exitInfo" - <*> v .:? "consistent" .!= False - <*> v .:? "reorient" .!= DForward - -failUponDuplication :: - (MonadFail m, Show a, Show b) => - T.Text -> - M.Map a (NonEmpty b) -> - m () -failUponDuplication message binnedMap = - forM_ (listToMaybe $ M.toList duplicated) $ \(pIn, pOuts) -> - failT - [ "Waypoint" - , showT pIn - , message - , T.intercalate ", " $ map showT $ NE.toList pOuts - ] - where - duplicated = M.filter ((> 1) . NE.length) binnedMap - -failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a -failWaypointLookup (WaypointName rawName) = - maybe (failT ["No waypoint named", quote rawName]) return - --- | --- The following constraints must be enforced: --- --- * portals based on plural waypoint multiplicity can have multiple entrances but only a single exit --- * no two portals share the same entrance location --- * waypoint uniqueness within a subworld when the 'unique' flag is specified --- --- == Data flow --- --- Waypoints are defined within a subworld and are namespaced by it. --- Optional intra-subworld uniqueness of Waypoints is enforced at 'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription' --- parse time. --- Portals are declared within a subworld. The portal entrance must be a waypoint --- within this subworld. --- They can reference waypoints in other subworlds as exits, but these references --- are not validated until the Scenario parse level. --- --- * Since portal /entrances/ are specified at the subworld level, validation that --- no entrances overlap can also be performed at that level. --- * However, enforcement of single-multiplicity on portal /exits/ must be performed --- at scenario-parse level, because for a portal exit that references a waypoint in --- another subworld, we can't know at the single-'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription' level whether --- that waypoint has plural multiplicity. -validatePartialNavigation :: - (MonadFail m, Traversable t) => - SubworldName -> - Location -> - [Originated Waypoint] -> - t Portal -> - m (Navigation Identity WaypointName) -validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do - failUponDuplication "is required to be unique, but is duplicated in:" waypointsWithUniqueFlag - - nestedPortalPairs <- forM portalDefs $ \p -> do - let Portal entranceName (PortalExit exitName maybeExitSubworldName) isConsistent reOrient = p - -- Portals can have multiple entrances but only a single exit. - -- That is, the pairings of entries to exits must form a proper mathematical "function". - -- Multiple occurrences of entrance waypoints of a given name will result in - -- multiple portal entrances. - entranceLocs <- getLocs entranceName - - let sw = fromMaybe currentSubworldName maybeExitSubworldName - f = (,AnnotatedDestination isConsistent (DRelative $ DPlanar reOrient) $ Cosmic sw exitName) . extractLoc - return $ map f $ NE.toList entranceLocs - - let reconciledPortalPairs = concat nestedPortalPairs - - -- Aside from the enforcement of single-exit per portal, we apply another layer of - -- enforcement to ensure that no two portals share the same entrance location - failUponDuplication "has overlapping portal entrances exiting to" $ - binTuples reconciledPortalPairs - - return . Navigation (pure bareWaypoints) . M.fromList $ - map (first $ Cosmic currentSubworldName) reconciledPortalPairs - where - getLocs wpWrapper = failWaypointLookup wpWrapper $ M.lookup wpWrapper correctedWaypoints - - extractLoc (Originated _ (Waypoint _ loc)) = loc - correctedWaypoints = - binTuples $ - map - (\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint $ upperLeft .-. origin) x)) - unmergedWaypoints - bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints - waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints - -validatePortals :: - MonadFail m => - Navigation (M.Map SubworldName) WaypointName -> - m (M.Map (Cosmic Location) (AnnotatedDestination Location)) -validatePortals (Navigation wpUniverse partialPortals) = do - portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, AnnotatedDestination isConsistent reOrient portalExit@(Cosmic swName (WaypointName rawExitName))) -> do - firstExitLoc :| otherExits <- getLocs portalExit - unless (null otherExits) $ - failT - [ "Ambiguous exit waypoints named" - , quote rawExitName - , "for portal" - ] - return (portalEntrance, AnnotatedDestination isConsistent reOrient $ Cosmic swName firstExitLoc) - - ensureSpatialConsistency portalPairs - - return $ M.fromList portalPairs - where - getLocs (Cosmic swName wpWrapper@(WaypointName exitName)) = do - subworldWaypoints <- case M.lookup swName wpUniverse of - Just x -> return x - Nothing -> - failT - [ "Could not lookup waypoint" - , quote exitName - , "for portal exit because subworld" - , quote $ renderWorldName swName - , "does not exist" - ] - - failWaypointLookup wpWrapper $ - M.lookup wpWrapper subworldWaypoints - --- | A portal can be marked as \"consistent\", meaning that it represents --- a conventional physical passage rather than a \"magical\" teleportation. --- --- If there exists more than one \"consistent\" portal between the same --- two subworlds, then the portal locations must be spatially consistent --- between the two worlds. I.e. the space comprising the two subworlds --- forms a "conservative vector field". --- --- Verifying this is simple: --- For all of the portals between Subworlds A and B: --- --- * The coordinates of all \"consistent\" portal locations in Subworld A --- are subtracted from the corresponding coordinates in Subworld B. It --- does not matter which are exits vs. entrances. --- * The resulting \"vector\" from every pair must be equal. -ensureSpatialConsistency :: - MonadFail m => - [(Cosmic Location, AnnotatedDestination Location)] -> - m () -ensureSpatialConsistency xs = - unless (null nonUniform) $ - failT - [ "Non-uniform portal distances:" - , showT nonUniform - ] - where - consistentPairs :: [(Cosmic Location, Cosmic Location)] - consistentPairs = map (fmap destination) $ filter (enforceConsistency . snd) xs - - interWorldPairs :: [(Cosmic Location, Cosmic Location)] - interWorldPairs = filter (uncurry ((/=) `on` view subworld)) consistentPairs - - normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)] - normalizedOrdering = map normalizePairOrder interWorldPairs - - normalizePairOrder :: (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a) - normalizePairOrder pair = - if uncurry ((>) `on` view subworld) pair - then Negative $ swap pair - else Positive pair - - tuplify :: (Cosmic a, Cosmic a) -> ((SubworldName, SubworldName), (a, a)) - tuplify = both (view subworld) &&& both (view planar) - - getSigned :: Signed (V2 Int32) -> V2 Int32 - getSigned = \case - Positive x -> x - Negative x -> negated x - - groupedBySubworldPair :: - Map (SubworldName, SubworldName) (NonEmpty (Signed (Location, Location))) - groupedBySubworldPair = binTuples $ map (sequenceSigned . fmap tuplify) normalizedOrdering - - vectorized :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32)) - vectorized = M.map (NE.map (getSigned . fmap (uncurry (.-.)))) groupedBySubworldPair - - nonUniform :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32)) - nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized - --- | --- An implementation of 'sequenceA' for 'Signed' that does not --- require an 'Applicative' instance for the inner 'Functor'. --- --- == Discussion --- Compare to the 'Traversable' instance of 'Signed': --- --- @ --- instance Traversable Signed where --- traverse f (Positive x) = Positive <$> f x --- traverse f (Negative x) = Negative <$> f x --- @ --- --- if we were to substitute 'id' for f: --- --- @ --- traverse id (Positive x) = Positive <$> id x --- traverse id (Negative x) = Negative <$> id x --- @ --- our implementation essentially becomes @traverse id@. --- --- However, we cannot simply write our implementation as @traverse id@, because --- the 'traverse' function has an 'Applicative' constraint, which is superfluous --- for our purpose. --- --- Perhaps there is an opportunity to invent a typeclass for datatypes which --- consist exclusively of unary (or more ambitiously, non-nullary?) data constructors, --- for which a less-constrained 'sequence' function could be automatically derived. --- Compare to the 'Comonad' class and its 'extract' function. -sequenceSigned :: - Functor f => - Signed (f a) -> - f (Signed a) -sequenceSigned = \case - Positive x -> Positive <$> x - Negative x -> Negative <$> x diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Util.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Util.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Util.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Game.Scenario.Topography.Navigation.Util where - -import Control.Lens (view) -import Data.Function (on) -import Data.Int (Int32) -import Linear (V2) -import Swarm.Game.Location -import Swarm.Game.Robot -import Swarm.Game.Universe (Cosmic, planar) -import Swarm.Language.Direction - --- | --- Computes the relative offset vector between a 'Robot' and a 'Location' --- (presumed to be in the same subworld, though the contrary will --- not result in failure), then re-interpret that vector based on the --- 'Robot'\'s current orientation. --- --- If the robot is not oriented in a cardinal direction, returns 'Nothing'. --- --- = Re-orientation semantics --- --- Given a displacement vector @(x, y)@ where: --- --- * positive @x@-coordinate represents @east@ --- * negative @x@-coordinate represents @west@ --- * positive @y@-coordinate represents @north@ --- * negative @y@-coordinate represents @south@ --- --- the re-interpreted vector @(x', y')@ becomes: --- --- * positive @x'@-coordinate represents @right@ --- * negative @x'@-coordinate represents @left@ --- * positive @y'@-coordinate represents @forward@ --- * negative @y'@-coordinate represents @back@ -orientationBasedRelativePosition :: Robot -> Cosmic Location -> Maybe (V2 Int32) -orientationBasedRelativePosition selfRobot otherLocation = - (`applyTurn` relativeCoords) <$> maybeSelfDirRelativeToNorth - where - maybeSelfDirection = view robotOrientation selfRobot >>= toAbsDirection - maybeSelfDirRelativeToNorth = DRelative . DPlanar . relativeTo DNorth <$> maybeSelfDirection - - relativeCoords = ((.-.) `on` view planar) otherLocation (view robotLocation selfRobot) diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Landmarks that are used to specify portal locations --- and can serve as navigation aids via the `waypoint` command. --- --- = Waypoint ordering --- --- The sequence of waypoints of a given name is dictated by criteria in the following order: --- --- 1. Ordering of structure placements --- (see implementation of 'Swarm.Game.Scenario.Topography.Structure.mergeStructures'); --- later placements are ordered first. --- 2. Placement of cells within a map. Map locations go by row-major order --- (compare to docs for 'Swarm.Game.State.genRobotTemplates'). --- --- TODO (#1366): May be useful to have a mechanism for more --- precise control of ordering. -module Swarm.Game.Scenario.Topography.Navigation.Waypoint where - -import Data.Int (Int32) -import Data.Text qualified as T -import Data.Yaml as Y -import GHC.Generics (Generic) -import Linear (V2 (..)) -import Swarm.Game.Location -import Swarm.Game.Scenario.Topography.Placement - --- | Indicates which structure something came from --- for debugging purposes. -data Originated a = Originated - { parent :: Maybe Placement - , value :: a - } - deriving (Show, Eq, Functor) - -newtype WaypointName = WaypointName T.Text - deriving (Show, Eq, Ord, Generic, FromJSON) - --- | Metadata about a waypoint -data WaypointConfig = WaypointConfig - { wpName :: WaypointName - , wpUnique :: Bool - -- ^ Enforce global uniqueness of this waypoint - } - deriving (Show, Eq) - -parseWaypointConfig :: Object -> Parser WaypointConfig -parseWaypointConfig v = - WaypointConfig - <$> v .: "name" - <*> v .:? "unique" .!= False - -instance FromJSON WaypointConfig where - parseJSON = withObject "Waypoint Config" parseWaypointConfig - --- | --- A parent world shouldn't have to know the exact layout of a subworld --- to specify where exactly a portal will deliver a robot to within the subworld. --- Therefore, we define named waypoints in the subworld and the parent world --- must reference them by name, rather than by coordinate. -data Waypoint = Waypoint - { wpConfig :: WaypointConfig - , wpLoc :: Location - } - deriving (Show, Eq) - --- | JSON representation is flattened; all keys are at the same level, --- in contrast with the underlying record. -instance FromJSON Waypoint where - parseJSON = withObject "Waypoint" $ \v -> - Waypoint - <$> parseWaypointConfig v - <*> v .: "loc" - --- | Basically "fmap" for the "Location" field -modifyLocation :: - (Location -> Location) -> - Waypoint -> - Waypoint -modifyLocation f (Waypoint cfg originalLoc) = Waypoint cfg $ f originalLoc - --- | Translation by a vector -offsetWaypoint :: - V2 Int32 -> - Waypoint -> - Waypoint -offsetWaypoint locOffset = modifyLocation (.+^ locOffset) diff --git a/src/Swarm/Game/Scenario/Topography/Placement.hs b/src/Swarm/Game/Scenario/Topography/Placement.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/Placement.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Descriptions of the orientation and offset by --- which a structure should be placed. -module Swarm.Game.Scenario.Topography.Placement where - -import Data.List (transpose) -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.Language.Syntax (AbsoluteDir (..)) - -newtype StructureName = StructureName Text - deriving (Eq, Ord, Show, Generic, FromJSON) - --- | Orientation transformations are applied before translation. -data Orientation = Orientation - { up :: AbsoluteDir - -- ^ e.g. For "East", rotates 270 degrees. - , flipped :: Bool - -- ^ vertical flip, applied before rotation - } - deriving (Eq, Show) - -instance FromJSON Orientation where - parseJSON = withObject "structure orientation" $ \v -> do - Orientation - <$> v .:? "up" .!= DNorth - <*> v .:? "flip" .!= False - -defaultOrientation :: Orientation -defaultOrientation = Orientation DNorth False - --- | This is the point-wise equivalent of "applyOrientationTransform" -reorientWaypoint :: Orientation -> AreaDimensions -> Location -> Location -reorientWaypoint (Orientation upDir shouldFlip) (AreaDimensions width height) = - rotational . flipping - where - 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 - rotational = case upDir of - DNorth -> id - DSouth -> flipH . flipV - DEast -> transposeLoc . flipV - DWest -> transposeLoc . flipH - --- | affine transformation -applyOrientationTransform :: Orientation -> [[a]] -> [[a]] -applyOrientationTransform (Orientation upDir shouldFlip) = - rotational . flipping - where - flipV = reverse - flipping = if shouldFlip then flipV else id - rotational = case upDir of - DNorth -> id - DSouth -> transpose . flipV . transpose . flipV - DEast -> transpose . flipV - DWest -> flipV . transpose - -data Placement = Placement - { src :: StructureName - , offset :: Location - , orient :: Orientation - } - deriving (Eq, Show) - -instance FromJSON Placement where - parseJSON = withObject "structure placement" $ \v -> do - sName <- v .: "src" - Placement sName - <$> v .:? "offset" .!= origin - <*> v .:? "orient" .!= defaultOrientation diff --git a/src/Swarm/Game/Scenario/Topography/Structure.hs b/src/Swarm/Game/Scenario/Topography/Structure.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/Structure.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Definitions of "structures" for use within a map, --- as well as logic for combining them. -module Swarm.Game.Scenario.Topography.Structure where - -import Control.Applicative ((<|>)) -import Control.Arrow ((&&&)) -import Data.Aeson.Key qualified as Key -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Coerce -import Data.Map qualified as M -import Data.Maybe (catMaybes, mapMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Yaml as Y -import Swarm.Game.Entity -import Swarm.Game.Location -import Swarm.Game.Scenario.RobotLookup -import Swarm.Game.Scenario.Topography.Area -import Swarm.Game.Scenario.Topography.Cell -import Swarm.Game.Scenario.Topography.Navigation.Waypoint -import Swarm.Game.Scenario.Topography.Placement -import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Util (failT, showT) -import Swarm.Util.Yaml -import Witch (into) - -data NamedStructure c = NamedStructure - { name :: StructureName - , structure :: PStructure c - } - deriving (Eq, Show) - -type InheritedStructureDefs = [NamedStructure (Maybe (PCell Entity))] - -instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity))) where - parseJSONE = withObjectE "named structure" $ \v -> do - NamedStructure - <$> liftE (v .: "name") - <*> v - ..: "structure" - -data PStructure c = Structure - { area :: [[c]] - , structures :: [NamedStructure c] - -- ^ structure definitions from parents shall be accessible by children - , placements :: [Placement] - -- ^ earlier placements will be overlaid on top of later placements in the YAML file - , waypoints :: [Waypoint] - } - deriving (Eq, Show) - -data MergedStructure c = MergedStructure [[c]] [Originated Waypoint] - --- | Destructively overlays one direct child structure --- upon the input structure. --- However, the child structure is assembled recursively. -overlaySingleStructure :: - M.Map StructureName (PStructure (Maybe a)) -> - (Placement, PStructure (Maybe a)) -> - MergedStructure (Maybe a) -> - MergedStructure (Maybe a) -overlaySingleStructure - inheritedStrucDefs - (p@(Placement _ loc@(Location colOffset rowOffset) orientation), struc) - (MergedStructure inputArea inputWaypoints) = - MergedStructure mergedArea mergedWaypoints - where - mergedArea = zipWithPad mergeSingleRow inputArea paddedOverlayRows - - placeWaypoint = - offsetWaypoint (coerce loc) - . modifyLocation (reorientWaypoint orientation $ getAreaDimensions overlayArea) - mergedWaypoints = inputWaypoints <> map (fmap placeWaypoint) overlayWaypoints - - zipWithPad f a b = zipWith f a $ b <> repeat Nothing - - MergedStructure overlayArea overlayWaypoints = mergeStructures inheritedStrucDefs (Just p) struc - affineTransformedOverlay = applyOrientationTransform orientation overlayArea - - mergeSingleRow inputRow maybeOverlayRow = - zipWithPad (flip (<|>)) inputRow paddedSingleOverlayRow - where - paddedSingleOverlayRow = maybe [] (applyOffset colOffset) maybeOverlayRow - - paddedOverlayRows = applyOffset (negate rowOffset) . map Just $ affineTransformedOverlay - applyOffset offsetNum = modifyFront - where - integralOffset = fromIntegral offsetNum - modifyFront = - if integralOffset >= 0 - then (replicate integralOffset Nothing <>) - else drop $ abs integralOffset - --- | Overlays all of the "child placements", such that the children encountered earlier --- in the YAML file supersede the later ones (due to use of 'foldr' instead of 'foldl'). -mergeStructures :: - M.Map StructureName (PStructure (Maybe a)) -> - Maybe Placement -> - PStructure (Maybe a) -> - MergedStructure (Maybe a) -mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = - foldr (overlaySingleStructure structureMap) (MergedStructure origArea originatedWaypoints) overlays - where - originatedWaypoints = map (Originated parentPlacement) subWaypoints - - -- deeper definitions override the outer (toplevel) ones - structureMap = M.union (M.fromList $ map (name &&& structure) subStructures) inheritedStrucDefs - overlays = mapMaybe g subPlacements - g placement@(Placement sName _ _) = - sequenceA (placement, M.lookup sName structureMap) - -instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe (PCell Entity))) where - parseJSONE = withObjectE "structure definition" $ \v -> do - pal <- v ..:? "palette" ..!= WorldPalette mempty - localStructureDefs <- v ..:? "structures" ..!= [] - placementDefs <- liftE $ v .:? "placements" .!= [] - waypointDefs <- liftE $ v .:? "waypoints" .!= [] - maybeMaskChar <- liftE $ v .:? "mask" - (maskedArea, mapWaypoints) <- liftE $ (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal - return $ Structure maskedArea localStructureDefs placementDefs $ waypointDefs <> mapWaypoints - --- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw --- string into a nested list of 'PCell' values by looking up each --- character in the palette, failing if any character in the raw map --- is not contained in the palette. -paintMap :: - MonadFail m => - Maybe Char -> - WorldPalette e -> - Text -> - m ([[Maybe (PCell e)]], [Waypoint]) -paintMap maskChar pal a = do - nestedLists <- readMap toCell a - let cells = map (map $ fmap standardCell) nestedLists - f i j maybeAugmentedCell = do - wpCfg <- waypointCfg =<< maybeAugmentedCell - return . Waypoint wpCfg . Location j $ negate i - wps = concat $ zipWith (\i -> catMaybes . zipWith (f i) [0 ..]) [0 ..] nestedLists - - return (cells, wps) - where - toCell c = - if Just c == maskChar - then return Nothing - else case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of - Nothing -> failT ["Char not in world palette:", showT c] - Just cell -> return $ Just cell - -readMap :: Applicative f => (Char -> f b) -> Text -> f [[b]] -readMap func = traverse (traverse func . into @String) . T.lines diff --git a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Game.Scenario.Topography.WorldDescription where - -import Control.Carrier.Reader (runReader) -import Control.Carrier.Throw.Either -import Control.Monad (forM) -import Data.Functor.Identity -import Data.Maybe (catMaybes) -import Data.Yaml as Y -import Swarm.Game.Entity -import Swarm.Game.Location -import Swarm.Game.Scenario.RobotLookup -import Swarm.Game.Scenario.Topography.Cell -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.Navigation.Portal -import Swarm.Game.Scenario.Topography.Navigation.Waypoint ( - WaypointName, - ) -import Swarm.Game.Scenario.Topography.Structure (InheritedStructureDefs, MergedStructure (MergedStructure), PStructure (Structure)) -import Swarm.Game.Scenario.Topography.Structure qualified as Structure -import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Game.Universe -import Swarm.Game.World.Parse () -import Swarm.Game.World.Syntax -import Swarm.Game.World.Typecheck -import Swarm.Language.Pretty (prettyString) -import Swarm.Util.Yaml - ------------------------------------------------------------- --- World description ------------------------------------------------------------- - --- | A description of a world parsed from a YAML file. --- This type is parameterized to accommodate Cells that --- utilize a less stateful Entity type. -data PWorldDescription e = WorldDescription - { offsetOrigin :: Bool - , scrollable :: Bool - , palette :: WorldPalette e - , ul :: Location - , area :: [[PCell e]] - , navigation :: Navigation Identity WaypointName - , worldName :: SubworldName - , worldProg :: Maybe (TTerm '[] (World CellVal)) - } - deriving (Show) - -type WorldDescription = PWorldDescription Entity - -instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) WorldDescription where - parseJSONE = withObjectE "world description" $ \v -> do - (worldMap, scenarioLevelStructureDefs, em, rm) <- getE - (pal, rootWorldStructureDefs) <- localE (const (em, rm)) $ do - pal <- v ..:? "palette" ..!= WorldPalette mempty - rootWorldStructs <- v ..:? "structures" ..!= [] - return (pal, rootWorldStructs) - - waypointDefs <- liftE $ v .:? "waypoints" .!= [] - portalDefs <- liftE $ v .:? "portals" .!= [] - placementDefs <- liftE $ v .:? "placements" .!= [] - (initialArea, mapWaypoints) <- liftE ((v .:? "map" .!= "") >>= Structure.paintMap Nothing pal) - - upperLeft <- liftE (v .:? "upperleft" .!= origin) - subWorldName <- liftE (v .:? "name" .!= DefaultRootSubworld) - - let initialStructureDefs = scenarioLevelStructureDefs <> rootWorldStructureDefs - struc = Structure initialArea initialStructureDefs placementDefs $ waypointDefs <> mapWaypoints - MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc - - validatedNavigation <- - validatePartialNavigation - subWorldName - upperLeft - unmergedWaypoints - portalDefs - - mwexp <- liftE (v .:? "dsl") - dslTerm <- forM mwexp $ \wexp -> do - let checkResult = - run . runThrow @CheckErr . runReader worldMap . runReader em $ - check CNil (TTyWorld TTyCell) wexp - either (fail . prettyString) return checkResult - WorldDescription - <$> liftE (v .:? "offset" .!= False) - <*> liftE (v .:? "scrollable" .!= True) - <*> pure pal - <*> pure upperLeft - <*> pure (map catMaybes mergedArea) -- Root-level map has no transparent cells. - <*> pure validatedNavigation - <*> pure subWorldName - <*> pure dslTerm - ------------------------------------------------------------- --- World editor ------------------------------------------------------------- - --- | A pared-down (stateless) version of "WorldDescription" just for --- the purpose of rendering a Scenario file -type WorldDescriptionPaint = PWorldDescription EntityFacade - -instance ToJSON WorldDescriptionPaint where - toJSON w = - object - [ "offset" .= offsetOrigin w - , "palette" .= Y.toJSON paletteKeymap - , "upperleft" .= ul w - , "map" .= Y.toJSON mapText - ] - where - cellGrid = area w - suggestedPalette = palette w - (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid diff --git a/src/Swarm/Game/Scenario/Topography/WorldPalette.hs b/src/Swarm/Game/Scenario/Topography/WorldPalette.hs deleted file mode 100644 --- a/src/Swarm/Game/Scenario/Topography/WorldPalette.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# 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 (KeyMap) -import Data.Aeson.KeyMap qualified as KM -import Data.Map qualified as M -import Data.Set qualified as Set -import Data.Text (Text) -import Data.Text qualified as T -import Data.Tuple (swap) -import Swarm.Game.Entity -import Swarm.Game.Scenario.RobotLookup -import Swarm.Game.Scenario.Topography.Cell -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Terrain (TerrainType) -import Swarm.Util.Erasable -import Swarm.Util.Yaml - --- | A world palette maps characters to 'Cell' values. -newtype WorldPalette e = WorldPalette - {unPalette :: KeyMap (AugmentedCell e)} - deriving (Eq, Show) - -instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where - parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE - -type TerrainWith a = (TerrainType, Erasable a) - -cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade -cellToTerrainPair (Cell terrain erasableEntity _) = (terrain, erasableEntity) - -toCellPaintDisplay :: Cell -> CellPaintDisplay -toCellPaintDisplay (Cell terrain maybeEntity r) = - Cell terrain (mkFacade <$> maybeEntity) r - -toKey :: TerrainWith EntityFacade -> TerrainWith EntityName -toKey = fmap $ fmap (\(EntityFacade eName _display) -> eName) - --- | We want to identify all of the unique (terrain, entity facade) pairs. --- However, "EntityFacade" includes a "Display" record, which contains more --- fields than desirable for use as a unique key. --- Therefore, we extract just the entity name for use in a --- (terrain, entity name) key, and couple it with the original --- (terrain, entity facade) pair in a Map. -getUniqueTerrainFacadePairs :: - [[CellPaintDisplay]] -> - M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) -getUniqueTerrainFacadePairs cellGrid = - M.fromList $ concatMap (map genTuple) cellGrid - where - genTuple c = - (toKey terrainEfd, terrainEfd) - where - terrainEfd = cellToTerrainPair c - -constructPalette :: - [(Char, TerrainWith EntityFacade)] -> - KM.KeyMap CellPaintDisplay -constructPalette mappedPairs = - KM.fromMapText terrainEntityPalette - where - g (terrain, maybeEfd) = Cell terrain maybeEfd [] - terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs - -constructWorldMap :: - [(Char, TerrainWith EntityFacade)] -> - [[CellPaintDisplay]] -> - Text -constructWorldMap mappedPairs = - T.unlines . map (T.pack . map renderMapCell) - where - invertedMappedPairs = map (swap . fmap toKey) mappedPairs - - renderMapCell c = - -- NOTE: This lookup should never fail - M.findWithDefault (error "Palette lookup failed!") k $ - M.fromList invertedMappedPairs - where - k = toKey $ cellToTerrainPair c - --- | All alphanumeric characters. These are used as supplemental --- map placeholders in case a pre-existing display character is --- not available to re-use. -genericCharacterPool :: Set.Set Char -genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9'] - --- | Note that display characters are not unique --- across different entities! However, the palette KeyMap --- as a conveyance serves to dedupe them. -prepForJson :: - WorldPalette EntityFacade -> - [[CellPaintDisplay]] -> - (Text, KM.KeyMap CellPaintDisplay) -prepForJson (WorldPalette suggestedPalette) cellGrid = - (constructWorldMap mappedPairs cellGrid, constructPalette mappedPairs) - where - preassignments :: [(Char, TerrainWith EntityFacade)] - preassignments = - map (first T.head . fmap (cellToTerrainPair . standardCell)) $ - M.toList $ - KM.toMapText suggestedPalette - - entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) - entityCells = getUniqueTerrainFacadePairs cellGrid - - unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) - unassignedCells = - M.withoutKeys entityCells $ - Set.fromList $ - map (toKey . snd) preassignments - - unassignedCharacters :: Set.Set Char - unassignedCharacters = - -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char") - -- to generate this pool? - Set.difference genericCharacterPool $ - Set.fromList $ - map fst preassignments - - newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)] - newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells - - mappedPairs = preassignments <> newlyAssignedPairs diff --git a/src/Swarm/Game/ScenarioInfo.hs b/src/Swarm/Game/ScenarioInfo.hs deleted file mode 100644 --- a/src/Swarm/Game/ScenarioInfo.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- -Wno-orphans is for the Eq/Ord Time instances - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Saving and loading info about scenarios (status, path, etc.) as --- well as loading recursive scenario collections. -module Swarm.Game.ScenarioInfo ( - -- * Scenario info - ScenarioStatus (..), - _NotStarted, - ScenarioInfo (..), - scenarioPath, - scenarioStatus, - CodeSizeDeterminators (CodeSizeDeterminators), - updateScenarioInfoOnFinish, - ScenarioInfoPair, - - -- * Scenario collection - ScenarioCollection (..), - scenarioCollectionToList, - flatten, - scenarioItemByPath, - normalizeScenarioPath, - ScenarioItem (..), - scenarioItemName, - _SISingle, - - -- * Loading and saving scenarios - loadScenarios, - loadScenarioInfo, - saveScenarioInfo, - - -- * Re-exports - module Swarm.Game.Scenario, -) where - -import Control.Algebra (Has) -import Control.Carrier.Lift (runM) -import Control.Carrier.Throw.Either (runThrow) -import Control.Effect.Accum (Accum, add) -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.IO.Class (MonadIO (liftIO)) -import Data.Char (isSpace) -import Data.Either (partitionEithers) -import Data.Either.Extra (fromRight') -import Data.List (intercalate, isPrefixOf, stripPrefix, (\\)) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M -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.Entity -import Swarm.Game.Failure -import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath) -import Swarm.Game.Scenario -import Swarm.Game.Scenario.Scoring.CodeSize -import Swarm.Game.Scenario.Status -import Swarm.Game.World.Typecheck (WorldMap) -import Swarm.Util.Effect (warn, withThrow) -import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory) -import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), ()) -import Witch (into) - --- ---------------------------------------------------------------------------- --- 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) - --- | Retrieve the name of a scenario item. -scenarioItemName :: ScenarioItem -> Text -scenarioItemName (SISingle (s, _ss)) = s ^. scenarioName -scenarioItemName (SICollection name _) = name - --- | A scenario collection is a tree of scenarios, keyed by name, --- together with an optional order. --- --- /Invariant:/ every item in the --- 'scOrder' exists as a key in the 'scMap'. -data ScenarioCollection = SC - { scOrder :: Maybe [FilePath] - , scMap :: Map FilePath ScenarioItem - } - deriving (Show) - --- | Access and modify 'ScenarioItem's in collection based on their path. -scenarioItemByPath :: FilePath -> Traversal' ScenarioCollection ScenarioItem -scenarioItemByPath path = ixp ps - where - ps = splitDirectories path - ixp :: (Applicative f) => [String] -> (ScenarioItem -> f ScenarioItem) -> ScenarioCollection -> f ScenarioCollection - 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 - where - inner si = case si of - SISingle {} -> pure si - SICollection n' col -> SICollection n' <$> ixp xs f col - --- | Canonicalize a scenario path, making it usable as a unique key. -normalizeScenarioPath :: - (MonadIO m) => - ScenarioCollection -> - FilePath -> - m FilePath -normalizeScenarioPath col p = - let path = p -<.> "yaml" - in if isJust $ col ^? scenarioItemByPath path - 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 - 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 - -flatten :: ScenarioItem -> [ScenarioInfoPair] -flatten (SISingle p) = [p] -flatten (SICollection _ c) = concatMap flatten $ scenarioCollectionToList c - --- | Load all the scenarios from the scenarios data directory. -loadScenarios :: - (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => - EntityMap -> - WorldMap -> - m ScenarioCollection -loadScenarios em worldMap = do - res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios" - case res of - Left err -> do - warn err - return $ SC mempty mempty - Right dataDir -> loadScenarioDir em worldMap 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) - --- | Recursively load all scenarios from a particular directory, and also load --- the 00-ORDER file (if any) giving the order for the scenarios. -loadScenarioDir :: - (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => - EntityMap -> - WorldMap -> - FilePath -> - m ScenarioCollection -loadScenarioDir em worldMap 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 - - forM_ (NE.nonEmpty dangling) $ - warn - . OrderFileWarning (dirName orderFileName) - . DanglingFiles - Nothing -> pure () - - -- Only keep the files from 00-ORDER.txt that actually exist. - let morder' = filter (`elem` itemPaths) <$> morder - loadItem filepath = do - item <- loadScenarioItem em worldMap (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 - - -- Whether the directory or file should be included in the scenario catalog. - isCatalogEntry d f = do - isDir <- doesDirectoryExist $ d f - return $ - if isDir - then not $ "_" `isPrefixOf` f - else takeExtensions f == ".yaml" - --- | How to transform scenario path to save path. -scenarioPathToSavePath :: FilePath -> FilePath -> FilePath -scenarioPathToSavePath path swarmData = swarmData Data.List.intercalate "_" (splitDirectories path) - --- | Load saved info about played scenario from XDG data directory. -loadScenarioInfo :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - FilePath -> - m ScenarioInfo -loadScenarioInfo p = do - path <- sendIO $ normalizeScenarioPath (SC Nothing mempty) 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 - --- | Save info about played scenario to XDG data directory. -saveScenarioInfo :: - FilePath -> - ScenarioInfo -> - IO () -saveScenarioInfo path si = do - infoPath <- scenarioPathToSavePath path <$> getSwarmSavePath True - encodeFile infoPath si - --- | Load a scenario item (either a scenario, or a subdirectory --- containing a collection of scenarios) from a particular path. -loadScenarioItem :: - ( Has (Throw SystemFailure) sig m - , Has (Accum (Seq SystemFailure)) sig m - , Has (Lift IO) sig m - ) => - EntityMap -> - WorldMap -> - FilePath -> - m ScenarioItem -loadScenarioItem em worldMap path = do - isDir <- sendIO $ doesDirectoryExist path - let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path - case isDir of - True -> SICollection collectionName <$> loadScenarioDir em worldMap path - False -> do - s <- loadScenarioFile em worldMap path - eitherSi <- runThrow @SystemFailure (loadScenarioInfo path) - case eitherSi of - Right si -> return $ SISingle (s, si) - Left warning -> do - warn warning - return $ SISingle (s, ScenarioInfo path NotStarted) - ------------------------------------------------------------- --- Some lenses + prisms ------------------------------------------------------------- - -makePrisms ''ScenarioItem -makePrisms ''ScenarioStatus diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs deleted file mode 100644 --- a/src/Swarm/Game/State.hs +++ /dev/null @@ -1,1432 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Definition of the record holding all the game-related state, and various related --- utility functions. -module Swarm.Game.State ( - -- * Game state record and related types - ViewCenterRule (..), - REPLStatus (..), - WinStatus (..), - WinCondition (..), - ObjectiveCompletion (..), - _NoWinCondition, - _WinConditions, - Announcement (..), - RunStatus (..), - Seed, - Step (..), - SingleStep (..), - GameState, - - -- ** GameState fields - creativeMode, - winCondition, - winSolution, - robotMap, - robotsByLocation, - robotsAtLocation, - robotsWatching, - robotsInArea, - baseRobot, - activeRobots, - waitingRobots, - messageNotifications, - seed, - randGen, - currentScenarioPath, - viewCenterRule, - viewCenter, - needsRedraw, - focusedRobotID, - - -- *** Subrecord accessors - temporal, - robotNaming, - recipesInfo, - messageInfo, - gameControls, - discovery, - landscape, - - -- ** GameState subrecords - - -- *** Temporal state - TemporalState, - gameStep, - runStatus, - ticks, - robotStepsPerTick, - paused, - - -- *** Robot naming - RobotNaming, - nameGenerator, - gensym, - - -- *** Recipes - Recipes, - recipesOut, - recipesIn, - recipesCat, - - -- *** Messages - Messages, - messageQueue, - lastSeenMessageTime, - announcementQueue, - - -- *** Controls - GameControls, - initiallyRunCode, - replStatus, - replNextValueIndex, - replWorking, - replActiveType, - inputHandler, - - -- *** Discovery - Discovery, - allDiscoveredEntities, - availableRecipes, - availableCommands, - knownEntities, - gameAchievements, - - -- *** Landscape - Landscape, - worldNavigation, - multiWorld, - worldScrollable, - entityMap, - - -- ** Notifications - Notifications (..), - notificationsCount, - notificationsContent, - - -- ** Launch parameters - LaunchParams, - ValidatedLaunchParams, - - -- ** GameState initialization - GameStateConfig (..), - initGameState, - scenarioToGameState, - CodeToRun (..), - Sha1 (..), - SolutionSource (..), - parseCodeFile, - - -- * Utilities - applyViewCenterRule, - recalcViewCenter, - modifyViewCenter, - viewingRegion, - unfocus, - focusedRobot, - RobotRange (..), - focusedRange, - getRadioRange, - clearFocusedRobotLogUpdated, - addRobot, - addRobotToLocation, - addTRobot, - emitMessage, - wakeWatchingRobots, - sleepUntil, - sleepForever, - wakeUpRobotsDoneSleeping, - deleteRobot, - removeRobotFromLocationMap, - activateRobot, - toggleRunStatus, - messageIsRecent, - messageIsFromNearby, - getRunCodePath, - buildWorldTuples, - genMultiWorld, - genRobotTemplates, -) where - -import Control.Applicative ((<|>)) -import Control.Arrow (Arrow ((&&&))) -import Control.Effect.Lens -import Control.Effect.Lift -import Control.Effect.State (State) -import Control.Effect.Throw -import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) -import Control.Monad (forM_) -import Data.Aeson (FromJSON, ToJSON) -import Data.Array (Array, listArray) -import Data.Bifunctor (first) -import Data.Digest.Pure.SHA (sha1, showDigest) -import Data.Foldable (toList) -import Data.Int (Int32) -import Data.IntMap (IntMap) -import Data.IntMap qualified as IM -import Data.IntSet (IntSet) -import Data.IntSet qualified as IS -import Data.IntSet.Lens (setOf) -import Data.List (partition, sortOn) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) -import Data.Sequence (Seq ((:<|))) -import Data.Sequence qualified as Seq -import Data.Set qualified as S -import Data.Text (Text) -import Data.Text qualified as T (drop, take) -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 Servant.Docs (ToSample) -import Servant.Docs qualified as SD -import Swarm.Game.Achievement.Attainment -import Swarm.Game.Achievement.Definitions -import Swarm.Game.CESK (CESK (Waiting), TickNumber (..), addTicks, emptyStore, finalValue, initMachine) -import Swarm.Game.Entity -import Swarm.Game.Failure (SystemFailure (..)) -import Swarm.Game.Location -import Swarm.Game.Recipe ( - Recipe, - catRecipeMap, - inRecipeMap, - outRecipeMap, - ) -import Swarm.Game.ResourceLoading (NameGenerator) -import Swarm.Game.Robot -import Swarm.Game.Scenario.Objective -import Swarm.Game.Scenario.Status -import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) -import Swarm.Game.ScenarioInfo -import Swarm.Game.Terrain (TerrainType (..)) -import Swarm.Game.Universe as U -import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray) -import Swarm.Game.World qualified as W -import Swarm.Game.World.Eval (runWorld) -import Swarm.Game.World.Gen (Seed, findGoodOrigin) -import Swarm.Game.World.Typecheck (WorldMap) -import Swarm.Language.Capability (constCaps) -import Swarm.Language.Context qualified as Ctx -import Swarm.Language.Module (Module (Module)) -import Swarm.Language.Pipeline (ProcessedTerm (ProcessedTerm), processTermEither) -import Swarm.Language.Syntax (Const, SrcLoc (..), Syntax' (..), allConst) -import Swarm.Language.Typed (Typed (Typed)) -import Swarm.Language.Types -import Swarm.Language.Value (Value) -import Swarm.Log -import Swarm.Util (applyWhen, binTuples, surfaceEmpty, uniq, (<+=), (<<.=), (?)) -import Swarm.Util.Erasable -import Swarm.Util.Lens (makeLensesExcluding, makeLensesNoSigs) -import System.Clock qualified as Clock -import System.Random (StdGen, mkStdGen, randomRIO) - ------------------------------------------------------------- --- Subsidiary data types ------------------------------------------------------------- - --- | The 'ViewCenterRule' specifies how to determine the center of the --- world viewport. -data ViewCenterRule - = -- | The view should be centered on an absolute position. - VCLocation (Cosmic Location) - | -- | The view should be centered on a certain robot. - VCRobot RID - deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) - -makePrisms ''ViewCenterRule - --- | A data type to represent the current status of the REPL. -data REPLStatus - = -- | The REPL is not doing anything actively at the moment. - -- We persist the last value and its type though. - -- - -- INVARIANT: the 'Value' stored here is not a 'Swarm.Language.Value.VResult'. - REPLDone (Maybe (Typed Value)) - | -- | A command entered at the REPL is currently being run. The - -- 'Polytype' represents the type of the expression that was - -- entered. The @Maybe Value@ starts out as 'Nothing' and gets - -- filled in with a result once the command completes. - REPLWorking (Typed (Maybe Value)) - deriving (Eq, Show, Generic, FromJSON, ToJSON) - -data WinStatus - = -- | There are one or more objectives remaining that the player - -- has not yet accomplished. - Ongoing - | -- | The player has won. - -- The boolean indicates whether they have - -- already been congratulated. - Won Bool - | -- | The player has completed certain "goals" that preclude - -- (via negative prerequisites) the completion of all of the - -- required goals. - -- The boolean indicates whether they have - -- already been informed. - Unwinnable Bool - deriving (Show, Generic, FromJSON, ToJSON) - -data WinCondition - = -- | There is no winning condition. - NoWinCondition - | -- | NOTE: It is possible to continue to achieve "optional" objectives - -- even after the game has been won (or deemed unwinnable). - WinConditions WinStatus ObjectiveCompletion - deriving (Show, Generic, FromJSON, ToJSON) - -makePrisms ''WinCondition - -instance ToSample WinCondition where - toSamples _ = - SD.samples - [ NoWinCondition - -- TODO: #1552 add simple objective sample - ] - --- | A data type to keep track of the pause mode. -data RunStatus - = -- | The game is running. - Running - | -- | The user paused the game, and it should stay pause after visiting the help. - ManualPause - | -- | The game got paused while visiting the help, - -- and it should unpause after returning back to the game. - AutoPause - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | Switch (auto or manually) paused game to running and running to manually paused. --- --- Note that this function is not safe to use in the app directly, because the UI --- also tracks time between ticks---use 'Swarm.TUI.Controller.safeTogglePause' instead. -toggleRunStatus :: RunStatus -> RunStatus -toggleRunStatus s = if s == Running then ManualPause else Running - --- | A data type to keep track of some kind of log or sequence, with --- an index to remember which ones are "new" and which ones have --- "already been seen". -data Notifications a = Notifications - { _notificationsCount :: Int - , _notificationsContent :: [a] - } - deriving (Eq, Show, Generic, FromJSON, ToJSON) - -instance Semigroup (Notifications a) where - Notifications count1 xs1 <> Notifications count2 xs2 = Notifications (count1 + count2) (xs1 <> xs2) - -instance Monoid (Notifications a) where - mempty = Notifications 0 [] - -makeLenses ''Notifications - -newtype Sha1 = Sha1 String - -data SolutionSource - = ScenarioSuggested - | -- | Includes the SHA1 of the program text - -- for the purpose of corroborating solutions - -- on a leaderboard. - PlayerAuthored FilePath Sha1 - -data CodeToRun = CodeToRun SolutionSource ProcessedTerm - -getRunCodePath :: CodeToRun -> Maybe FilePath -getRunCodePath (CodeToRun solutionSource _) = case solutionSource of - ScenarioSuggested -> Nothing - PlayerAuthored fp _ -> Just fp - -parseCodeFile :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - FilePath -> - m CodeToRun -parseCodeFile filepath = do - contents <- sendIO $ TIO.readFile filepath - pt@(ProcessedTerm (Module (Syntax' srcLoc _ _) _) _ _) <- - either (throwError . CustomFailure) return (processTermEither contents) - let strippedText = stripSrc srcLoc contents - programBytestring = TL.encodeUtf8 $ TL.fromStrict strippedText - sha1Hash = showDigest $ sha1 programBytestring - return $ CodeToRun (PlayerAuthored filepath $ Sha1 sha1Hash) pt - where - stripSrc :: SrcLoc -> Text -> Text - stripSrc (SrcLoc start end) txt = T.drop start $ T.take end txt - stripSrc NoLoc txt = txt - ------------------------------------------------------------- --- The main GameState record type ------------------------------------------------------------- - --- | By default, robots may make a maximum of 100 CESK machine steps --- during one game tick. -defaultRobotStepsPerTick :: Int -defaultRobotStepsPerTick = 100 - --- | Type for remembering which robots will be run next in a robot step mode. --- --- Once some robots have run, we need to store 'RID' to know which ones should go next. --- At 'SBefore' no robots were run yet, so it is safe to transition to and from 'WorldTick'. --- --- @ --- tick --- ┌────────────────────────────────────┐ --- │ │ --- │ step │ --- │ ┌────┐ │ --- ▼ ▼ │ │ --- ┌───────┐ step ┌───────┴───┐ step ┌────┴─────┐ --- │SBefore├──────►│SSingle RID├──────►│SAfter RID│ --- └──┬────┘ └───────────┘ └────┬─────┘ --- │ ▲ player ▲ │ --- ▼ │ switch └───────────────────┘ --- ┌────┴────┐ view RID > oldRID --- │WorldTick│ --- └─────────┘ --- @ -data SingleStep - = -- | Run the robots from the beginning until the focused robot (noninclusive). - SBefore - | -- | Run a single step of the focused robot. - SSingle RID - | -- | Run robots after the (previously) focused robot and finish the tick. - SAfter RID - --- | Game step mode - we use the single step mode when debugging robot 'CESK' machine. -data Step = WorldTick | RobotStep SingleStep - -data Recipes = Recipes - { _recipesOut :: IntMap [Recipe Entity] - , _recipesIn :: IntMap [Recipe Entity] - , _recipesCat :: IntMap [Recipe Entity] - } - -makeLensesNoSigs ''Recipes - --- | All recipes the game knows about, indexed by outputs. -recipesOut :: Lens' Recipes (IntMap [Recipe Entity]) - --- | All recipes the game knows about, indexed by inputs. -recipesIn :: Lens' Recipes (IntMap [Recipe Entity]) - --- | All recipes the game knows about, indexed by requirement/catalyst. -recipesCat :: Lens' Recipes (IntMap [Recipe Entity]) - -data Messages = Messages - { _messageQueue :: Seq LogEntry - , _lastSeenMessageTime :: TickNumber - , _announcementQueue :: Seq Announcement - } - -makeLensesNoSigs ''Messages - --- | A queue of global messages. --- --- Note that we put the newest entry to the right. -messageQueue :: Lens' Messages (Seq LogEntry) - --- | Last time message queue has been viewed (used for notification). -lastSeenMessageTime :: Lens' Messages TickNumber - --- | A queue of global announcements. --- Note that this is distinct from the 'messageQueue', --- which is for messages emitted by robots. --- --- Note that we put the newest entry to the right. -announcementQueue :: Lens' Messages (Seq Announcement) - -data RobotNaming = RobotNaming - { _nameGenerator :: NameGenerator - , _gensym :: Int - } - -makeLensesExcluding ['_nameGenerator] ''RobotNaming - ---- | Read-only list of words, for use in building random robot names. -nameGenerator :: Getter RobotNaming NameGenerator -nameGenerator = to _nameGenerator - --- | A counter used to generate globally unique IDs. -gensym :: Lens' RobotNaming Int - -data TemporalState = TemporalState - { _gameStep :: Step - , _runStatus :: RunStatus - , _ticks :: TickNumber - , _robotStepsPerTick :: Int - } - -makeLensesNoSigs ''TemporalState - --- | How to step the game: 'WorldTick' or 'RobotStep' for debugging the 'CESK' machine. -gameStep :: Lens' TemporalState Step - --- | The current 'RunStatus'. -runStatus :: Lens' TemporalState RunStatus - --- | Whether the game is currently paused. -paused :: Getter TemporalState Bool -paused = to (\s -> s ^. runStatus /= Running) - --- | The number of ticks elapsed since the game started. -ticks :: Lens' TemporalState TickNumber - --- | The maximum number of CESK machine steps a robot may take during --- a single tick. -robotStepsPerTick :: Lens' TemporalState Int - -data GameControls = GameControls - { _replStatus :: REPLStatus - , _replNextValueIndex :: Integer - , _inputHandler :: Maybe (Text, Value) - , _initiallyRunCode :: Maybe ProcessedTerm - } - -makeLensesNoSigs ''GameControls - --- | The current status of the REPL. -replStatus :: Lens' GameControls REPLStatus - --- | The index of the next @it{index}@ value -replNextValueIndex :: Lens' GameControls Integer - --- | 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 ProcessedTerm) - -data Discovery = Discovery - { _allDiscoveredEntities :: Inventory - , _availableRecipes :: Notifications (Recipe Entity) - , _availableCommands :: Notifications Const - , _knownEntities :: [Text] - , _gameAchievements :: Map GameplayAchievement Attainment - } - -makeLensesNoSigs ''Discovery - --- | The list of entities that have been discovered. -allDiscoveredEntities :: Lens' Discovery Inventory - --- | The list of available recipes. -availableRecipes :: Lens' Discovery (Notifications (Recipe Entity)) - --- | The list of available commands. -availableCommands :: Lens' Discovery (Notifications Const) - --- | The names of entities that should be considered \"known\", that is, --- robots know what they are without having to scan them. -knownEntities :: Lens' Discovery [Text] - --- | Map of in-game achievements that were obtained -gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment) - -data Landscape = Landscape - { _worldNavigation :: Navigation (M.Map SubworldName) Location - , _multiWorld :: W.MultiWorld Int Entity - , _entityMap :: EntityMap - , _worldScrollable :: Bool - } - -makeLensesNoSigs ''Landscape - --- | Includes a 'Map' of named locations and an --- "edge list" (graph) that maps portal entrances to exits -worldNavigation :: Lens' Landscape (Navigation (M.Map SubworldName) Location) - --- | The current state of the world (terrain and entities only; robots --- are stored in the 'robotMap'). 'Int' is used instead of --- 'TerrainType' because we need to be able to store terrain values in --- unboxed tile arrays. -multiWorld :: Lens' Landscape (W.MultiWorld Int Entity) - --- | The catalog of all entities that the game knows about. -entityMap :: Lens' Landscape EntityMap - --- | Whether the world map is supposed to be scrollable or not. -worldScrollable :: Lens' Landscape Bool - --- | The main record holding the state for the game itself (as --- distinct from the UI). See the lenses below for access to its --- fields. -data GameState = GameState - { _creativeMode :: Bool - , _temporal :: TemporalState - , _winCondition :: WinCondition - , _winSolution :: Maybe ProcessedTerm - , _robotMap :: IntMap Robot - , -- A set of robots to consider for the next game tick. It is guaranteed to - -- be a subset of the keys of 'robotMap'. It may contain waiting or idle - -- robots. But robots that are present in 'robotMap' and not in 'activeRobots' - -- are guaranteed to be either waiting or idle. - _activeRobots :: IntSet - , -- A set of probably waiting robots, indexed by probable wake-up time. It - -- may contain robots that are in fact active or idle, as well as robots - -- that do not exist anymore. Its only guarantee is that once a robot name - -- with its wake up time is inserted in it, it will remain there until the - -- wake-up time is reached, at which point it is removed via - -- '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] - , _robotsByLocation :: Map SubworldName (Map 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) (S.Set RID) - , _discovery :: Discovery - , _seed :: Seed - , _randGen :: StdGen - , _robotNaming :: RobotNaming - , _recipesInfo :: Recipes - , _currentScenarioPath :: Maybe FilePath - , _landscape :: Landscape - , _viewCenterRule :: ViewCenterRule - , _viewCenter :: Cosmic Location - , _needsRedraw :: Bool - , _gameControls :: GameControls - , _messageInfo :: Messages - , _focusedRobotID :: RID - } - ------------------------------------------------------------- --- Lenses ------------------------------------------------------------- - --- We want to access active and waiting robots via lenses inside --- this module but to expose it as a Getter to protect invariants. -makeLensesFor - [ ("_activeRobots", "internalActiveRobots") - , ("_waitingRobots", "internalWaitingRobots") - ] - ''GameState - -makeLensesExcluding ['_viewCenter, '_focusedRobotID, '_viewCenterRule, '_activeRobots, '_waitingRobots] ''GameState - --- | Is the user in creative mode (i.e. able to do anything without restriction)? -creativeMode :: Lens' GameState Bool - --- | Aspects of the temporal state of the game -temporal :: Lens' GameState TemporalState - --- | How to determine whether the player has won. -winCondition :: Lens' GameState WinCondition - --- | How to win (if possible). This is useful for automated testing --- and to show help to cheaters (or testers). -winSolution :: Lens' GameState (Maybe ProcessedTerm) - --- | All the robots that currently exist in the game, indexed by ID. -robotMap :: Lens' GameState (IntMap Robot) - --- | The names of all robots that currently exist in the game, indexed by --- location (which we need both for /e.g./ the @salvage@ command as --- well as for actually drawing the world). Unfortunately there is --- no good way to automatically keep this up to date, since we don't --- just want to completely rebuild it every time the 'robotMap' --- changes. Instead, we just make sure to update it every time the --- 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' GameState (Map SubworldName (Map Location IntSet)) - --- | Get a list of all the robots at a particular location. -robotsAtLocation :: Cosmic Location -> GameState -> [Robot] -robotsAtLocation loc gs = - mapMaybe (`IM.lookup` (gs ^. robotMap)) - . maybe [] IS.toList - . M.lookup (loc ^. planar) - . M.findWithDefault mempty (loc ^. subworld) - . view robotsByLocation - $ gs - --- | Get a list of all the robots that are \"watching\" by location. -robotsWatching :: Lens' GameState (Map (Cosmic Location) (S.Set RID)) - --- | Get all the robots within a given Manhattan distance from a --- location. -robotsInArea :: Cosmic Location -> Int32 -> GameState -> [Robot] -robotsInArea (Cosmic subworldName o) d gs = map (rm IM.!) rids - where - rm = gs ^. robotMap - rl = gs ^. robotsByLocation - rids = - concatMap IS.elems $ - getElemsInArea o d $ - M.findWithDefault mempty subworldName rl - --- | The base robot, if it exists. -baseRobot :: Traversal' GameState Robot -baseRobot = robotMap . ix 0 - --- | The names of the robots that are currently not sleeping. -activeRobots :: Getter GameState IntSet -activeRobots = internalActiveRobots - --- | 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 GameState (Map TickNumber [RID]) -waitingRobots = internalWaitingRobots - --- | Discovery state of entities, commands, recipes -discovery :: Lens' GameState Discovery - --- | The initial seed that was used for the random number generator, --- and world generation. -seed :: Lens' GameState Seed - --- | Pseudorandom generator initialized at start. -randGen :: Lens' GameState StdGen - --- | State and data for assigning identifiers to robots -robotNaming :: Lens' GameState RobotNaming - --- | Collection of recipe info -recipesInfo :: Lens' GameState Recipes - --- | The filepath of the currently running scenario. --- --- This is useful as an index to the scenarios collection, --- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'. -currentScenarioPath :: Lens' GameState (Maybe FilePath) - --- | Info about the lay of the land -landscape :: Lens' GameState Landscape - --- | The current center of the world view. Note that this cannot be --- modified directly, since it is calculated automatically from the --- 'viewCenterRule'. To modify the view center, either set the --- 'viewCenterRule', or use 'modifyViewCenter'. -viewCenter :: Getter GameState (Cosmic Location) -viewCenter = to _viewCenter - --- | Whether the world view needs to be redrawn. -needsRedraw :: Lens' GameState Bool - --- | Controls, including REPL and key mapping -gameControls :: Lens' GameState GameControls - --- | Message info -messageInfo :: Lens' GameState Messages - --- | The current robot in focus. --- --- It is only a 'Getter' because this value should be updated only when --- the 'viewCenterRule' is specified to be a robot. --- --- Technically it's the last robot ID specified by 'viewCenterRule', --- but that robot may not be alive anymore - to be safe use 'focusedRobot'. -focusedRobotID :: Getter GameState RID -focusedRobotID = to _focusedRobotID - ------------------------------------------------------------- --- Utilities ------------------------------------------------------------- - --- | The current rule for determining the center of the world view. --- It updates also, 'viewCenter' and 'focusedRobot' to keep --- everything synchronized. -viewCenterRule :: Lens' GameState ViewCenterRule -viewCenterRule = lens getter setter - where - getter :: GameState -> ViewCenterRule - getter = _viewCenterRule - - -- The setter takes care of updating 'viewCenter' and 'focusedRobot' - -- So non of this fields get out of sync. - setter :: GameState -> ViewCenterRule -> GameState - setter g rule = - case rule of - VCLocation loc -> g {_viewCenterRule = rule, _viewCenter = loc} - VCRobot rid -> - let robotcenter = g ^? robotMap . ix rid . robotLocation - in -- retrieve the loc of the robot if it exists, Nothing otherwise. - -- sometimes, lenses are amazing... - case robotcenter of - Nothing -> g - Just loc -> g {_viewCenterRule = rule, _viewCenter = loc, _focusedRobotID = rid} - --- | Whether the repl is currently working. -replWorking :: Getter GameControls Bool -replWorking = to (\s -> matchesWorking $ s ^. replStatus) - where - matchesWorking (REPLDone _) = False - matchesWorking (REPLWorking _) = True - --- | Either the type of the command being executed, or of the last command -replActiveType :: Getter REPLStatus (Maybe Polytype) -replActiveType = to getter - where - getter (REPLDone (Just (Typed _ typ _))) = Just typ - getter (REPLWorking (Typed _ typ _)) = Just typ - getter _ = Nothing - --- | Get the notification list of messages from the point of view of focused robot. -messageNotifications :: Getter GameState (Notifications LogEntry) -messageNotifications = to getNotif - where - getNotif gs = Notifications {_notificationsCount = length new, _notificationsContent = allUniq} - where - allUniq = uniq $ toList allMessages - 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) - 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 - -- other they have to get from log - latestMsg = messageIsRecent gs - closeMsg = messageIsFromNearby (gs ^. viewCenter) - generatedBy rid logEntry = case logEntry ^. leSource of - RobotLog _ rid' _ -> rid == rid' - _ -> False - - focusedOrLatestClose mq = - (Seq.take 1 . Seq.reverse . Seq.filter closeMsg $ Seq.takeWhileR latestMsg mq) - <> Seq.filter (generatedBy (gs ^. focusedRobotID)) mq - -messageIsRecent :: GameState -> LogEntry -> Bool -messageIsRecent gs e = addTicks 1 (e ^. leTime) >= gs ^. temporal . ticks - --- | Reconciles the possibilities of log messages being --- omnipresent and robots being in different worlds -messageIsFromNearby :: Cosmic Location -> LogEntry -> Bool -messageIsFromNearby l e = case e ^. leSource of - SystemLog -> True - RobotLog _ _ loc -> f loc - where - f logLoc = case cosmoMeasure manhattan l logLoc of - InfinitelyFar -> False - Measurable x -> x <= hearingDistance - --- | Given a current mapping from robot names to robots, apply a --- 'ViewCenterRule' to derive the location it refers to. The result --- is 'Maybe' because the rule may refer to a robot which does not --- exist. -applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location) -applyViewCenterRule (VCLocation l) _ = Just l -applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation - --- | Recalculate the view center (and cache the result in the --- 'viewCenter' field) based on the current 'viewCenterRule'. If --- the 'viewCenterRule' specifies a robot which does not exist, --- simply leave the current 'viewCenter' as it is. Set 'needsRedraw' --- if the view center changes. -recalcViewCenter :: GameState -> GameState -recalcViewCenter g = - g - { _viewCenter = newViewCenter - } - & (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id) - where - oldViewCenter = g ^. viewCenter - newViewCenter = - fromMaybe oldViewCenter $ - applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap) - --- | Modify the 'viewCenter' by applying an arbitrary function to the --- current value. Note that this also modifies the 'viewCenterRule' --- to match. After calling this function the 'viewCenterRule' will --- specify a particular location, not a robot. -modifyViewCenter :: (Cosmic Location -> Cosmic Location) -> GameState -> GameState -modifyViewCenter update g = - g - & case g ^. viewCenterRule of - VCLocation l -> viewCenterRule .~ VCLocation (update l) - VCRobot _ -> viewCenterRule .~ VCLocation (update (g ^. viewCenter)) - --- | "Unfocus" by modifying the view center rule to look at the --- current location instead of a specific robot, and also set the --- focused robot ID to an invalid value. In classic mode this --- causes the map view to become nothing but static. -unfocus :: GameState -> GameState -unfocus = (\g -> g {_focusedRobotID = -1000}) . modifyViewCenter id - --- | Given a width and height, compute the region, centered on the --- 'viewCenter', that should currently be in view. -viewingRegion :: Cosmic Location -> (Int32, Int32) -> Cosmic W.BoundsRectangle -viewingRegion (Cosmic sw (Location cx cy)) (w, h) = - Cosmic sw (W.Coords (rmin, cmin), W.Coords (rmax, cmax)) - where - (rmin, rmax) = over both (+ (-cy - h `div` 2)) (0, h - 1) - (cmin, cmax) = over both (+ (cx - w `div` 2)) (0, w - 1) - --- | Find out which robot has been last specified by the --- 'viewCenterRule', if any. -focusedRobot :: GameState -> Maybe Robot -focusedRobot g = g ^. robotMap . at (g ^. focusedRobotID) - --- | Type for describing how far away a robot is from the base, which --- determines what kind of communication can take place. -data RobotRange - = -- | Close; communication is perfect. - Close - | -- | Mid-range; communication is possible but lossy. - MidRange Double - | -- | Far; communication is not possible. - Far - deriving (Eq, Ord) - --- | Check how far away the focused robot is from the base. @Nothing@ --- is returned if there is no focused robot; otherwise, return a --- 'RobotRange' value as follows. --- --- * If we are in creative or scroll-enabled mode, the focused robot is --- always considered 'Close'. --- * Otherwise, there is a "minimum radius" and "maximum radius". --- --- * If the robot is within the minimum radius, it is 'Close'. --- * If the robot is between the minimum and maximum radii, it --- is 'MidRange', with a 'Double' value ranging linearly from --- 0 to 1 proportional to the distance from the minimum to --- maximum radius. For example, @MidRange 0.5@ would indicate --- a robot exactly halfway between the minimum and maximum --- radii. --- * If the robot is beyond the maximum radius, it is 'Far'. --- --- * By default, the minimum radius is 16, and maximum is 64. --- * Device augmentations --- --- * If the focused robot has an @antenna@ installed, it doubles --- both radii. --- * If the base has an @antenna@ installed, it also doubles both radii. -focusedRange :: GameState -> Maybe RobotRange -focusedRange g = checkRange <$ maybeFocusedRobot - where - maybeBaseRobot = g ^. robotMap . at 0 - maybeFocusedRobot = focusedRobot g - - checkRange = case r of - InfinitelyFar -> Far - Measurable r' -> computedRange r' - - computedRange r' - | g ^. creativeMode || g ^. landscape . worldScrollable || r' <= minRadius = Close - | r' > maxRadius = Far - | otherwise = MidRange $ (r' - minRadius) / (maxRadius - minRadius) - - -- Euclidean distance from the base to the view center. - r = case maybeBaseRobot of - -- if the base doesn't exist, we have bigger problems - Nothing -> InfinitelyFar - Just br -> cosmoMeasure euclidean (g ^. viewCenter) (br ^. robotLocation) - - (minRadius, maxRadius) = getRadioRange maybeBaseRobot maybeFocusedRobot - --- | Get the min/max communication radii given possible augmentations on each end -getRadioRange :: Maybe Robot -> Maybe Robot -> (Double, Double) -getRadioRange maybeBaseRobot maybeTargetRobot = - (minRadius, maxRadius) - where - -- See whether the base or focused robot have antennas installed. - baseInv, focInv :: Maybe Inventory - baseInv = view equippedDevices <$> maybeBaseRobot - focInv = view equippedDevices <$> maybeTargetRobot - - gain :: Maybe Inventory -> (Double -> Double) - gain (Just inv) - | countByName "antenna" inv > 0 = (* 2) - gain _ = id - - -- Range radii. Default thresholds are 16, 64; each antenna - -- boosts the signal by 2x. - minRadius, maxRadius :: Double - (minRadius, maxRadius) = over both (gain baseInv . gain focInv) (16, 64) - --- | Clear the 'robotLogUpdated' flag of the focused robot. -clearFocusedRobotLogUpdated :: (Has (State GameState) sig m) => m () -clearFocusedRobotLogUpdated = do - n <- use focusedRobotID - robotMap . ix n . robotLogUpdated .= False - --- | Add a concrete instance of a robot template to the game state: --- First, generate a unique ID number for it. Then, add it to the --- main robot map, the active robot set, and to to the index of --- robots by location. Return the updated robot. -addTRobot :: (Has (State GameState) sig m) => TRobot -> m Robot -addTRobot r = do - rid <- robotNaming . gensym <+= 1 - let r' = instantiateRobot rid r - addRobot r' - return r' - --- | Add a robot to the game state, adding it to the main robot map, --- the active robot set, and to to the index of robots by --- location. -addRobot :: (Has (State GameState) sig m) => Robot -> m () -addRobot r = do - let rid = r ^. robotID - - robotMap %= IM.insert rid r - addRobotToLocation rid $ r ^. robotLocation - internalActiveRobots %= IS.insert rid - --- | Helper function for updating the "robotsByLocation" bookkeeping -addRobotToLocation :: (Has (State GameState) 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)) - -maxMessageQueueSize :: Int -maxMessageQueueSize = 1000 - --- | Add a message to the message queue. -emitMessage :: (Has (State GameState) sig m) => LogEntry -> m () -emitMessage msg = messageInfo . messageQueue %= (|> msg) . dropLastIfLong - where - tooLong s = Seq.length s >= maxMessageQueueSize - dropLastIfLong whole@(_oldest :<| newer) = if tooLong whole then newer else whole - dropLastIfLong emptyQueue = emptyQueue - --- | Takes a robot out of the 'activeRobots' set and puts it in the 'waitingRobots' --- queue. -sleepUntil :: (Has (State GameState) sig m) => RID -> TickNumber -> m () -sleepUntil rid time = do - internalActiveRobots %= IS.delete rid - internalWaitingRobots . at time . non [] %= (rid :) - --- | Takes a robot out of the 'activeRobots' set. -sleepForever :: (Has (State GameState) sig m) => RID -> m () -sleepForever rid = internalActiveRobots %= IS.delete rid - --- | Adds a robot to the 'activeRobots' set. -activateRobot :: (Has (State GameState) sig m) => RID -> m () -activateRobot rid = internalActiveRobots %= IS.insert rid - --- | Removes robots whose wake up time matches the current game ticks count --- from the 'waitingRobots' queue and put them back in the 'activeRobots' set --- if they still exist in the keys of 'robotMap'. -wakeUpRobotsDoneSleeping :: (Has (State GameState) sig m) => m () -wakeUpRobotsDoneSleeping = do - time <- use $ temporal . ticks - mrids <- internalWaitingRobots . at time <<.= Nothing - case mrids of - Nothing -> return () - Just rids -> do - robots <- use robotMap - let aliveRids = filter (`IM.member` robots) rids - internalActiveRobots %= IS.union (IS.fromList aliveRids) - - -- These robots' wake times may have been moved "forward" - -- by 'wakeWatchingRobots'. - clearWatchingRobots rids - --- | Clear the "watch" state of all of the --- awakened robots -clearWatchingRobots :: - (Has (State GameState) sig m) => - [RID] -> - m () -clearWatchingRobots rids = do - robotsWatching %= M.map (`S.difference` S.fromList 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. --- --- NOTE: Clearing 'TickNumber' map entries from 'internalWaitingRobots' --- upon wakeup is handled by 'wakeUpRobotsDoneSleeping' -wakeWatchingRobots :: (Has (State GameState) sig m) => Cosmic Location -> m () -wakeWatchingRobots loc = do - currentTick <- use $ temporal . ticks - waitingMap <- use waitingRobots - rMap <- use robotMap - watchingMap <- use robotsWatching - - -- The bookkeeping updates to robot waiting - -- states are prepared in 4 steps... - - let -- Step 1: Identify the robots that are watching this location. - botsWatchingThisLoc :: [Robot] - botsWatchingThisLoc = - mapMaybe (`IM.lookup` rMap) $ - S.toList $ - M.findWithDefault mempty 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 - - -- 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 - 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 - - -- Step 4: Re-add the watching bots to be awakened at the next tick: - wakeableBotIds = map fst wakeTimes - newWakeTime = addTicks 1 currentTick - newInsertions = M.singleton newWakeTime wakeableBotIds - - -- NOTE: There are two "sources of truth" for the waiting state of robots: - -- 1. In the GameState via "internalWaitingRobots" - -- 2. In each robot, via the CESK machine state - - -- 1. Update the game state - internalWaitingRobots .= M.unionWith (<>) filteredWaiting newInsertions - - -- 2. Update the machine of each robot - forM_ wakeableBotIds $ \rid -> - robotMap . at rid . _Just . machine %= \case - Waiting _ c -> Waiting newWakeTime c - x -> x - -deleteRobot :: (Has (State GameState) sig m) => RID -> m () -deleteRobot rn = do - internalActiveRobots %= IS.delete rn - mrobot <- robotMap . at rn <<.= Nothing - mrobot `forM_` \robot -> do - -- Delete the robot from the index of robots by location. - removeRobotFromLocationMap (robot ^. robotLocation) rn - --- | Makes sure empty sets don't hang around in the --- 'robotsByLocation' map. We don't want a key with an --- empty set at every location any robot has ever --- visited! -removeRobotFromLocationMap :: - (Has (State GameState) sig m) => - Cosmic Location -> - 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 - ------------------------------------------------------------- --- Initialization ------------------------------------------------------------- - -type LaunchParams a = ParameterizableLaunchParams CodeToRun a - --- | In this stage in the UI pipeline, both fields --- have already been validated, and "Nothing" means --- that the field is simply absent. -type ValidatedLaunchParams = LaunchParams Identity - --- | Record to pass information needed to create an initial --- 'GameState' record when starting a scenario. -data GameStateConfig = GameStateConfig - { initNameParts :: NameGenerator - , initEntities :: EntityMap - , initRecipes :: [Recipe Entity] - , initWorldMap :: WorldMap - } - --- | Create an initial, fresh game state record when starting a new scenario. -initGameState :: GameStateConfig -> GameState -initGameState gsc = - GameState - { _creativeMode = False - , _temporal = - TemporalState - { _gameStep = WorldTick - , _runStatus = Running - , _ticks = TickNumber 0 - , _robotStepsPerTick = defaultRobotStepsPerTick - } - , _winCondition = NoWinCondition - , _winSolution = Nothing - , _robotMap = IM.empty - , _robotsByLocation = M.empty - , _robotsWatching = mempty - , _discovery = - Discovery - { _availableRecipes = mempty - , _availableCommands = mempty - , _allDiscoveredEntities = empty - , _knownEntities = [] - , -- This does not need to be initialized with anything, - -- since the master list of achievements is stored in UIState - _gameAchievements = mempty - } - , _activeRobots = IS.empty - , _waitingRobots = M.empty - , _seed = 0 - , _randGen = mkStdGen 0 - , _robotNaming = - RobotNaming - { _nameGenerator = initNameParts gsc - , _gensym = 0 - } - , _recipesInfo = - Recipes - { _recipesOut = outRecipeMap (initRecipes gsc) - , _recipesIn = inRecipeMap (initRecipes gsc) - , _recipesCat = catRecipeMap (initRecipes gsc) - } - , _currentScenarioPath = Nothing - , _landscape = - Landscape - { _worldNavigation = Navigation mempty mempty - , _multiWorld = mempty - , _entityMap = initEntities gsc - , _worldScrollable = True - } - , _viewCenterRule = VCRobot 0 - , _viewCenter = defaultCosmicLocation - , _needsRedraw = False - , _gameControls = - GameControls - { _replStatus = REPLDone Nothing - , _replNextValueIndex = 0 - , _inputHandler = Nothing - , _initiallyRunCode = Nothing - } - , _messageInfo = - Messages - { _messageQueue = Empty - , _lastSeenMessageTime = TickNumber (-1) - , _announcementQueue = mempty - } - , _focusedRobotID = 0 - } - -type SubworldDescription = (SubworldName, ([IndexedTRobot], Seed -> WorldFun Int Entity)) - -buildWorldTuples :: Scenario -> NonEmpty SubworldDescription -buildWorldTuples s = - NE.map (worldName &&& buildWorld) $ - s ^. scenarioWorlds - -genMultiWorld :: NonEmpty SubworldDescription -> Seed -> W.MultiWorld Int Entity -genMultiWorld worldTuples s = - M.map genWorld - . M.fromList - . NE.toList - $ worldTuples - where - genWorld x = W.newWorld $ snd x s - --- | --- Returns a list of robots, ordered by decreasing preference --- to serve as the "base". --- --- = Rules for selecting the "base" robot: --- --- What follows is a thorough description of how the base --- choice is made as of the most recent study of the code. --- This level of detail is not meant to be public-facing. --- --- For an abbreviated explanation, see the "Base robot" section of the --- . --- --- == Precedence rules --- --- 1. Prefer those robots defined with a @loc@ ('robotLocation') in the scenario file --- --- 1. If multiple robots define a @loc@, use the robot that is defined --- first within the scenario file. --- 2. Note that if a robot is both given a @loc@ AND is specified in the --- world map, then two instances of the robot shall be created. The --- instance with the @loc@ shall be preferred as the base. --- --- 2. Fall back to robots generated from templates via the map and palette. --- --- 1. If multiple robots are specified in the map, prefer the one that --- is defined first within the scenario file. --- 2. If multiple robots are instantiated from the same template, then --- prefer the one with a lower-indexed subworld. Note that the root --- subworld is always first. --- 3. If multiple robots instantiated from the same template are in the --- same subworld, then --- prefer the one closest to the upper-left of the screen, with higher --- rows given precedence over columns (i.e. first in row-major order). -genRobotTemplates :: Scenario -> NonEmpty (a, ([(Int, TRobot)], b)) -> [TRobot] -genRobotTemplates scenario worldTuples = - locatedRobots ++ map snd (sortOn fst genRobots) - where - -- Keep only robots from the robot list with a concrete location; - -- the others existed only to serve as a template for robots drawn - -- in the world map - locatedRobots = filter (isJust . view trobotLocation) $ scenario ^. scenarioRobots - - -- Subworld order as encountered in the scenario YAML file is preserved for - -- the purpose of numbering robots, other than the "root" subworld - -- guaranteed to be first. - genRobots :: [(Int, TRobot)] - genRobots = concat $ NE.toList $ NE.map (fst . snd) worldTuples - --- | Create an initial game state corresponding to the given scenario. -scenarioToGameState :: - Scenario -> - ValidatedLaunchParams -> - GameStateConfig -> - IO GameState -scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) gsc = do - -- Decide on a seed. In order of preference, we will use: - -- 1. seed value provided by the user - -- 2. seed value specified in the scenario description - -- 3. randomly chosen seed value - theSeed <- case userSeed <|> scenario ^. scenarioSeed of - Just s -> return s - Nothing -> randomRIO (0, maxBound :: Int) - - now <- Clock.getTime Clock.Monotonic - let robotList' = (robotCreatedAt .~ now) <$> robotList - - let modifyRecipesInfo oldRecipesInfo = - oldRecipesInfo - & recipesOut %~ addRecipesWith outRecipeMap - & recipesIn %~ addRecipesWith inRecipeMap - & recipesCat %~ addRecipesWith catRecipeMap - - return $ - (initGameState gsc) - { _focusedRobotID = baseID - } - & creativeMode .~ scenario ^. scenarioCreative - & winCondition .~ theWinCondition - & winSolution .~ scenario ^. scenarioSolution - & robotMap .~ IM.fromList (map (view robotID &&& id) robotList') - & robotsByLocation .~ M.map (groupRobotsByPlanarLocation . NE.toList) (groupRobotsBySubworld robotList') - & internalActiveRobots .~ setOf (traverse . robotID) robotList' - & discovery . availableCommands .~ Notifications 0 initialCommands - & discovery . knownEntities .~ scenario ^. scenarioKnown - & robotNaming . gensym .~ initGensym - & seed .~ theSeed - & randGen .~ mkStdGen theSeed - & recipesInfo %~ modifyRecipesInfo - & landscape . entityMap .~ em - & landscape . worldNavigation .~ scenario ^. scenarioNavigation - & landscape . multiWorld .~ genMultiWorld worldTuples theSeed - -- 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. - & landscape . worldScrollable .~ NE.head (scenario ^. scenarioWorlds) ^. to scrollable - & viewCenterRule .~ VCRobot baseID - & gameControls . initiallyRunCode .~ 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 - True -> REPLWorking (Typed Nothing PolyUnit mempty) - & temporal . robotStepsPerTick .~ ((scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick) - where - groupRobotsBySubworld = - binTuples . map (view (robotLocation . subworld) &&& id) - - groupRobotsByPlanarLocation rs = - M.fromListWith - IS.union - (map (view (robotLocation . planar) &&& (IS.singleton . view robotID)) rs) - - em = initEntities gsc <> scenario ^. scenarioEntities - baseID = 0 - (things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em)) - - getCodeToRun (CodeToRun _ s) = s - - robotsByBasePrecedence = genRobotTemplates scenario worldTuples - - initialCodeToRun = getCodeToRun <$> toRun - - robotList = - zipWith instantiateRobot [baseID ..] robotsByBasePrecedence - -- If the --run flag was used, use it to replace the CESK machine of the - -- robot whose id is 0, i.e. the first robot listed in the scenario. - -- Note that this *replaces* any program the base robot otherwise - -- would have run (i.e. any program specified in the program: field - -- of the scenario description). - & ix baseID - . machine - %~ case initialCodeToRun of - Nothing -> id - Just pt -> const $ initMachine pt Ctx.empty emptyStore - -- If we are in creative mode, give base all the things - & ix baseID - . robotInventory - %~ case scenario ^. scenarioCreative of - False -> id - True -> union (fromElems (map (0,) things)) - & ix baseID - . equippedDevices - %~ case scenario ^. scenarioCreative of - False -> id - True -> const (fromList devices) - - running = case robotList of - [] -> False - (base : _) -> isNothing (finalValue (base ^. machine)) - - -- Initial list of available commands = all commands enabled by - -- devices in inventory or equipped; and commands that require no - -- capability. - allCapabilities r = - inventoryCapabilities (r ^. equippedDevices) - <> inventoryCapabilities (r ^. robotInventory) - initialCaps = mconcat $ map allCapabilities robotList - initialCommands = - filter - (maybe True (`S.member` initialCaps) . constCaps) - allConst - - worldTuples = buildWorldTuples scenario - - theWinCondition = - maybe - NoWinCondition - (\x -> WinConditions Ongoing (ObjectiveCompletion (CompletionBuckets (NE.toList x) mempty mempty) mempty)) - (NE.nonEmpty (scenario ^. scenarioObjectives)) - - initGensym = length robotList - 1 - addRecipesWith f = IM.unionWith (<>) (f $ scenario ^. scenarioRecipes) - --- | Take a world description, parsed from a scenario file, and turn --- it into a list of located robots and a world function. -buildWorld :: WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity) -buildWorld WorldDescription {..} = (robots worldName, first fromEnum . wf) - where - rs = fromIntegral $ length area - cs = fromIntegral $ maybe 0 length $ listToMaybe area - Coords (ulr, ulc) = locToCoords ul - - worldGrid :: [[(TerrainType, Erasable Entity)]] - worldGrid = (map . map) (cellTerrain &&& cellEntity) area - - worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity) - worldArray = listArray ((ulr, ulc), (ulr + rs - 1, ulc + cs - 1)) (concat worldGrid) - - dslWF, arrayWF :: Seed -> WorldFun TerrainType Entity - dslWF = maybe mempty ((applyWhen offsetOrigin findGoodOrigin .) . runWorld) worldProg - arrayWF = const (worldFunFromArray worldArray) - - wf = dslWF <> arrayWF - - -- Get all the robots described in cells and set their locations appropriately - robots :: SubworldName -> [IndexedTRobot] - robots swName = - area - & traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices - & concat - & concatMap - ( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robotList) -> - let robotWithLoc = trobotLocation ?~ Cosmic swName (W.coordsToLoc (Coords (ulr + r, ulc + c))) - in map (fmap robotWithLoc) robotList - ) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs deleted file mode 100644 --- a/src/Swarm/Game/Step.hs +++ /dev/null @@ -1,2870 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Facilities for stepping the robot CESK machines, /i.e./ the actual --- interpreter for the Swarm language. --- --- ** Note on the IO: --- --- The only reason we need @IO@ is so that robots can run programs --- loaded from files, via the 'Swarm.Language.Syntax.Run' command. --- This could be avoided by using a hypothetical @import@ command instead and parsing --- the required files at the time of declaration. --- See . -module Swarm.Game.Step where - -import Control.Applicative (Applicative (..)) -import Control.Arrow ((&&&)) -import Control.Carrier.Error.Either (ErrorC, runError) -import Control.Carrier.State.Lazy -import Control.Carrier.Throw.Either (ThrowC, runThrow) -import Control.Effect.Error -import Control.Effect.Lens -import Control.Effect.Lift -import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) -import Control.Monad (foldM, forM, forM_, guard, msum, unless, when, zipWithM) -import Data.Bifunctor (second) -import Data.Bool (bool) -import Data.Char (chr, ord) -import Data.Either (partitionEithers, rights) -import Data.Foldable (asum, for_, traverse_) -import Data.Foldable.Extra (findM, firstJustM) -import Data.Function (on) -import Data.Functor (void) -import Data.Int (Int32) -import Data.IntMap qualified as IM -import Data.IntSet qualified as IS -import Data.List (find, sortOn) -import Data.List qualified as L -import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) -import Data.Ord (Down (Down)) -import Data.Sequence ((><)) -import Data.Sequence qualified as Seq -import Data.Set (Set) -import Data.Set qualified as S -import Data.Text (Text) -import Data.Text qualified as T -import Data.Time (getZonedTime) -import Data.Tuple (swap) -import Linear (V2 (..), perp, zero) -import Prettyprinter (pretty) -import Swarm.Game.Achievement.Attainment -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.Location -import Swarm.Game.Recipe -import Swarm.Game.ResourceLoading (getDataFileNameSafe) -import Swarm.Game.Robot -import Swarm.Game.Scenario.Objective qualified as OB -import Swarm.Game.Scenario.Objective.WinCheck qualified as WC -import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation) -import Swarm.Game.Scenario.Topography.Navigation.Util -import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..)) -import Swarm.Game.State -import Swarm.Game.Step.Combustion qualified as Combustion -import Swarm.Game.Step.Pathfinding -import Swarm.Game.Step.Util -import Swarm.Game.Universe -import Swarm.Game.Value -import Swarm.Game.World qualified as W -import Swarm.Language.Capability -import Swarm.Language.Context hiding (delete) -import Swarm.Language.Key (parseKeyComboFull) -import Swarm.Language.Parse (runParser) -import Swarm.Language.Pipeline -import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText) -import Swarm.Language.Requirement qualified as R -import Swarm.Language.Syntax -import Swarm.Language.Text.Markdown qualified as Markdown -import Swarm.Language.Typed (Typed (..)) -import Swarm.Language.Value -import Swarm.Log -import Swarm.Util hiding (both) -import Swarm.Util.Effect (throwToMaybe) -import Swarm.Util.WindowedCounter qualified as WC -import System.Clock (TimeSpec) -import Witch (From (from), into) -import Prelude hiding (Applicative (..), lookup) - --- | The main function to do one game tick. --- --- Note that the game may be in 'RobotStep' mode and not finish --- the tick. Use the return value to check whether a full tick happened. -gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m Bool -gameTick = do - wakeUpRobotsDoneSleeping - active <- use activeRobots - focusedRob <- use focusedRobotID - - ticked <- - use (temporal . gameStep) >>= \case - WorldTick -> do - runRobotIDs active - temporal . ticks %= addTicks 1 - pure True - RobotStep ss -> singleStep ss focusedRob active - - -- See if the base is finished with a computation, and if so, record - -- the result in the game state so it can be displayed by the REPL; - -- also save the current store into the robotContext so we can - -- restore it the next time we start a computation. - mr <- use (robotMap . at 0) - case mr of - Just r -> do - res <- use $ gameControls . replStatus - case res of - REPLWorking (Typed Nothing ty req) -> case getResult r of - Just (v, s) -> do - gameControls . replStatus .= REPLWorking (Typed (Just v) ty req) - baseRobot . robotContext . defStore .= s - Nothing -> pure () - _otherREPLStatus -> pure () - Nothing -> pure () - - -- Possibly update the view center. - modify recalcViewCenter - - when ticked $ do - -- On new tick see if the winning condition for the current objective is met. - wc <- use winCondition - case wc of - WinConditions winState oc -> do - g <- get @GameState - em <- use $ landscape . entityMap - hypotheticalWinCheck em g winState oc - _ -> pure () - return ticked - --- | Finish a game tick in progress and set the game to 'WorldTick' mode afterwards. --- --- Use this function if you need to unpause the game. -finishGameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m () -finishGameTick = - use (temporal . gameStep) >>= \case - WorldTick -> pure () - RobotStep SBefore -> temporal . gameStep .= WorldTick - RobotStep _ -> void gameTick >> finishGameTick - --- Insert the robot back to robot map. --- Will selfdestruct or put the robot to sleep if it has that set. -insertBackRobot :: Has (State GameState) sig m => RID -> Robot -> m () -insertBackRobot rn rob = do - time <- use $ temporal . ticks - if rob ^. selfDestruct - then deleteRobot rn - else do - robotMap %= IM.insert rn rob - case waitingUntil rob of - Just wakeUpTime - -- if w=2 t=1 then we do not needlessly put robot to waiting queue - | wakeUpTime <= addTicks 2 time -> return () - | otherwise -> sleepUntil rn wakeUpTime - Nothing -> - unless (isActive rob) (sleepForever rn) - --- Run a set of robots - this is used to run robots before/after the focused one. -runRobotIDs :: (Has (State GameState) sig m, Has (Lift IO) sig m) => IS.IntSet -> m () -runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do - mr <- uses robotMap (IM.lookup rn) - forM_ mr (stepOneRobot rn) - where - stepOneRobot rn rob = tickRobot rob >>= insertBackRobot rn - --- This is a helper function to do one robot step or run robots before/after. -singleStep :: (Has (State GameState) sig m, Has (Lift IO) sig m) => SingleStep -> RID -> IS.IntSet -> m Bool -singleStep ss focRID robotSet = do - let (preFoc, focusedActive, postFoc) = IS.splitMember focRID robotSet - case ss of - ---------------------------------------------------------------------------- - -- run robots from the beginning until focused robot - SBefore -> do - runRobotIDs preFoc - temporal . gameStep .= RobotStep (SSingle focRID) - -- also set ticks of focused robot - steps <- use $ temporal . robotStepsPerTick - robotMap . ix focRID . activityCounts . tickStepBudget .= steps - -- continue to focused robot if there were no previous robots - -- DO NOT SKIP THE ROBOT SETUP above - if IS.null preFoc - then singleStep (SSingle focRID) focRID robotSet - else return False - ---------------------------------------------------------------------------- - -- run single step of the focused robot (may skip if inactive) - SSingle rid | not focusedActive -> do - singleStep (SAfter rid) rid postFoc -- skip inactive focused robot - SSingle rid -> do - mOldR <- uses robotMap (IM.lookup focRID) - case mOldR of - Nothing | rid == focRID -> do - debugLog "The debugged robot does not exist! Exiting single step mode." - runRobotIDs postFoc - temporal . gameStep .= WorldTick - temporal . ticks %= addTicks 1 - return True - Nothing | otherwise -> do - debugLog "The previously debugged robot does not exist!" - singleStep SBefore focRID postFoc - Just oldR -> do - -- if focus changed we need to finish the previous robot - newR <- (if rid == focRID then stepRobot else tickRobotRec) oldR - insertBackRobot focRID newR - if rid == focRID - then do - when (newR ^. activityCounts . tickStepBudget == 0) $ - temporal . gameStep .= RobotStep (SAfter focRID) - return False - else do - -- continue to newly focused - singleStep SBefore focRID postFoc - ---------------------------------------------------------------------------- - -- run robots after the focused robot - SAfter rid | focRID <= rid -> do - -- This state takes care of two possibilities: - -- 1. normal - rid == focRID and we finish the tick - -- 2. changed focus and the newly focused robot has previously run - -- so we just finish the tick the same way - runRobotIDs postFoc - temporal . gameStep .= RobotStep SBefore - temporal . ticks %= addTicks 1 - return True - SAfter rid | otherwise -> do - -- go to single step if new robot is focused - let (_pre, postRID) = IS.split rid robotSet - singleStep SBefore focRID postRID - where - h = hypotheticalRobot (Out VUnit emptyStore []) 0 - debugLog txt = do - m <- evalState @Robot h $ createLogEntry RobotError Debug txt - emitMessage m - --- | An accumulator for folding over the incomplete --- objectives to evaluate for their completion -data CompletionsWithExceptions = CompletionsWithExceptions - { exceptions :: [Text] - , completions :: ObjectiveCompletion - , completionAnnouncementQueue :: [OB.Objective] - -- ^ Upon completion, an objective is enqueued. - -- It is dequeued when displayed on the UI. - } - --- | Execute the win condition check *hypothetically*: i.e. in a --- fresh CESK machine, using a copy of the current game state. --- --- The win check is performed only on "active" goals; that is, --- the goals that are currently unmet and have had all of their --- prerequisites satisfied. --- Note that it may be possible, while traversing through the --- goal list, for one goal to be met earlier in the list that --- happens to be a prerequisite later in the traversal. This --- is why: --- 1) We must not pre-filter the goals to be traversed based --- on satisfied prerequisites (i.e. we cannot use the --- "getActiveObjectives" function). --- 2) The traversal order must be "reverse topological" order, so --- that prerequisites are evaluated before dependent goals. --- 3) The iteration needs to be a "fold", so that state is updated --- after each element. -hypotheticalWinCheck :: - (Has (State GameState) sig m, Has (Lift IO) sig m) => - EntityMap -> - GameState -> - WinStatus -> - ObjectiveCompletion -> - m () -hypotheticalWinCheck em g ws oc = do - -- We can fully and accurately evaluate the new state of the objectives DAG - -- in a single pass, so long as we visit it in reverse topological order. - -- - -- N.B. The "reverse" is essential due to the re-population of the - -- "incomplete" goal list by cons-ing. - finalAccumulator <- - foldM foldFunc initialAccumulator $ - reverse incompleteGoals - - let newWinState = case ws of - Ongoing -> getNextWinState $ completions finalAccumulator - _ -> ws - - winCondition .= WinConditions newWinState (completions finalAccumulator) - - case newWinState of - Unwinnable _ -> do - grantAchievement LoseScenario - _ -> return () - - messageInfo . announcementQueue %= (>< Seq.fromList (map ObjectiveCompleted $ completionAnnouncementQueue finalAccumulator)) - - mapM_ handleException $ exceptions finalAccumulator - where - getNextWinState completedObjs - | WC.didWin completedObjs = Won False - | WC.didLose completedObjs = Unwinnable False - | otherwise = Ongoing - - (withoutIncomplete, incompleteGoals) = OB.extractIncomplete oc - initialAccumulator = CompletionsWithExceptions [] withoutIncomplete [] - - -- All of the "incomplete" goals have been emptied from the initial accumulator, and - -- these are what we iterate over with the fold. - -- Each iteration, we either place the goal back into the "incomplete" bucket, or - -- we determine that it has been met or impossible and place it into the "completed" - -- or "unwinnable" bucket, respectively. - foldFunc (CompletionsWithExceptions exnTexts currentCompletions announcements) obj = do - v <- - if WC.isPrereqsSatisfied currentCompletions obj - then runThrow @Exn . evalState @GameState g $ evalPT $ obj ^. OB.objectiveCondition - else return $ Right $ VBool False - let simplified = simplifyResult $ stripVResult <$> v - return $ case simplified of - Left exnText -> - CompletionsWithExceptions - (exnText : exnTexts) - -- Push back the incomplete goal that had been popped for inspection - (OB.addIncomplete obj currentCompletions) - announcements - Right boolResult -> - CompletionsWithExceptions - exnTexts - -- Either restore the goal to the incomplete list from which it was popped - -- or move it to the complete (or unwinnable) bucket. - (modifyCompletions obj currentCompletions) - (modifyAnnouncements announcements) - where - (modifyCompletions, modifyAnnouncements) - | boolResult = (OB.addCompleted, (obj :)) - | WC.isUnwinnable currentCompletions obj = (OB.addUnwinnable, id) - | otherwise = (OB.addIncomplete, id) - - simplifyResult = \case - Left exn -> Left $ formatExn em exn - Right (VBool x) -> Right x - Right val -> - Left $ - 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 - handleException exnText = do - m <- evalState @Robot h $ createLogEntry RobotError Critical exnText - emitMessage m - where - h = hypotheticalRobot (Out VUnit emptyStore []) 0 - -evalPT :: - (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) => - ProcessedTerm -> - m Value -evalPT t = evaluateCESK (initMachine t empty emptyStore) - --- | Create a special robot to check some hypothetical, for example the win condition. --- --- Use ID (-1) so it won't conflict with any robots currently in the robot map. -hypotheticalRobot :: CESK -> TimeSpec -> Robot -hypotheticalRobot c = - mkRobot - (-1) - Nothing - "hypothesis" - mempty - defaultCosmicLocation - zero - defaultRobotDisplay - c - [] - [] - True - False - mempty - -evaluateCESK :: - (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) => - CESK -> - m Value -evaluateCESK cesk = do - createdAt <- getNow - let r = hypotheticalRobot cesk createdAt - addRobot r -- Add the special robot to the robot map, so it can look itself up if needed - evalState r . runCESK $ cesk - -runCESK :: - ( Has (Lift IO) sig m - , Has (Throw Exn) sig m - , Has (State GameState) sig m - , Has (State Robot) sig m - ) => - CESK -> - m Value -runCESK (Up exn _ []) = throwError exn -runCESK cesk = case finalValue cesk of - Just (v, _) -> return v - Nothing -> stepCESK cesk >>= runCESK - ------------------------------------------------------------- --- Debugging ------------------------------------------------------------- - --- | Create a log entry given current robot and game time in ticks --- noting whether it has been said. --- --- This is the more generic version used both for (recorded) said --- messages and normal logs. -createLogEntry :: - (Has (State GameState) sig m, Has (State Robot) sig m) => - RobotLogSource -> - Severity -> - Text -> - m LogEntry -createLogEntry source sev msg = do - rid <- use robotID - rn <- use robotName - time <- use $ temporal . ticks - loc <- use robotLocation - pure $ LogEntry time (RobotLog source rid loc) sev rn msg - --- | Print some text via the robot's log. -traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => RobotLogSource -> Severity -> Text -> m LogEntry -traceLog source sev msg = do - m <- createLogEntry source sev msg - robotLog %= (Seq.|> m) - return m - --- | Print a showable value via the robot's log. --- --- Useful for debugging. -traceLogShow :: (Has (State GameState) sig m, Has (State Robot) sig m, Show a) => a -> m () -traceLogShow = void . traceLog Logged Info . from . show - ------------------------------------------------------------- --- Exceptions and validation ------------------------------------------------------------- - --- | Capabilities needed for a specific robot to evaluate or execute a --- constant. Right now, the only difference is whether the robot is --- heavy or not when executing the 'Swarm.Language.Syntax.Move' command, but there might --- be other exceptions added in the future. -constCapsFor :: Const -> Robot -> Maybe Capability -constCapsFor Move r - | r ^. robotHeavy = Just CMoveheavy -constCapsFor Backup r - | r ^. robotHeavy = Just CMoveheavy -constCapsFor Stride r - | r ^. robotHeavy = Just CMoveheavy -constCapsFor c _ = constCaps c - --- | Ensure that a robot is capable of executing a certain constant --- (either because it has a device which gives it that capability, --- or it is a system robot, or we are in creative mode). -ensureCanExecute :: (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Const -> m () -ensureCanExecute c = - gets @Robot (constCapsFor c) >>= \case - Nothing -> pure () - Just cap -> do - isPrivileged <- isPrivilegedBot - robotCaps <- use robotCapabilities - let hasCaps = cap `S.member` robotCaps - (isPrivileged || hasCaps) - `holdsOr` Incapable FixByEquip (R.singletonCap cap) (TConst c) - --- | Create an exception about a command failing, with an achievement -cmdExnWithAchievement :: Const -> [Text] -> GameplayAchievement -> Exn -cmdExnWithAchievement c parts a = CmdFailed c (T.unwords parts) $ Just a - --- | Raise an exception about a command failing with a formatted error message. -raise :: (Has (Throw Exn) sig m) => Const -> [Text] -> m a -raise c parts = throwError (cmdExn c parts) - --- | Run a subcomputation that might throw an exception in a context --- where we are returning a CESK machine; any exception will be --- turned into an 'Up' state. -withExceptions :: Monad m => Store -> Cont -> ThrowC Exn m CESK -> m CESK -withExceptions s k m = do - res <- runThrow m - case res of - Left exn -> return $ Up exn s k - Right a -> return a - ------------------------------------------------------------- --- Stepping robots ------------------------------------------------------------- - --- | Run a robot for one tick, which may consist of up to --- 'robotStepsPerTick' CESK machine steps and at most one tangible --- command execution, whichever comes first. -tickRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot -tickRobot r = do - steps <- use $ temporal . robotStepsPerTick - tickRobotRec (r & activityCounts . tickStepBudget .~ steps) - --- | Recursive helper function for 'tickRobot', which checks if the --- robot is actively running and still has steps left, and if so --- runs it for one step, then calls itself recursively to continue --- stepping the robot. -tickRobotRec :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot -tickRobotRec r = do - time <- use $ temporal . ticks - case wantsToStep time r && (r ^. runningAtomic || r ^. activityCounts . tickStepBudget > 0) of - True -> stepRobot r >>= tickRobotRec - False -> return r - --- | Single-step a robot by decrementing its 'tickStepBudget' counter and --- running its CESK machine for one step. -stepRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot -stepRobot r = do - (r', cesk') <- runState (r & activityCounts . tickStepBudget -~ 1) (stepCESK (r ^. machine)) - -- sendIO $ appendFile "out.txt" (prettyString cesk' ++ "\n") - t <- use $ temporal . ticks - - isCreative <- use creativeMode - let shouldTrackActivity = isCreative || not (r' ^. systemRobot) - - return $ - applyWhen shouldTrackActivity (maintainActivityWindow t) $ - r' - & machine .~ cesk' - & activityCounts . lifetimeStepCount +~ 1 - where - maintainActivityWindow t bot = - bot & (activityCounts . activityWindow %~ WC.insert t) - --- | replace some entity in the world with another entity -updateWorld :: - (Has (State GameState) sig m, Has (Throw Exn) sig m) => - Const -> - WorldUpdate Entity -> - m () -updateWorld c (ReplaceEntity loc eThen down) = do - w <- use $ landscape . multiWorld - let eNow = W.lookupCosmicEntity (fmap W.locToCoords loc) w - -- Can fail if a robot started a multi-tick "drill" operation on some entity - -- and meanwhile another entity swaps it out from under them. - if Just eThen /= eNow - then throwError $ cmdExn c ["The", eThen ^. entityName, "is not there."] - else updateEntityAt loc $ const down - -applyRobotUpdates :: - (Has (State GameState) sig m, Has (State Robot) sig m) => - [RobotUpdate] -> - m () -applyRobotUpdates = - mapM_ \case - AddEntity c e -> robotInventory %= E.insertCount c e - LearnEntity e -> robotInventory %= E.insertCount 0 e - -data SKpair = SKpair Store Cont - --- | Performs some side-effectful computation --- for an "FImmediate" Frame. --- Aborts processing the continuation stack --- if an error is encountered. --- --- Compare to "withExceptions". -processImmediateFrame :: - (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => - Value -> - SKpair -> - -- | the unreliable computation - ErrorC Exn m () -> - m CESK -processImmediateFrame v (SKpair s k) unreliableComputation = do - wc <- runError unreliableComputation - case wc of - Left exn -> return $ Up exn s k - Right () -> stepCESK $ Out v s k - -updateWorldAndRobots :: - (HasRobotStepState sig m) => - Const -> - [WorldUpdate Entity] -> - [RobotUpdate] -> - m () -updateWorldAndRobots cmd wf rf = do - mapM_ (updateWorld cmd) wf - applyRobotUpdates rf - flagRedraw - --- | The main CESK machine workhorse. Given a robot, look at its CESK --- machine state and figure out a single next step. -stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => CESK -> m CESK -stepCESK cesk = case cesk of - ------------------------------------------------------------ - -- Evaluation - - -- We wake up robots whose wake-up time has been reached. If it hasn't yet - -- then stepCESK is a no-op. - Waiting wakeupTime cesk' -> do - time <- use $ temporal . ticks - if wakeupTime <= time - then stepCESK cesk' - else return cesk - Out v s (FImmediate cmd wf rf : k) -> - processImmediateFrame v (SKpair s k) $ - updateWorldAndRobots cmd wf rf - -- Now some straightforward cases. These all immediately turn - -- into values. - In TUnit _ s k -> return $ Out VUnit s k - In (TDir d) _ s k -> return $ Out (VDir d) s k - 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 - -- 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 - In (TRequire {}) 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 - -- Normally it's not possible to have a TRobot value in surface - -- syntax, but the salvage command generates a program that needs to - -- refer directly to the salvaging robot. - In (TRobot rid) _ s k -> return $ Out (VRobot rid) s k - -- Function constants of arity 0 are evaluated immediately - -- (e.g. parent, self). Any other constant is turned into a VCApp, - -- which is waiting for arguments and/or an FExec frame. - In (TConst c) _ s k - | arity c == 0 && not (isCmd c) -> evalConst c [] s k - | otherwise -> return $ Out (VCApp c []) s k - -- To evaluate a variable, just look it up in the context. - In (TVar x) e s k -> withExceptions s k $ do - v <- - lookup x e - `isJustOr` Fatal (T.unwords ["Undefined variable", x, "encountered while running the interpreter."]) - return $ Out v s k - - -- To evaluate a pair, start evaluating the first component. - In (TPair t1 t2) e s k -> return $ In t1 e s (FSnd t2 e : k) - -- Once that's done, evaluate the second component. - Out v1 s (FSnd t2 e : k) -> return $ In t2 e s (FFst v1 : k) - -- Finally, put the results together into a pair value. - 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 - -- 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) - -- We can evaluate an application of a closure in the usual way. - Out v2 s (FApp (VClo x t e) : k) -> return $ In t (addBinding x v2 e) s k - -- We can also evaluate an application of a constant by collecting - -- arguments, eventually dispatching to evalConst for function - -- constants. - Out v2 s (FApp (VCApp c args) : k) - | not (isCmd c) - && arity c == length args + 1 -> - evalConst c (reverse (v2 : args)) s k - | otherwise -> return $ Out (VCApp c (v2 : args)) s k - Out _ s (FApp _ : _) -> badMachineState s "FApp of non-function" - -- Start evaluating a record. If it's empty, we're done. Otherwise, focus - -- on the first field and record the rest in a FRcd frame. - In (TRcd m) e s k -> return $ case M.assocs m of - [] -> Out (VRcd M.empty) s k - ((x, t) : fs) -> In (fromMaybe (TVar x) t) e s (FRcd e [] x fs : k) - -- When we finish evaluating the last field, return a record value. - Out v s (FRcd _ done x [] : k) -> return $ Out (VRcd (M.fromList ((x, v) : done))) s k - -- Otherwise, save the value of the field just evaluated and move on - -- to focus on evaluating the next one. - Out v s (FRcd e done x ((y, t) : rest) : k) -> - return $ In (fromMaybe (TVar y) t) e s (FRcd e ((x, v) : done) y rest : k) - -- Evaluate a record projection: evaluate the record and remember we - -- need to do the projection later. - In (TProj t x) e s k -> return $ In t e s (FProj x : k) - -- Do a record projection - Out v s (FProj x : k) -> case v of - VRcd m -> case M.lookup x m of - Nothing -> badMachineState s $ T.unwords ["Record projection for variable", x, "that does not exist"] - Just xv -> return $ Out xv s k - _ -> 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 _ t1 t2) e s k -> return $ In t1 e s (FLet x t2 e : k) - -- To evaluate recursive let expressions, we evaluate the memoized - -- delay of the let-bound expression. Every free occurrence of x - -- in the let-bound expression and the body has already been - -- rewritten by elaboration to 'force x'. - In (TLet True x _ t1 t2) e s k -> - return $ In (TDelay (MemoizedDelay $ Just x) t1) e s (FLet x t2 e : k) - -- Once we've finished with the let-binding, we switch to evaluating - -- the body in a suitably extended environment. - Out v1 s (FLet x t2 e : k) -> return $ In t2 (addBinding x v1 e) s k - -- Definitions immediately turn into VDef values, awaiting execution. - In tm@(TDef r x _ t) e s k -> withExceptions s k $ do - hasCapabilityFor CEnv tm - return $ Out (VDef r x t 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 t1 t2) e s k -> return $ Out (VBind mx t1 t2 e) s k - -- Simple (non-memoized) delay expressions immediately turn into - -- VDelay values, awaiting application of 'Force'. - In (TDelay SimpleDelay t) e s k -> return $ Out (VDelay t e) s k - -- For memoized delay expressions, we allocate a new cell in the store and - -- return a reference to it. - In (TDelay (MemoizedDelay x) t) e s k -> do - -- Note that if the delay expression is recursive, we add a - -- binding to the environment that wil be used to evaluate the - -- body, binding the variable to a reference to the memory cell we - -- just allocated for the body expression itself. As a fun aside, - -- notice how Haskell's recursion and laziness play a starring - -- role: @loc@ is both an output from @allocate@ and used as part - -- of an input! =D - let (loc, s') = allocate (maybe id (`addBinding` VRef loc) x e) t s - return $ Out (VRef loc) s' k - -- If we see an update frame, it means we're supposed to set the value - -- of a particular cell to the value we just finished computing. - Out v s (FUpdate loc : k) -> return $ Out v (setStore loc (V v) s) k - ------------------------------------------------------------ - -- Execution - - -- Executing a 'requirements' command generates an appropriate log message - -- listing the requirements of the given expression. - Out (VRequirements src t _) s (FExec : k) -> do - currentContext <- use $ robotContext . defReqs - em <- use $ landscape . entityMap - let (R.Requirements caps devs inv, _) = R.requirements currentContext t - - devicesForCaps, requiredDevices :: Set (Set Text) - -- possible devices to provide each required capability - devicesForCaps = S.map (S.fromList . map (^. entityName) . (`deviceForCap` em)) caps - -- outright required devices - requiredDevices = S.map S.singleton devs - - deviceSets :: Set (Set Text) - deviceSets = - -- Union together all required device sets, and remove any - -- device sets which are a superset of another set. For - -- example, if (grabber OR fast grabber OR harvester) is - -- required but (grabber OR fast grabber) is also required - -- then we might as well remove the first set, since - -- satisfying the second device set will automatically - -- satisfy the first. - removeSupersets $ devicesForCaps `S.union` requiredDevices - - reqLog = - prettyText $ - BulletList - (pretty $ T.unwords ["Requirements for", bquote src <> ":"]) - ( filter - (not . null . bulletListItems) - [ BulletList - "Equipment:" - (T.intercalate " OR " . S.toList <$> S.toList deviceSets) - , BulletList - "Inventory:" - ((\(e, n) -> e <> " " <> parens (showT n)) <$> M.assocs inv) - ] - ) - - _ <- traceLog Logged Info reqLog - return $ Out VUnit s k - - -- To execute a definition, we immediately turn the body into a - -- delayed value, so it will not even be evaluated until it is - -- called. We memoize both recursive and non-recursive definitions, - -- since the point of a definition is that it may be used many times. - Out (VDef r x t e) s (FExec : k) -> - return $ In (TDelay (MemoizedDelay $ bool Nothing (Just x) r) t) e s (FDef x : k) - -- Once we have finished evaluating the (memoized, delayed) body of - -- a definition, we return a special VResult value, which packages - -- up the return value from the @def@ command itself (@unit@) - -- together with the resulting environment (the variable bound to - -- the delayed value). - Out v s (FDef x : k) -> - return $ Out (VResult VUnit (singleton x v)) s k - -- To execute a constant application, delegate to the 'evalConst' - -- function. Set tickStepBudget to 0 if the command is supposed to take - -- a tick, so the robot won't take any more steps this tick. - Out (VCApp c args) s (FExec : k) -> do - when (isTangible c) $ activityCounts . tickStepBudget .= 0 - evalConst c (reverse args) s k - - -- Reset the runningAtomic flag when we encounter an FFinishAtomic frame. - Out v s (FFinishAtomic : k) -> do - runningAtomic .= False - return $ Out v s k - - -- Machinery for implementing the 'Swarm.Language.Syntax.MeetAll' command. - -- First case: done meeting everyone. - Out b s (FMeetAll _ [] : k) -> return $ Out b s k - -- More still to meet: apply the function to the current value b and - -- then the next robot id. This will result in a command which we - -- execute, discard any generated environment, and then pass the - -- result to continue meeting the rest of the robots. - Out b s (FMeetAll f (rid : rids) : k) -> - return $ Out b s (FApp f : FArg (TRobot rid) empty : FExec : FDiscardEnv : FMeetAll f rids : k) - -- To execute a bind expression, evaluate and execute the first - -- command, and remember the second for execution later. - Out (VBind mx c1 c2 e) s (FExec : k) -> return $ In c1 e s (FExec : FBind mx c2 e : k) - -- If first command completes with a value along with an environment - -- resulting from definition commands and/or binds, switch to - -- evaluating the second command of the bind. Extend the - -- environment with both the environment resulting from the first - -- command, as well as a binding for the result (if the bind was of - -- the form @x <- c1; c2@). Remember that we must execute the - -- second command once it has been evaluated, then union any - -- resulting definition environment with the definition environment - -- from the first command. - Out (VResult v ve) s (FBind mx t2 e : k) -> do - let ve' = maybe id (`addBinding` v) mx ve - return $ In t2 (e `union` ve') s (FExec : fUnionEnv ve' k) - -- If the first command completes with a simple value and there is no binder, - -- then we just continue without worrying about the environment. - Out _ s (FBind Nothing t2 e : k) -> return $ In t2 e s (FExec : k) - -- If the first command completes with a simple value and there is a binder, - -- we promote it to the returned environment as well. - Out v s (FBind (Just x) t2 e : k) -> do - return $ In t2 (addBinding x v e) s (FExec : fUnionEnv (singleton x v) k) - -- If a command completes with a value and definition environment, - -- and the next continuation frame contains a previous environment - -- to union with, then pass the unioned environments along in - -- another VResult. - - Out (VResult v e2) s (FUnionEnv e1 : k) -> return $ Out (VResult v (e1 `union` e2)) s k - -- Or, if a command completes with no environment, but there is a - -- previous environment to union with, just use that environment. - Out v s (FUnionEnv e : k) -> return $ Out (VResult v e) s k - -- If there's an explicit DiscardEnv frame, throw away any returned environment. - Out (VResult v _) s (FDiscardEnv : k) -> return $ Out v s k - Out v s (FDiscardEnv : k) -> return $ Out v s k - -- If the top of the continuation stack contains a 'FLoadEnv' frame, - -- it means we are supposed to load up the resulting definition - -- environment, store, and type and capability contexts into the robot's - -- top-level environment and contexts, so they will be available to - -- future programs. - Out (VResult v e) s (FLoadEnv ctx rctx : k) -> do - robotContext . defVals %= (`union` e) - robotContext . defTypes %= (`union` ctx) - robotContext . defReqs %= (`union` rctx) - return $ Out v s k - Out v s (FLoadEnv {} : k) -> return $ Out v s k - -- Any other type of value wiwth an FExec frame is an error (should - -- never happen). - Out _ s (FExec : _) -> badMachineState s "FExec frame with non-executable value" - -- If we see a VResult in any other context, simply discard it. For - -- example, this is what happens when there are binders (i.e. a "do - -- block") nested inside another block instead of at the top level. - -- It used to be that (1) only 'def' could generate a VResult, and - -- (2) 'def' was guaranteed to only occur at the top level, hence - -- any VResult would be caught by a FLoadEnv frame, and seeing a - -- VResult anywhere else was an error. But - -- https://github.com/swarm-game/swarm/commit/b62d27e566565aa9a3ff351d91b23d2589b068dc - -- made top-level binders export a variable binding, also via the - -- VResult mechanism, and unlike 'def', binders do not have to occur - -- at the top level only. This led to - -- https://github.com/swarm-game/swarm/issues/327 , which was fixed - -- by changing this case from an error to simply ignoring the - -- VResult wrapper. - Out (VResult v _) s k -> return $ Out v s k - ------------------------------------------------------------ - -- Exception handling - ------------------------------------------------------------ - - -- First, if we were running a try block but evaluation completed normally, - -- just ignore the try block and continue. - Out v s (FTry {} : k) -> return $ Out v s k - Up exn s [] -> do - -- Here, an exception has risen all the way to the top level without being - -- handled. - case exn of - CmdFailed _ _ (Just a) -> do - grantAchievement a - _ -> return () - - -- If an exception rises all the way to the top level without being - -- handled, turn it into an error message. - - -- HOWEVER, we have to make sure to check that the robot has the - -- 'log' capability which is required to collect and view logs. - -- - -- Notice how we call resetBlackholes on the store, so that any - -- cells which were in the middle of being evaluated will be reset. - let s' = resetBlackholes s - h <- hasCapability CLog - em <- use $ landscape . entityMap - if h - then do - void $ traceLog RobotError Error (formatExn em exn) - return $ Out VUnit s [] - else return $ Out VUnit s' [] - -- Fatal errors, capability errors, and infinite loop errors can't - -- be caught; just throw away the continuation stack. - Up exn@Fatal {} s _ -> return $ Up exn s [] - Up exn@Incapable {} s _ -> return $ Up exn s [] - Up exn@InfiniteLoop {} s _ -> return $ Up exn s [] - -- Otherwise, if we are raising an exception up the continuation - -- stack and come to a Try frame, force and then execute the associated catch - -- block. - Up _ s (FTry c : k) -> return $ Out c s (FApp (VCApp Force []) : FExec : k) - -- Otherwise, keep popping from the continuation stack. - Up exn s (_ : k) -> return $ Up exn s k - -- Finally, if we're done evaluating and the continuation stack is - -- empty, return the machine unchanged. - done@(Out _ _ []) -> return done - where - badMachineState s msg = - let msg' = - T.unlines - [ T.append "Bad machine state in stepRobot: " msg - , prettyText cesk - ] - in return $ Up (Fatal msg') s [] - - -- Note, the order of arguments to `union` is important in the below - -- definition of fUnionEnv. I wish I knew how to add an automated - -- test for this. But you can tell the difference in the following - -- REPL session: - -- - -- > x <- return 1; x <- return 2 - -- 2 : int - -- > x - -- 2 : int - -- - -- If we switch the code to read 'e1 `union` e2' instead, then - -- the first expression above still correctly evaluates to 2, but - -- x ends up incorrectly bound to 1. - - fUnionEnv e1 = \case - FUnionEnv e2 : k -> FUnionEnv (e2 `union` e1) : k - k -> FUnionEnv e1 : k - --- | Eexecute a constant, catching any exception thrown and returning --- it via a CESK machine state. -evalConst :: - (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK -evalConst c vs s k = do - res <- runError $ execConst c vs s k - case res of - Left exn -> return $ Up exn s k - Right cek' -> return cek' - --- | A system program for a "seed robot", to regrow a growable entity --- after it is harvested. -seedProgram :: Integer -> Integer -> Text -> ProcessedTerm -seedProgram minTime randTime thing = - [tmQ| - try { - r <- random (1 + $int:randTime); - wait (r + $int:minTime); - appear "|"; - r <- random (1 + $int:randTime); - wait (r + $int:minTime); - place $str:thing; - } {}; - selfdestruct - |] - --- | Construct a "seed robot" from entity, time range and position, --- and add it to the world. It has low priority and will be covered --- by placed entities. -addSeedBot :: - Has (State GameState) sig m => - Entity -> - (Integer, Integer) -> - Cosmic Location -> - TimeSpec -> - m () -addSeedBot e (minT, maxT) loc ts = - void $ - addTRobot $ - mkRobot - () - Nothing - "seed" - (Markdown.fromText $ T.unwords ["A growing", e ^. entityName, "seed."]) - (Just loc) - zero - ( defaultEntityDisplay '.' - & displayAttr .~ (e ^. entityDisplay . displayAttr) - & displayPriority .~ 0 - ) - (initMachine (seedProgram minT (maxT - minT) (e ^. entityName)) empty emptyStore) - [] - [(1, e)] - True - False - mempty - ts - --- | Interpret the execution (or evaluation) of a constant application --- to some values. -execConst :: - (HasRobotStepState sig m, Has (Lift IO) sig m) => - Const -> - [Value] -> - Store -> - Cont -> - m CESK -execConst c vs s k = do - -- First, ensure the robot is capable of executing/evaluating this constant. - ensureCanExecute c - - -- Increment command count regardless of success - when (isTangible c) $ - activityCounts . tangibleCommandCount += 1 - - activityCounts . commandsHistogram %= M.insertWith (+) c 1 - - -- Now proceed to actually carry out the operation. - case c of - Noop -> return $ Out VUnit s k - Return -> case vs of - [v] -> return $ Out v s k - _ -> badConst - Wait -> case vs of - [VInt d] -> do - time <- use $ temporal . ticks - purgeFarAwayWatches - return $ Waiting (addTicks (fromIntegral d) time) (Out VUnit s k) - _ -> badConst - Selfdestruct -> do - destroyIfNotBase $ \case False -> Just AttemptSelfDestructBase; _ -> Nothing - flagRedraw - return $ Out VUnit s k - Move -> do - orient <- use robotOrientation - moveInDirection $ orient ? zero - Backup -> do - orient <- use robotOrientation - moveInDirection $ applyTurn (DRelative $ DPlanar DBack) $ orient ? zero - Path -> case vs of - [VInj hasLimit limitVal, VInj findEntity goalVal] -> do - maybeLimit <- - if hasLimit - then case limitVal of - VInt d -> return $ Just d - _ -> badConst - else return Nothing - goal <- - if findEntity - then case goalVal of - VText eName -> return $ EntityTarget eName - _ -> badConst - else case goalVal of - VPair (VInt x) (VInt y) -> - return $ - LocationTarget $ - Location (fromIntegral x) (fromIntegral y) - _ -> badConst - robotLoc <- use robotLocation - result <- pathCommand maybeLimit robotLoc goal - return $ Out (asValue result) s k - _ -> badConst - Push -> do - -- Figure out where we're going - loc <- use robotLocation - orient <- use robotOrientation - let applyHeading = (`offsetBy` (orient ? zero)) - nextLoc = applyHeading loc - placementLoc = applyHeading nextLoc - - -- 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!"] - - let verbed = verbedGrabbingCmd Push' - -- Ensure it can be pushed. - omni <- isPrivilegedBot - (omni || e `hasProperty` Portable && 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 () - - updateRobotLocation loc nextLoc - return $ Out VUnit s k - Stride -> case vs of - [VInt d] -> do - when (d > fromIntegral maxStrideRange) $ - throwError $ - CmdFailed - Stride - ( T.unwords - [ "Can only stride up to" - , T.pack $ show maxStrideRange - , "units." - ] - ) - Nothing - - -- Figure out where we're going - loc <- use robotLocation - orient <- use robotOrientation - let heading = orient ? zero - - -- Excludes the base location. - let locsInDirection :: [Cosmic Location] - locsInDirection = - take (min (fromIntegral d) maxStrideRange) $ - drop 1 $ - iterate (`offsetBy` heading) loc - - failureMaybes <- mapM checkMoveFailure locsInDirection - let maybeFirstFailure = asum failureMaybes - - applyMoveFailureEffect maybeFirstFailure $ \case - PathBlocked -> ThrowExn - PathLiquid -> Destroy - - let maybeLastLoc = do - guard $ null maybeFirstFailure - listToMaybe $ reverse locsInDirection - - forM_ maybeLastLoc $ updateRobotLocation loc - - return $ Out VUnit s k - _ -> 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 - PathBlocked -> Destroy - PathLiquid -> Destroy - updateRobotLocation oldLoc nextLoc - - return $ Out VUnit s k - _ -> badConst - Grab -> mkReturn <$> doGrab Grab' - Harvest -> mkReturn <$> doGrab Harvest' - Ignite -> case vs of - [VDir d] -> do - Combustion.igniteCommand c d - return $ Out VUnit s k - _ -> badConst - Swap -> case vs of - [VText name] -> do - loc <- use robotLocation - -- Make sure the robot has the thing in its inventory - e <- hasInInventoryOrFail name - -- Grab - newE <- doGrab Swap' - - -- Place the entity and remove it from the inventory - updateEntityAt loc (const (Just e)) - robotInventory %= delete e - - when (e == newE) $ - grantAchievement SwapSame - - return $ mkReturn newE - _ -> badConst - Turn -> case vs of - [VDir d] -> do - when (isCardinal d) $ hasCapabilityFor COrient (TDir d) - robotOrientation . _Just %= applyTurn d - flagRedraw - - inst <- use equippedDevices - when (d == DRelative DDown && countByName "compass" inst == 0) $ do - grantAchievement GetDisoriented - - return $ Out VUnit s k - _ -> badConst - Place -> case vs of - [VText name] -> do - loc <- use robotLocation - - -- Make sure there's nothing already here - nothingHere <- isNothing <$> entityAt loc - nothingHere `holdsOrFail` ["There is already an entity here."] - - -- 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)) - robotInventory %= delete e - - flagRedraw - return $ Out VUnit s k - _ -> badConst - Ping -> case vs of - [VRobot otherID] -> do - maybeOtherRobot <- robotWithID otherID - selfRobot <- get - return $ Out (asValue $ displacementVector selfRobot maybeOtherRobot) s k - where - displacementVector :: Robot -> Maybe Robot -> Maybe (V2 Int32) - displacementVector selfRobot maybeOtherRobot = do - otherRobot <- maybeOtherRobot - let dist = (cosmoMeasure euclidean `on` view robotLocation) selfRobot otherRobot - (_minRange, maxRange) = getRadioRange (Just selfRobot) (Just otherRobot) - d <- getFiniteDistance dist - guard $ d <= maxRange - orientationBasedRelativePosition selfRobot $ view robotLocation otherRobot - _ -> badConst - Give -> case vs of - [VRobot otherID, VText itemName] -> do - -- Make sure the other robot exists and is close - _other <- getRobotWithinTouch otherID - - item <- ensureItem itemName "give" - - -- Giving something to ourself should be a no-op. We need - -- this as a special case since it will not work to modify - -- ourselves in the robotMap --- after performing a tick we - -- return a modified Robot which gets put back in the - -- robotMap, overwriting any changes to this robot made - -- directly in the robotMap during the tick. - myID <- use robotID - focusedID <- use focusedRobotID - when (otherID /= myID) $ do - -- Make the exchange - robotMap . at otherID . _Just . robotInventory %= insert item - robotInventory %= delete item - - -- Flag the UI for a redraw if we are currently showing either robot's inventory - when (focusedID == myID || focusedID == otherID) flagRedraw - - return $ Out VUnit s k - _ -> badConst - Equip -> case vs of - [VText itemName] -> do - item <- ensureItem itemName "equip" - myID <- use robotID - focusedID <- use focusedRobotID - -- Don't do anything if the robot already has the device. - already <- use (equippedDevices . to (`E.contains` item)) - unless already $ do - equippedDevices %= insert item - robotInventory %= delete item - - -- Flag the UI for a redraw if we are currently showing our inventory - when (focusedID == myID) flagRedraw - - return $ Out VUnit s k - _ -> badConst - Unequip -> case vs of - [VText itemName] -> do - item <- ensureEquipped itemName - myID <- use robotID - focusedID <- use focusedRobotID - equippedDevices %= delete item - robotInventory %= insert item - -- Flag the UI for a redraw if we are currently showing our inventory - when (focusedID == myID) flagRedraw - return $ Out VUnit s k - _ -> badConst - Make -> case vs of - [VText name] -> do - inv <- use robotInventory - ins <- use equippedDevices - em <- use $ landscape . entityMap - e <- - lookupEntityName name em - `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."] - - outRs <- use $ recipesInfo . recipesOut - - creative <- use creativeMode - let create l = l <> ["You can use 'create \"" <> name <> "\"' instead." | creative] - - -- Only consider recipes where the number of things we are trying to make - -- is greater in the outputs than in the inputs. This prevents us from doing - -- silly things like making copper pipes when the user says "make furnace". - let recipes = filter increase (recipesFor outRs e) - increase r = countIn (r ^. recipeOutputs) > countIn (r ^. recipeInputs) - countIn xs = maybe 0 fst (find ((== e) . snd) xs) - not (null recipes) - `holdsOrFail` create ["There is no known recipe for making", indefinite name <> "."] - - let displayMissingCount mc = \case - MissingInput -> from (show mc) - MissingCatalyst -> "not equipped" - displayMissingIngredient (MissingIngredient mk mc me) = - " - " <> me ^. entityName <> " (" <> displayMissingCount mc mk <> ")" - displayMissingIngredients xs = L.intercalate ["OR"] (map displayMissingIngredient <$> xs) - - -- Try recipes and make a weighted random choice among the - -- ones we have ingredients for. - let (badRecipes, goodRecipes) = partitionEithers . map (make (inv, ins)) $ recipes - chosenRecipe <- weightedChoice (^. _3 . recipeWeight) goodRecipes - (invTaken, changeInv, recipe) <- - chosenRecipe - `isJustOrFail` create - [ "You don't have the ingredients to make" - , indefinite name <> "." - , "Missing:\n" <> T.unlines (displayMissingIngredients badRecipes) - ] - - -- take recipe inputs from inventory and add outputs after recipeTime - robotInventory .= invTaken - traverse_ (updateDiscoveredEntities . snd) (recipe ^. recipeOutputs) - finishCookingRecipe recipe VUnit [] (map (uncurry AddEntity) changeInv) - _ -> badConst - Has -> case vs of - [VText name] -> do - inv <- use robotInventory - return $ Out (VBool ((> 0) $ countByName name inv)) s k - _ -> badConst - Equipped -> case vs of - [VText name] -> do - inv <- use equippedDevices - return $ Out (VBool ((> 0) $ countByName name inv)) s k - _ -> badConst - Count -> case vs of - [VText name] -> do - inv <- use robotInventory - return $ Out (VInt (fromIntegral $ countByName name inv)) s k - _ -> badConst - Scout -> case vs of - [VDir d] -> do - rMap <- use robotMap - myLoc <- use robotLocation - heading <- deriveHeading d - botsByLocs <- use robotsByLocation - selfRid <- use robotID - - -- Includes the base location, so we exclude the base robot later. - let locsInDirection :: [Cosmic Location] - locsInDirection = take maxScoutRange $ iterate (`offsetBy` heading) myLoc - - let hasOpaqueEntity = - fmap (maybe False (`hasProperty` E.Opaque)) . entityAt - - let hasVisibleBot :: Cosmic Location -> Bool - hasVisibleBot = any botIsVisible . IS.toList . excludeSelf . botsHere - where - excludeSelf = (`IS.difference` IS.singleton selfRid) - botsHere (Cosmic swName loc) = - M.findWithDefault mempty loc $ - M.findWithDefault mempty swName botsByLocs - botIsVisible = maybe False canSee . (`IM.lookup` rMap) - canSee = not . (^. robotDisplay . invisible) - - -- A robot on the same cell as an opaque entity is considered hidden. - -- Returns (Just Bool) if the result is conclusively visible or opaque, - -- or Nothing if we don't have a conclusive answer yet. - let isConclusivelyVisible :: Bool -> Cosmic Location -> Maybe Bool - isConclusivelyVisible isOpaque loc - | isOpaque = Just False - | hasVisibleBot loc = Just True - | otherwise = Nothing - - let isConclusivelyVisibleM loc = do - opaque <- hasOpaqueEntity loc - return $ isConclusivelyVisible opaque loc - - -- This ensures that we only evaluate locations until - -- a conclusive result is obtained, so we don't always - -- have to inspect the maximum range of the command. - result <- firstJustM isConclusivelyVisibleM locsInDirection - let foundBot = fromMaybe False result - return $ Out (VBool foundBot) s k - _ -> badConst - Whereami -> do - loc <- use robotLocation - return $ Out (asValue $ loc ^. planar) s k - Waypoint -> case vs of - [VText name, VInt idx] -> 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 $ Out (asValue (NE.length wps, indexWrapNonEmpty wps idx)) s k - _ -> badConst - Detect -> case vs of - [VText name, VRect x1 y1 x2 y2] -> do - loc <- use robotLocation - let locs = rectCells x1 y1 x2 y2 - -- sort offsets by (Manhattan) distance so that we return the closest occurrence - let sortedOffsets = sortOn (\(V2 x y) -> abs x + abs y) locs - let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc - firstOne <- findM f sortedOffsets - return $ Out (asValue firstOne) s k - _ -> badConst - Resonate -> case vs of - [VText name, VRect x1 y1 x2 y2] -> doResonate (maybe False $ isEntityNamed name) x1 y1 x2 y2 - _ -> badConst - Density -> case vs of - [VRect x1 y1 x2 y2] -> doResonate isJust x1 y1 x2 y2 - _ -> badConst - Sniff -> case vs of - [VText name] -> do - firstFound <- findNearest name - return $ Out (asValue $ maybe (-1) fst firstFound) s k - _ -> badConst - Watch -> case vs of - [VDir d] -> do - (loc, _me) <- lookInDirection d - addWatchedLocation loc - return $ Out VUnit s k - _ -> badConst - Surveil -> case vs of - [VPair (VInt x) (VInt y)] -> do - Cosmic swName _ <- use robotLocation - let loc = Cosmic swName $ Location (fromIntegral x) (fromIntegral y) - addWatchedLocation loc - return $ Out VUnit s k - _ -> badConst - Chirp -> case vs of - [VText name] -> do - firstFound <- findNearest name - mh <- use robotOrientation - inst <- use equippedDevices - let processDirection entityDir = - if countByName "compass" inst >= 1 - then Just $ DAbsolute entityDir - else case mh >>= toDirection of - Just (DAbsolute robotDir) -> - Just . DRelative . DPlanar $ entityDir `relativeTo` robotDir - _ -> Nothing -- This may happen if the robot is facing "down" - val = VDir $ fromMaybe (DRelative DDown) $ do - entLoc <- firstFound - guard $ snd entLoc /= zero - processDirection . nearestDirection . snd $ entLoc - return $ Out val s k - _ -> badConst - Heading -> do - mh <- use robotOrientation - -- In general, (1) entities might not have an orientation, and - -- (2) even if they do, orientation is a general vector, which - -- might not correspond to a cardinal direction. We could make - -- 'heading' return a 'maybe dir' i.e. 'unit + dir', or return a - -- vector of type 'int * int', but those would both be annoying - -- for players in the vast majority of cases. We rather choose - -- to just return the direction 'down' in any case where we don't - -- otherwise have anything reasonable to return. - return $ Out (VDir (fromMaybe (DRelative DDown) $ mh >>= toDirection)) s k - Time -> do - TickNumber t <- use $ temporal . ticks - return $ Out (VInt $ fromIntegral t) s k - Drill -> case vs of - [VDir d] -> doDrill d - _ -> badConst - Use -> case vs of - [VText deviceName, VDir d] -> do - ins <- use equippedDevices - equippedEntity <- ensureEquipped deviceName - let verbPhrase = T.unwords ["use", deviceName, "on"] - applyDevice ins verbPhrase d equippedEntity - _ -> badConst - Blocked -> do - loc <- use robotLocation - orient <- use robotOrientation - let nextLoc = loc `offsetBy` (orient ? zero) - me <- entityAt nextLoc - return $ Out (VBool (maybe False (`hasProperty` Unwalkable) me)) s k - Scan -> case vs of - [VDir d] -> do - (_loc, me) <- lookInDirection d - for_ me $ \e -> do - robotInventory %= insertCount 0 e - updateDiscoveredEntities e - -- Flag the world for a redraw since scanning something may - -- change the way it is drawn (if the base is doing the - -- scanning) - flagRedraw - return $ Out (asValue me) s k - _ -> badConst - Knows -> case vs of - [VText name] -> do - inv <- use robotInventory - ins <- use equippedDevices - let allKnown = inv `E.union` ins - let knows = case E.lookupByName name allKnown of - [] -> False - _ -> True - return $ Out (VBool knows) s k - _ -> badConst - Upload -> case vs of - [VRobot otherID] -> do - -- Make sure the other robot exists and is close - _other <- getRobotWithinTouch otherID - - -- Upload knowledge of everything in our inventory - inv <- use robotInventory - forM_ (elems inv) $ \(_, e) -> - robotMap . at otherID . _Just . robotInventory %= insertCount 0 e - - -- Upload our log - rlog <- use robotLog - robotMap . at otherID . _Just . robotLog <>= rlog - - -- Flag the world for redraw since uploading may change the - -- base's knowledge and hence how entities are drawn (if they - -- go from unknown to known). - flagRedraw - - return $ Out VUnit s k - _ -> badConst - Random -> case vs of - [VInt hi] -> do - n <- uniform (0, hi - 1) - return $ Out (VInt n) s k - _ -> badConst - Atomic -> goAtomic - Instant -> goAtomic - As -> case vs of - [VRobot rid, prog] -> do - -- Get the named robot and current game state - r <- robotWithID rid >>= (`isJustOrFail` ["There is no actor with ID", from (show rid)]) - g <- get @GameState - - -- Execute the given program *hypothetically*: i.e. in a fresh - -- CESK machine, using *copies* of the current store, robot - -- and game state. We discard the state afterwards so any - -- modifications made by prog do not persist. Note we also - -- set the copied robot to be a "system" robot so it is - -- capable of executing any commands; the As command - -- already requires "God" capability. - v <- - evalState @Robot (r & systemRobot .~ True) . evalState @GameState g $ - runCESK (Out prog s [FApp (VCApp Force []), FExec]) - - -- Return the value returned by the hypothetical command. - return $ Out v s k - _ -> badConst - RobotNamed -> case vs of - [VText rname] -> do - r <- robotWithName rname >>= (`isJustOrFail` ["There is no robot named", rname]) - return $ Out (asValue r) s k - _ -> badConst - RobotNumbered -> case vs of - [VInt rid] -> do - r <- - robotWithID (fromIntegral rid) - >>= (`isJustOrFail` ["There is no robot with number", from (show rid)]) - return $ Out (asValue r) s k - _ -> badConst - Say -> case vs of - [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') -> - robotMap . at rid . _Just . robotLog %= addLatestClosest loc' - robotsAround <- - if isPrivileged - then use $ robotMap . to IM.elems - else gets $ robotsInArea loc hearingDistance - mapM_ addToRobotLog robotsAround - return $ Out VUnit s k - _ -> badConst - Listen -> do - gs <- get @GameState - loc <- use robotLocation - rid <- use robotID - isPrivileged <- isPrivilegedBot - mq <- use $ messageInfo . messageQueue - let isClose e = isPrivileged || messageIsFromNearby loc e - notMine e = case e ^. leSource of - SystemLog {} -> False - RobotLog _ lrid _ -> rid /= lrid - limitLast = \case - _s Seq.:|> l -> Just $ l ^. leText - _ -> Nothing - mm = limitLast . Seq.filter (liftA2 (&&) notMine isClose) $ Seq.takeWhileR (messageIsRecent gs) mq - return $ - maybe - (In (TConst Listen) mempty s (FExec : k)) -- continue listening - (\m -> Out (VText m) s k) -- return found message - mm - Log -> case vs of - [VText msg] -> do - void $ traceLog Logged Info msg - return $ Out VUnit s k - _ -> badConst - View -> case vs of - [VRobot rid] -> do - -- Only the base can actually change the view in the UI. Other robots can - -- execute this command but it does nothing (at least for now). - rn <- use robotID - when (rn == 0) $ - robotWithID rid >>= \case - -- If the robot does not exist... - Nothing -> do - cr <- use creativeMode - ws <- use $ landscape . worldScrollable - case cr || ws of - -- If we are in creative mode or allowed to scroll, then we are allowed - -- to learn that the robot doesn't exist. - True -> throwError $ cmdExn c ["There is no actor with ID", from (show rid), "to view."] - -- Otherwise, "unfocus" from any robot, which - -- means the world view will turn to static. The - -- point is that there's no way to tell the difference - -- between this situation and the situation where the - -- robot exists but is too far away. - False -> modify unfocus - - -- If it does exist, set it as the view center. - Just _ -> viewCenterRule .= VCRobot rid - - return $ Out VUnit s k - _ -> badConst - Appear -> case vs of - [VText app] -> do - flagRedraw - case into @String app of - [dc] -> do - robotDisplay . defaultChar .= dc - robotDisplay . orientationMap .= M.empty - return $ Out VUnit s k - [dc, nc, ec, sc, wc] -> do - robotDisplay . defaultChar .= dc - robotDisplay . orientationMap . ix DNorth .= nc - robotDisplay . orientationMap . ix DEast .= ec - robotDisplay . orientationMap . ix DSouth .= sc - robotDisplay . orientationMap . ix DWest .= wc - return $ Out VUnit s k - _other -> raise Appear [quote app, "is not a valid appearance string. 'appear' must be given a string with exactly 1 or 5 characters."] - _ -> badConst - Create -> case vs of - [VText name] -> do - em <- use $ landscape . entityMap - e <- - lookupEntityName name em - `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."] - - robotInventory %= insert e - updateDiscoveredEntities e - - return $ Out VUnit s k - _ -> badConst - Halt -> case vs of - [VRobot targetID] -> do - myID <- use robotID - case myID == targetID of - -- To halt ourselves, just return a cancelled CESK machine. - -- It will be reinstalled as our current machine; then, - -- based on the fact that our CESK machine is done we will - -- be put to sleep and the REPL will be reset if we are the - -- base robot. - True -> return $ cancel $ Out VUnit s k - False -> do - -- Make sure the other robot exists and is close enough. - target <- getRobotWithinTouch targetID - -- Make sure either we are privileged, OR the target robot - -- is NOT. In other words unprivileged bots should not be - -- able to halt privileged ones. - omni <- isPrivilegedBot - case omni || not (target ^. systemRobot) of - True -> do - -- Cancel its CESK machine, and put it to sleep. - robotMap . at targetID . _Just . machine %= cancel - sleepForever targetID - return $ Out VUnit s k - False -> throwError $ cmdExn c ["You are not authorized to halt that robot."] - _ -> badConst - Ishere -> case vs of - [VText name] -> do - loc <- use robotLocation - me <- entityAt loc - let here = maybe False (isEntityNamed name) me - return $ Out (VBool here) s k - _ -> badConst - Isempty -> do - loc <- use robotLocation - me <- entityAt loc - return $ Out (VBool (isNothing me)) s k - Self -> do - rid <- use robotID - return $ Out (VRobot rid) s k - Parent -> do - mp <- use robotParentID - rid <- use robotID - return $ Out (VRobot (fromMaybe rid mp)) s k - Base -> return $ Out (VRobot 0) s k - Meet -> do - loc <- use robotLocation - rid <- use robotID - g <- get @GameState - let neighbor = - find ((/= rid) . (^. robotID)) -- pick one other than ourself - . sortOn ((manhattan `on` view planar) loc . (^. robotLocation)) -- prefer closer - $ robotsInArea loc 1 g -- all robots within Manhattan distance 1 - return $ Out (asValue neighbor) s k - MeetAll -> case vs of - [f, b] -> do - loc <- use robotLocation - rid <- use robotID - g <- get @GameState - let neighborIDs = filter (/= rid) . map (^. robotID) $ robotsInArea loc 1 g - return $ Out b s (FMeetAll f neighborIDs : k) - _ -> badConst - Whoami -> case vs of - [] -> do - name <- use robotName - return $ Out (VText name) s k - _ -> badConst - Setname -> case vs of - [VText name] -> do - robotName .= name - return $ Out VUnit s k - _ -> badConst - Force -> case vs of - [VDelay t e] -> return $ In t e s k - [VRef loc] -> - -- To force a VRef, we look up the location in the store. - case lookupStore loc s of - -- If there's no cell at that location, it's a bug! It - -- shouldn't be possible to get a VRef to a non-existent - -- location, since the only way VRefs get created is at the - -- time we allocate a new cell. - Nothing -> - return $ - Up (Fatal $ T.append "Reference to unknown memory cell " (from (show loc))) s k - -- If the location contains an unevaluated expression, it's - -- time to evaluate it. Set the cell to a 'Blackhole', push - -- an 'FUpdate' frame so we remember to update the location - -- to its value once we finish evaluating it, and focus on - -- the expression. - Just (E t e') -> return $ In t e' (setStore loc (Blackhole t e') s) (FUpdate loc : k) - -- If the location contains a Blackhole, that means we are - -- already currently in the middle of evaluating it, i.e. it - -- depends on itself, so throw an 'InfiniteLoop' error. - Just Blackhole {} -> return $ Up InfiniteLoop s k - -- If the location already contains a value, just return it. - Just (V v) -> return $ Out v s k - -- If a force is applied to any other kind of value, just ignore it. - -- This is needed because of the way we wrap all free variables in @force@ - -- in case they come from a @def@ which are always wrapped in @delay@. - -- But binders (i.e. @x <- ...@) are also exported to the global context. - [v] -> return $ Out v s k - _ -> badConst - If -> case vs of - -- Use the boolean to pick the correct branch, and apply @force@ to it. - [VBool b, thn, els] -> return $ Out (bool els thn b) s (FApp (VCApp Force []) : k) - _ -> badConst - Inl -> case vs of - [v] -> return $ Out (VInj False v) s k - _ -> badConst - Inr -> case vs of - [v] -> return $ Out (VInj True v) s k - _ -> badConst - 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 - _ -> badConst - Try -> case vs of - [c1, c2] -> return $ Out c1 s (FApp (VCApp Force []) : FExec : FTry c2 : k) - _ -> badConst - Undefined -> return $ Up (User "undefined") s k - Fail -> case vs of - [VText msg] -> return $ Up (User msg) s k - _ -> badConst - Key -> case vs of - [VText ktxt] -> case runParser parseKeyComboFull ktxt of - Right kc -> return $ Out (VKey kc) s k - Left _ -> return $ Up (CmdFailed Key (T.unwords ["Unknown key", quote ktxt]) Nothing) s k - _ -> badConst - InstallKeyHandler -> case vs of - [VText hint, handler] -> do - gameControls . inputHandler .= Just (hint, handler) - return $ Out VUnit s k - _ -> badConst - Reprogram -> case vs of - [VRobot childRobotID, VDelay cmd e] -> do - r <- get - isPrivileged <- isPrivilegedBot - - -- check if robot exists - childRobot <- - robotWithID childRobotID - >>= (`isJustOrFail` ["There is no actor with ID", from (show childRobotID) <> "."]) - - -- check that current robot is not trying to reprogram self - myID <- use robotID - (childRobotID /= myID) - `holdsOrFail` ["You cannot make a robot reprogram itself."] - - -- check if robot has completed executing it's current command - _ <- - finalValue (childRobot ^. machine) - `isJustOrFail` ["You cannot reprogram a robot that is actively running a program."] - - -- check if childRobot is at the correct distance - -- a robot can program adjacent robots - -- privileged bots ignore distance checks - loc <- use robotLocation - - isNearbyOrExempt isPrivileged loc (childRobot ^. robotLocation) - `holdsOrFail` ["You can only reprogram an adjacent robot."] - - -- Figure out if we can supply what the target robot requires, - -- and if so, what is needed. - (toEquip, toGive) <- - checkRequirements - (r ^. robotInventory) - (childRobot ^. robotInventory) - (childRobot ^. equippedDevices) - cmd - "The target robot" - FixByObtain - - -- update other robot's CESK machine, environment and context - -- the childRobot inherits the parent robot's environment - -- and context which collectively mean all the variables - -- declared in the parent robot - robotMap . at childRobotID . _Just . machine .= In cmd e s [FExec] - robotMap . at childRobotID . _Just . robotContext .= r ^. robotContext - - -- Provision the target robot with any required devices and - -- inventory that are lacking. - provisionChild childRobotID (fromList . S.toList $ toEquip) toGive - - -- Finally, re-activate the reprogrammed target robot. - activateRobot childRobotID - - return $ Out VUnit s k - _ -> badConst - Build -> case vs of - -- NOTE, pattern-matching on a VDelay here means we are - -- /relying/ on the fact that 'Build' can only be given a - -- /non-memoized/ delayed value. If it were given a memoized - -- delayed value we would see a VRef instead of a VDelay. If - -- and Try are generalized to handle any type of delayed value, - -- but Build and Reprogram still assume they are given a VDelay - -- and not a VRef. In the future, if we enable memoized delays - -- by default, or allow the user to explicitly request - -- memoization via double braces or something similar, this will - -- have to be generalized. The difficulty is that we do a - -- capability check on the delayed program at runtime, just - -- before creating the newly built robot (see the call to - -- 'requirements' below); but if we have a VRef instead of a - -- VDelay, we may only be able to get a Value out of it instead - -- of a Term as we currently do, and capability checking a Value - -- is annoying and/or problematic. One solution might be to - -- annotate delayed expressions with their required capabilities - -- at typechecking time, and carry those along so they flow to - -- this point. Another solution would be to just bite the bullet - -- and figure out how to do capability checking on Values (which - -- would return the capabilities needed to *execute* them), - -- hopefully without duplicating too much code. - [VDelay cmd e] -> do - r <- get @Robot - pid <- use robotID - - (toEquip, toGive) <- - checkRequirements (r ^. robotInventory) E.empty E.empty cmd "You" FixByObtain - - -- Pick a random display name. - displayName <- randomName - createdAt <- getNow - isSystemRobot <- use systemRobot - - -- Construct the new robot and add it to the world. - parentCtx <- use robotContext - newRobot <- - addTRobot . (trobotContext .~ parentCtx) $ - mkRobot - () - (Just pid) - displayName - (Markdown.fromText $ "A robot built by the robot named " <> (r ^. robotName) <> ".") - (Just (r ^. robotLocation)) - ( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir) - ? north - ) - defaultRobotDisplay - (In cmd e s [FExec]) - [] - [] - isSystemRobot - False - mempty - createdAt - - -- Provision the new robot with the necessary devices and inventory. - provisionChild (newRobot ^. robotID) (fromList . S.toList $ toEquip) toGive - - -- Flag the world for a redraw and return the name of the newly constructed robot. - flagRedraw - return $ Out (asValue newRobot) s k - _ -> badConst - Salvage -> case vs of - [] -> do - loc <- use robotLocation - let okToSalvage r = (r ^. robotID /= 0) && (not . isActive $ r) - mtarget <- gets (find okToSalvage . robotsAtLocation loc) - case mtarget of - Nothing -> return $ Out VUnit s k -- Nothing to salvage - Just target -> do - -- Copy the salvaged robot's equipped devices into its inventory, in preparation - -- for transferring it. - let salvageInventory = E.union (target ^. robotInventory) (target ^. equippedDevices) - robotMap . at (target ^. robotID) . traverse . robotInventory .= salvageInventory - - let salvageItems = concatMap (\(n, e) -> replicate n (e ^. entityName)) (E.elems salvageInventory) - numItems = length salvageItems - - -- Copy over the salvaged robot's log, if we have one - inst <- use equippedDevices - em <- use $ landscape . entityMap - isPrivileged <- isPrivilegedBot - logger <- - lookupEntityName "logger" em - `isJustOr` Fatal "While executing 'salvage': there's no such thing as a logger!?" - when (isPrivileged || inst `E.contains` logger) $ robotLog <>= target ^. robotLog - - -- Immediately copy over any items the robot knows about - -- but has 0 of - let knownItems = map snd . filter ((== 0) . fst) . elems $ salvageInventory - robotInventory %= \i -> foldr (insertCount 0) i knownItems - - -- Now reprogram the robot being salvaged to 'give' each - -- item in its inventory to us, one at a time, then - -- self-destruct at the end. Make it a system robot so we - -- don't have to worry about capabilities. - robotMap . at (target ^. robotID) . traverse . systemRobot .= True - - ourID <- use @Robot robotID - - -- The program for the salvaged robot to run - let giveInventory = - foldr (TBind Nothing . giveItem) (TConst Selfdestruct) salvageItems - giveItem item = TApp (TApp (TConst Give) (TRobot ourID)) (TText item) - - -- Reprogram and activate the salvaged robot - robotMap - . at (target ^. robotID) - . traverse - . machine - .= In giveInventory empty emptyStore [FExec] - activateRobot (target ^. robotID) - - -- Now wait the right amount of time for it to finish. - time <- use $ temporal . ticks - return $ Waiting (addTicks (numItems + 1) time) (Out VUnit s k) - _ -> badConst - -- run can take both types of text inputs - -- with and without file extension as in - -- "./path/to/file.sw" and "./path/to/file" - Run -> case vs of - [VText fileName] -> do - let filePath = into @String fileName - sData <- throwToMaybe @SystemFailure $ getDataFileNameSafe Script filePath - sDataSW <- throwToMaybe @SystemFailure $ getDataFileNameSafe Script (filePath <> ".sw") - mf <- sendIO $ mapM readFileMay $ [filePath, filePath <> ".sw"] <> catMaybes [sData, sDataSW] - - f <- msum mf `isJustOrFail` ["File not found:", fileName] - - mt <- - processTerm (into @Text f) `isRightOr` \err -> - cmdExn Run ["Error in", fileName, "\n", err] - - case mt of - Nothing -> return $ Out VUnit s k - Just t@(ProcessedTerm _ _ reqCtx) -> do - -- Add the reqCtx from the ProcessedTerm to the current robot's defReqs. - -- See #827 for an explanation of (1) why this is needed, (2) why - -- it's slightly technically incorrect, and (3) why it is still way - -- better than what we had before. - robotContext . defReqs <>= reqCtx - return $ initMachine' t empty s k - _ -> badConst - Not -> case vs of - [VBool b] -> return $ Out (VBool (not b)) s k - _ -> badConst - Neg -> case vs of - [VInt n] -> return $ Out (VInt (-n)) s k - _ -> badConst - Eq -> returnEvalCmp - Neq -> returnEvalCmp - Lt -> returnEvalCmp - Gt -> returnEvalCmp - Leq -> returnEvalCmp - Geq -> returnEvalCmp - And -> case vs of - [VBool a, VBool b] -> return $ Out (VBool (a && b)) s k - _ -> badConst - Or -> case vs of - [VBool a, VBool b] -> return $ Out (VBool (a || b)) s k - _ -> badConst - Add -> returnEvalArith - Sub -> returnEvalArith - Mul -> returnEvalArith - Div -> returnEvalArith - Exp -> returnEvalArith - Format -> case vs of - [v] -> return $ Out (VText (prettyValue v)) s k - _ -> badConst - Chars -> case vs of - [VText t] -> return $ Out (VInt (fromIntegral $ T.length t)) s k - _ -> badConst - Split -> case vs of - [VInt i, VText t] -> - let p = T.splitAt (fromInteger i) t - t2 = over both VText p - in return $ Out (uncurry VPair t2) s k - _ -> badConst - Concat -> case vs of - [VText v1, VText v2] -> return $ Out (VText (v1 <> v2)) s k - _ -> badConst - CharAt -> case vs of - [VInt i, VText t] - | i < 0 || i >= fromIntegral (T.length t) -> - raise CharAt ["Index", prettyValue (VInt i), "out of bounds for length", from @String $ show (T.length t)] - | otherwise -> return $ Out (VInt . fromIntegral . ord . T.index t . fromIntegral $ i) s k - _ -> badConst - ToChar -> case vs of - [VInt i] - | i < 0 || i > fromIntegral (ord (maxBound :: Char)) -> - raise ToChar ["Value", prettyValue (VInt i), "is an invalid character code"] - | otherwise -> - return $ Out (VText . T.singleton . chr . fromIntegral $ i) s k - _ -> badConst - AppF -> - let msg = "The operator '$' should only be a syntactic sugar and removed in elaboration:\n" - in throwError . Fatal $ msg <> badConstMsg - where - doDrill d = do - ins <- use equippedDevices - - let equippedDrills = extantElemsWithCapability CDrill ins - -- Heuristic: choose the drill with the more elaborate name. - -- E.g. "metal drill" vs. "drill" - preferredDrill = listToMaybe $ sortOn (Down . T.length . (^. entityName)) equippedDrills - - tool <- preferredDrill `isJustOr` Fatal "Drill is required but not equipped?!" - applyDevice ins "drill" d tool - - applyDevice ins verbPhrase d tool = do - (nextLoc, nextE) <- getDeviceTarget verbPhrase d - inRs <- use $ recipesInfo . recipesIn - - let recipes = filter isApplicableRecipe (recipesFor inRs nextE) - isApplicableRecipe = any ((== tool) . snd) . view recipeCatalysts - - not (null recipes) - `holdsOrFail` [ "There is no way to" - , verbPhrase - , indefinite (nextE ^. entityName) <> "." - ] - - inv <- use robotInventory - - -- add the targeted entity so it can be consumed by the recipe - let makeRecipe r = (,r) <$> make' (insert nextE inv, ins) r - chosenRecipe <- - weightedChoice (\((_, _), r) -> r ^. recipeWeight) $ - rights $ - map makeRecipe recipes - ((invTaken, outs), recipe) <- - chosenRecipe - `isJustOrFail` ["You don't have the ingredients to", verbPhrase, indefinite (nextE ^. entityName) <> "."] - - let (out, down) = L.partition ((`hasProperty` Portable) . snd) outs - learn = map (LearnEntity . snd) down - gain = map (uncurry AddEntity) out - - newEntity <- case down of - [] -> pure Nothing - [(1, de)] -> pure $ Just de - _ -> throwError $ Fatal "Bad recipe:\n more than one unmovable entity produced." - let changeWorld = - ReplaceEntity - { updatedLoc = nextLoc - , originalEntity = nextE - , newEntity = newEntity - } - - -- take recipe inputs from inventory and add outputs after recipeTime - robotInventory .= invTaken - - let cmdOutput = asValue $ snd <$> listToMaybe out - finishCookingRecipe recipe cmdOutput [changeWorld] (learn <> gain) - - getDeviceTarget verb d = do - rname <- use robotName - - (nextLoc, nextME) <- lookInDirection d - nextE <- - nextME - `isJustOrFail` ["There is nothing to", verb, directionText, "robot", rname <> "."] - return (nextLoc, nextE) - where - directionText = case d of - DRelative DDown -> "under" - DRelative (DPlanar DForward) -> "ahead of" - DRelative (DPlanar DBack) -> "behind" - _ -> directionSyntax d <> " of" - - goAtomic :: HasRobotStepState sig m => m CESK - goAtomic = case vs of - -- To execute an atomic block, set the runningAtomic flag, - -- push an FFinishAtomic frame so that we unset the flag when done, and - -- proceed to execute the argument. - [cmd] -> do - runningAtomic .= True - return $ Out cmd s (FExec : FFinishAtomic : k) - _ -> badConst - - -- Case-insensitive matching on entity names - isEntityNamed :: T.Text -> Entity -> Bool - isEntityNamed n e = ((==) `on` T.toLower) (e ^. entityName) n - - badConst :: HasRobotStepState sig m => m a - badConst = throwError $ Fatal badConstMsg - - badConstMsg :: Text - badConstMsg = - T.unlines - [ "Bad application of execConst:" - , T.pack (show c) - , T.pack (show (reverse vs)) - , prettyText (Out (VCApp c (reverse vs)) s k) - ] - - doResonate :: - (HasRobotStepState sig m, Has (Lift IO) sig m) => - (Maybe Entity -> Bool) -> - Integer -> - Integer -> - Integer -> - Integer -> - m CESK - doResonate p x1 y1 x2 y2 = do - loc <- use robotLocation - let offsets = rectCells x1 y1 x2 y2 - hits <- mapM (fmap (fromEnum . p) . entityAt . offsetBy loc) offsets - return $ Out (VInt $ fromIntegral $ sum hits) s k - - rectCells :: Integer -> Integer -> Integer -> Integer -> [V2 Int32] - rectCells x1 y1 x2 y2 = - rectCellsInt32 - (fromIntegral x1) - (fromIntegral y1) - (fromIntegral x2) - (fromIntegral y2) - - rectCellsInt32 :: Int32 -> Int32 -> Int32 -> Int32 -> [V2 Int32] - rectCellsInt32 x1 y1 x2 y2 = [V2 x y | x <- [xMin .. xMax], y <- [yMin .. yMax]] - where - (xMin, xMax) = sortPair (x1, x2) - (yMin, yMax) = sortPair (y1, y2) - - findNearest :: - HasRobotStepState sig m => - Text -> - m (Maybe (Int32, V2 Int32)) - findNearest name = do - loc <- use robotLocation - let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc . snd - findM f sortedOffsets - where - sortedOffsets :: [(Int32, V2 Int32)] - sortedOffsets = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange] - - -- Grow a list of locations in a diamond shape outward, such that the nearest cells - -- are searched first by construction, rather than having to sort. - genDiamondSides :: Int32 -> [(Int32, V2 Int32)] - genDiamondSides diameter = concat [f diameter x | x <- [0 .. diameter]] - where - -- Adds a single cell to each of the four sides of the diamond - f d x = map (d,) . take 4 . iterate perp $ V2 x (d - x) - - finishCookingRecipe :: - HasRobotStepState sig m => - Recipe e -> - Value -> - [WorldUpdate Entity] -> - [RobotUpdate] -> - m CESK - finishCookingRecipe r v wf rf = - if remTime <= 0 - then do - updateWorldAndRobots c wf rf - return $ Out v s k - else do - time <- use $ temporal . ticks - return . (if remTime <= 1 then id else Waiting (addTicks (fromIntegral remTime) time)) $ - Out v s (FImmediate c wf rf : k) - where - remTime = r ^. recipeTime - - ensureEquipped :: HasRobotStepState sig m => Text -> m Entity - ensureEquipped itemName = do - inst <- use equippedDevices - listToMaybe (lookupByName itemName inst) - `isJustOrFail` ["You don't have a", indefinite itemName, "equipped."] - - ensureItem :: HasRobotStepState sig m => Text -> Text -> m Entity - ensureItem itemName action = do - -- First, make sure we know about the entity. - inv <- use robotInventory - inst <- use equippedDevices - item <- - asum (map (listToMaybe . lookupByName itemName) [inv, inst]) - `isJustOrFail` ["What is", indefinite itemName <> "?"] - - -- Next, check whether we have one. If we don't, add a hint about - -- 'create' in creative mode. - creative <- use creativeMode - let create l = l <> ["You can make one first with 'create \"" <> itemName <> "\"'." | creative] - - (E.lookup item inv > 0) - `holdsOrFail` create ["You don't have", indefinite itemName, "to", action <> "."] - - return item - - -- Check the required devices and inventory for running the given - -- command on a target robot. This function is used in common by - -- both 'Build' and 'Reprogram'. - -- - -- It is given as inputs the parent robot inventory, the inventory - -- and equipped devices of the child (these will be empty in the - -- case of 'Build'), and the command to be run (along with a few - -- inputs to configure any error messages to be generated). - -- - -- Throws an exception if it's not possible to set up the child - -- robot with the things it needs to execute the given program. - -- Otherwise, returns a pair consisting of the set of devices to be - -- equipped, and the inventory that should be transferred from - -- parent to child. - checkRequirements :: - HasRobotStepState sig m => - Inventory -> - Inventory -> - Inventory -> - Term -> - Text -> - IncapableFix -> - m (Set Entity, Inventory) - checkRequirements parentInventory childInventory childDevices cmd subject fixI = do - currentContext <- use $ robotContext . defReqs - em <- use $ landscape . entityMap - creative <- use creativeMode - let -- Note that _capCtx must be empty: at least at the - -- moment, definitions are only allowed at the top level, - -- so there can't be any inside the argument to build. - -- (Though perhaps there is an argument that this ought to be - -- relaxed specifically in the cases of 'Build' and 'Reprogram'.) - -- See #349 - (R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames, _capCtx) = R.requirements currentContext cmd - - -- Check that all required device names exist (fail with - -- an exception if not) and convert them to 'Entity' values. - (devs :: [Entity]) <- forM devNames $ \devName -> - E.lookupEntityName devName em `isJustOrFail` ["Unknown device required: " <> devName] - - -- Check that all required inventory entity names exist (fail with - -- an exception if not) and convert them to 'Entity' values, with - -- an associated count for each. - (reqInv :: Inventory) <- fmap E.fromElems . forM (M.assocs reqInvNames) $ \(eName, n) -> - (n,) - <$> ( E.lookupEntityName eName em - `isJustOrFail` ["Unknown entity required: " <> eName] - ) - - let -- List of possible devices per requirement. For the - -- requirements that stem from a required capability, we - -- remember the capability alongside the possible devices, to - -- help with later error message generation. - possibleDevices :: [(Maybe Capability, [Entity])] - possibleDevices = - map (Just &&& (`deviceForCap` em)) caps -- Possible devices for capabilities - ++ map ((Nothing,) . (: [])) devs -- Outright required devices - - -- A device is OK if it is available in the inventory of the - -- parent robot, or already equipped in the child robot. - deviceOK :: Entity -> Bool - deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d - - -- Partition each list of possible devices into a set of - -- available devices and a set of unavailable devices. - -- There's a problem if some capability is required but no - -- devices that provide it are available. In that case we can - -- print an error message, using the second set as a list of - -- suggestions. - partitionedDevices :: [(Set Entity, Set Entity)] - partitionedDevices = - map (Lens.over both S.fromList . L.partition deviceOK . snd) possibleDevices - - -- Devices equipped on the child, as a Set instead of an - -- Inventory for convenience. - alreadyEquipped :: Set Entity - alreadyEquipped = S.fromList . map snd . E.elems $ childDevices - - -- Figure out what is still missing of the required inventory: - -- the required inventory, less any inventory the child robot - -- already has. - missingChildInv = reqInv `E.difference` childInventory - - if creative - then - return - ( -- In creative mode, just equip ALL the devices - -- providing each required capability (because, why - -- not?). But don't re-equip any that are already - -- equipped. - S.unions (map (S.fromList . snd) possibleDevices) `S.difference` alreadyEquipped - , -- Conjure the necessary missing inventory out of thin - -- air. - missingChildInv - ) - else do - -- First, check that devices actually exist AT ALL to provide every - -- required capability. If not, we will generate an error message saying - -- something like "missing capability X but no device yet provides it". - let capsWithNoDevice = mapMaybe fst . filter (null . snd) $ possibleDevices - null capsWithNoDevice - `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 - null missingDevices - `holdsOrFail` ( singularSubjectVerb subject "do" - : "not have required devices, please" - : formatIncapableFix fixI <> ":" - : (("\n - " <>) . formatDevices <$> missingDevices) - ) - - let minimalEquipSet = smallHittingSet (filter (S.null . S.intersection alreadyEquipped) (map fst partitionedDevices)) - - -- Check that we have enough in our inventory to cover the - -- required devices PLUS what's missing from the child - -- inventory. - - -- What do we need? - neededParentInv = - missingChildInv - `E.union` (fromList . S.toList $ minimalEquipSet) - - -- What are we missing? - missingParentInv = neededParentInv `E.difference` parentInventory - missingMap = - M.fromList - . filter ((> 0) . snd) - . map (swap . second (^. entityName)) - . E.elems - $ missingParentInv - - -- If we're missing anything, throw an error - E.isEmpty missingParentInv - `holdsOr` Incapable fixI (R.Requirements S.empty S.empty missingMap) cmd - - return (minimalEquipSet, missingChildInv) - - -- Destroy the current robot, as long as it is not the base robot. - -- - -- Depending on whether we destroy (True) or do not destroy - -- (False) the current robot, possibly grant an achievement. - -- - -- Note we cannot simply return a Boolean and grant achievements - -- at call sites, because in the case that we do not destroy the - -- base we actually throw an exception, so we do not return to the - -- original call site. - destroyIfNotBase :: - (HasRobotStepState sig m, Has (Lift IO) sig m) => - (Bool -> Maybe GameplayAchievement) -> - m () - destroyIfNotBase mAch = do - rid <- use robotID - holdsOrFailWithAchievement - (rid /= 0) - ["You consider destroying your base, but decide not to do it after all."] - (mAch False) - - selfDestruct .= True - maybe (return ()) grantAchievement (mAch True) - - moveInDirection :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Heading -> m CESK - moveInDirection orientation = do - -- Figure out where we're going - loc <- use robotLocation - let nextLoc = loc `offsetBy` orientation - checkMoveAhead nextLoc $ \case - PathBlocked -> ThrowExn - PathLiquid -> Destroy - updateRobotLocation loc nextLoc - return $ Out VUnit s k - - applyMoveFailureEffect :: - (HasRobotStepState sig m, Has (Lift IO) sig m) => - Maybe MoveFailureDetails -> - MoveFailureHandler -> - m () - applyMoveFailureEffect maybeFailure failureHandler = - case maybeFailure of - Nothing -> return () - Just (MoveFailureDetails e 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 - PathBlocked -> ["There is a", e ^. entityName, "in the way!"] - PathLiquid -> ["There is a dangerous liquid", e ^. entityName, "in the way!"] - - -- Determine the move failure mode and apply the corresponding effect. - checkMoveAhead :: - (HasRobotStepState sig m, Has (Lift IO) sig m) => - Cosmic Location -> - MoveFailureHandler -> - m () - checkMoveAhead nextLoc failureHandler = do - maybeFailure <- checkMoveFailure nextLoc - applyMoveFailureEffect maybeFailure failureHandler - - getRobotWithinTouch :: HasRobotStepState sig m => RID -> m Robot - getRobotWithinTouch rid = do - cid <- use robotID - if cid == rid - then get @Robot - else do - mother <- robotWithID rid - other <- mother `isJustOrFail` ["There is no robot with ID", from (show rid) <> "."] - - let otherLoc = other ^. robotLocation - privileged <- isPrivilegedBot - myLoc <- use robotLocation - - -- Make sure it is either in the same location or we do not care - isNearbyOrExempt privileged myLoc otherLoc - `holdsOrFail` ["The robot with ID", from (show rid), "is not close enough."] - return other - - holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m () - holdsOrFail = holdsOrFail' c - - holdsOrFailWithAchievement :: (Has (Throw Exn) sig m) => Bool -> [Text] -> Maybe GameplayAchievement -> m () - holdsOrFailWithAchievement a ts mAch = case mAch of - Nothing -> holdsOrFail a ts - Just ach -> a `holdsOr` cmdExnWithAchievement c ts ach - - isJustOrFail :: (Has (Throw Exn) sig m) => Maybe a -> [Text] -> m a - isJustOrFail = isJustOrFail' c - - returnEvalCmp = case vs of - [v1, v2] -> (\b -> Out (VBool b) s k) <$> evalCmp c v1 v2 - _ -> badConst - returnEvalArith = case vs of - [VInt n1, VInt n2] -> (\r -> Out (VInt r) s k) <$> evalArith c n1 n2 - _ -> badConst - - -- Make sure the robot has the thing in its inventory - hasInInventoryOrFail :: HasRobotStepState sig m => Text -> m Entity - hasInInventoryOrFail eName = do - inv <- use robotInventory - e <- - listToMaybe (lookupByName eName inv) - `isJustOrFail` ["What is", indefinite eName <> "?"] - let cmd = T.toLower . T.pack . show $ c - (E.lookup e inv > 0) - `holdsOrFail` ["You don't have", indefinite eName, "to", cmd <> "."] - return e - - mkReturn :: Valuable a => a -> CESK - mkReturn x = Out (asValue x) s k - - -- The code for grab and harvest is almost identical, hence factored - -- out here. - doGrab :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GrabbingCmd -> m Entity - doGrab cmd = do - let verb = verbGrabbingCmd cmd - verbed = verbedGrabbingCmd cmd - - -- Ensure there is an entity here. - loc <- use robotLocation - e <- - entityAt loc - >>= (`isJustOrFail` ["There is nothing here to", verb <> "."]) - - -- Ensure it can be picked up. - omni <- isPrivilegedBot - (omni || e `hasProperty` Portable) - `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."] - - -- Remove the entity from the world. - updateEntityAt loc (const Nothing) - flagRedraw - - -- Immediately regenerate entities with 'infinite' property. - when (e `hasProperty` Infinite) $ - updateEntityAt loc (const (Just e)) - - -- Possibly regrow the entity, if it is growable and the 'harvest' - -- command was used. - when ((e `hasProperty` Growable) && cmd == Harvest') $ do - let GrowthTime (minT, maxT) = (e ^. entityGrowth) ? defaultGrowthTime - - createdAt <- getNow - - -- Grow a new entity from a seed. - addSeedBot e (minT, maxT) loc createdAt - - -- Add the picked up item to the robot's inventory. If the - -- entity yields something different, add that instead. - let yieldName = e ^. entityYields - e' <- case yieldName of - Nothing -> return e - Just n -> fromMaybe e <$> uses (landscape . entityMap) (lookupEntityName n) - - robotInventory %= insert e' - updateDiscoveredEntities e' - - -- Return the item obtained. - return e' - ------------------------------------------------------------- --- The "watch" command ------------------------------------------------------------- - -addWatchedLocation :: - HasRobotStepState sig m => - Cosmic Location -> - m () -addWatchedLocation loc = do - rid <- use robotID - robotsWatching %= M.insertWith (<>) loc (S.singleton rid) - --- | Clear watches that are out of range -purgeFarAwayWatches :: - HasRobotStepState sig m => m () -purgeFarAwayWatches = do - privileged <- isPrivilegedBot - myLoc <- use robotLocation - rid <- use robotID - - let isNearby = isNearbyOrExempt privileged myLoc - f loc = - if not $ isNearby loc - then S.delete rid - else id - - robotsWatching %= M.filter (not . null) . M.mapWithKey f - ------------------------------------------------------------- --- Some utility functions ------------------------------------------------------------- - --- | Requires that the target location is within one cell. --- Requirement is waived if the bot is privileged. -isNearbyOrExempt :: Bool -> Cosmic Location -> Cosmic Location -> Bool -isNearbyOrExempt privileged myLoc otherLoc = - privileged || case cosmoMeasure manhattan myLoc otherLoc of - InfinitelyFar -> False - Measurable x -> x <= 1 - -grantAchievement :: - (Has (State GameState) sig m, Has (Lift IO) sig m) => - GameplayAchievement -> - m () -grantAchievement a = do - currentTime <- sendIO getZonedTime - scenarioPath <- use currentScenarioPath - discovery . gameAchievements - %= M.insertWith - (<>) - a - (Attainment (GameplayAchievement a) scenarioPath currentTime) - --- | How to handle failure, for example when moving to blocked location -data RobotFailure = ThrowExn | Destroy | IgnoreFail - --- | How to handle different types of failure when moving/teleporting --- to a location. -type MoveFailureHandler = MoveFailureMode -> RobotFailure - -data GrabbingCmd = Grab' | Harvest' | Swap' | Push' deriving (Eq, Show) - -verbGrabbingCmd :: GrabbingCmd -> Text -verbGrabbingCmd = \case - Harvest' -> "harvest" - Grab' -> "grab" - Swap' -> "swap" - Push' -> "push" - -verbedGrabbingCmd :: GrabbingCmd -> Text -verbedGrabbingCmd = \case - Harvest' -> "harvested" - Grab' -> "grabbed" - Swap' -> "swapped" - Push' -> "pushed" - --- | Format a set of suggested devices for use in an error message, --- in the format @device1 or device2 or ... or deviceN@. -formatDevices :: Set Entity -> Text -formatDevices = T.intercalate " or " . map (^. entityName) . S.toList - --- | Give some entities from a parent robot (the robot represented by --- the ambient @State Robot@ effect) to a child robot (represented --- by the given 'RID') as part of a 'Swarm.Language.Syntax.Build' --- or 'Swarm.Language.Syntax.Reprogram' command. --- The first 'Inventory' is devices to be equipped, and the second --- is entities to be transferred. --- --- In classic mode, the entities will be /transferred/ (that is, --- removed from the parent robot's inventory); in creative mode, the --- entities will be copied/created, that is, no entities will be --- removed from the parent robot. -provisionChild :: - (HasRobotStepState sig m) => - RID -> - Inventory -> - Inventory -> - m () -provisionChild childID toEquip toGive = do - -- Equip and give devices to child - robotMap . ix childID . equippedDevices %= E.union toEquip - robotMap . ix childID . robotInventory %= E.union toGive - - -- Delete all items from parent in classic mode - creative <- use creativeMode - unless creative $ - robotInventory %= (`E.difference` (toEquip `E.union` toGive)) - --- | Update the location of a robot, and simultaneously update the --- 'robotsByLocation' map, so we can always look up robots by --- location. This should be the /only/ way to update the location --- of a robot. --- Also implements teleportation by portals. -updateRobotLocation :: - (HasRobotStepState sig m) => - Cosmic Location -> - Cosmic Location -> - m () -updateRobotLocation oldLoc newLoc - | oldLoc == newLoc = return () - | otherwise = do - newlocWithPortal <- applyPortal newLoc - rid <- use robotID - removeRobotFromLocationMap oldLoc rid - addRobotToLocation rid newlocWithPortal - modify (unsafeSetRobotLocation newlocWithPortal) - flagRedraw - where - applyPortal loc = do - lms <- use $ landscape . worldNavigation - let maybePortalInfo = M.lookup loc $ portals lms - updatedLoc = maybe loc destination maybePortalInfo - maybeTurn = reorientation <$> maybePortalInfo - forM_ maybeTurn $ \d -> - robotOrientation . _Just %= applyTurn d - return updatedLoc - --- | Execute a stateful action on a target robot --- whether the --- current one or another. -onTarget :: - (HasRobotStepState sig m, Has (Lift IO) sig m) => - RID -> - (forall sig' m'. (HasRobotStepState sig' m', Has (Lift IO) sig' m') => m' ()) -> - m () -onTarget rid act = do - myID <- use robotID - case myID == rid of - True -> act - False -> do - mtgt <- use (robotMap . at rid) - case mtgt of - Nothing -> return () - Just tgt -> do - tgt' <- execState @Robot tgt act - if tgt' ^. selfDestruct - then deleteRobot rid - else robotMap . ix rid .= tgt' - ------------------------------------------------------------- --- Comparison ------------------------------------------------------------- - --- | Evaluate the application of a comparison operator. Returns --- @Nothing@ if the application does not make sense. -evalCmp :: Has (Throw Exn) sig m => Const -> Value -> Value -> m Bool -evalCmp c v1 v2 = decideCmp c $ compareValues v1 v2 - where - decideCmp = \case - Eq -> fmap (== EQ) - Neq -> fmap (/= EQ) - Lt -> fmap (== LT) - Gt -> fmap (== GT) - Leq -> fmap (/= GT) - Geq -> fmap (/= LT) - _ -> const . throwError . Fatal . T.append "evalCmp called on bad constant " . from $ show c - --- | Compare two values, returning an 'Ordering' if they can be --- compared, or @Nothing@ if they cannot. -compareValues :: Has (Throw Exn) sig m => Value -> Value -> m Ordering -compareValues v1 = case v1 of - VUnit -> \case VUnit -> return EQ; v2 -> incompatCmp VUnit v2 - VInt n1 -> \case VInt n2 -> return (compare n1 n2); v2 -> incompatCmp v1 v2 - VText t1 -> \case VText t2 -> return (compare t1 t2); v2 -> incompatCmp v1 v2 - VDir d1 -> \case VDir d2 -> return (compare d1 d2); v2 -> incompatCmp v1 v2 - VBool b1 -> \case VBool b2 -> return (compare b1 b2); v2 -> incompatCmp v1 v2 - VRobot r1 -> \case VRobot r2 -> return (compare r1 r2); v2 -> incompatCmp v1 v2 - VInj s1 v1' -> \case - VInj s2 v2' -> - case compare s1 s2 of - EQ -> compareValues v1' v2' - o -> return o - v2 -> incompatCmp v1 v2 - VPair v11 v12 -> \case - VPair v21 v22 -> - (<>) <$> compareValues v11 v21 <*> compareValues v12 v22 - v2 -> incompatCmp v1 v2 - VRcd m1 -> \case - VRcd m2 -> mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2 - v2 -> incompatCmp v1 v2 - VKey kc1 -> \case - VKey kc2 -> return (compare kc1 kc2) - v2 -> incompatCmp v1 v2 - VClo {} -> incomparable v1 - VCApp {} -> incomparable v1 - VDef {} -> incomparable v1 - VResult {} -> incomparable v1 - VBind {} -> incomparable v1 - VDelay {} -> incomparable v1 - VRef {} -> incomparable v1 - VRequirements {} -> incomparable v1 - --- | Values with different types were compared; this should not be --- possible since the type system should catch it. -incompatCmp :: Has (Throw Exn) sig m => Value -> Value -> m a -incompatCmp v1 v2 = - throwError $ - Fatal $ - T.unwords ["Incompatible comparison of ", prettyValue v1, "and", prettyValue v2] - --- | Values were compared of a type which cannot be compared --- (e.g. functions, etc.). -incomparable :: Has (Throw Exn) sig m => Value -> Value -> m a -incomparable v1 v2 = - throwError $ - cmdExn - Lt - ["Comparison is undefined for ", prettyValue v1, "and", prettyValue v2] - ------------------------------------------------------------- --- Arithmetic ------------------------------------------------------------- - --- | Evaluate the application of an arithmetic operator, returning --- an exception in the case of a failing operation, or in case we --- incorrectly use it on a bad 'Const' in the library. -evalArith :: Has (Throw Exn) sig m => Const -> Integer -> Integer -> m Integer -evalArith = \case - Add -> ok (+) - Sub -> ok (-) - Mul -> ok (*) - Div -> safeDiv - Exp -> safeExp - c -> \_ _ -> throwError $ Fatal $ T.append "evalArith called on bad constant " (from (show c)) - where - ok f x y = return $ f x y - --- | Perform an integer division, but return @Nothing@ for division by --- zero. -safeDiv :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer -safeDiv _ 0 = throwError $ cmdExn Div $ pure "Division by zero" -safeDiv a b = return $ a `div` b - --- | Perform exponentiation, but return @Nothing@ if the power is negative. -safeExp :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer -safeExp a b - | b < 0 = throwError $ cmdExn Exp $ pure "Negative exponent" - | otherwise = return $ a ^ b - ------------------------------------------------------------- --- Updating discovered entities, recipes, and commands ------------------------------------------------------------- - --- | Update the global list of discovered entities, and check for new recipes. -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 - --- | Update the availableRecipes list. --- This implementation is not efficient: --- * Every time we discover a new entity, we iterate through the entire list of recipes to see which ones we can make. --- Trying to do something more clever seems like it would definitely be a case of premature optimization. --- One doesn't discover new entities all that often. --- * For each usable recipe, we do a linear search through the list of known recipes to see if we already know it. --- This is a little more troubling, since it's quadratic in the number of recipes. --- But it probably doesn't really make that much difference until we get up to thousands of recipes. -updateAvailableRecipes :: Has (State GameState) sig m => (Inventory, Inventory) -> Entity -> m () -updateAvailableRecipes invs e = do - allInRecipes <- use $ recipesInfo . recipesIn - let entityRecipes = recipesFor allInRecipes e - usableRecipes = filter (knowsIngredientsFor invs) entityRecipes - knownRecipes <- use $ discovery . availableRecipes . notificationsContent - let newRecipes = filter (`notElem` knownRecipes) usableRecipes - newCount = length newRecipes - discovery . availableRecipes %= mappend (Notifications newCount newRecipes) - updateAvailableCommands e - -updateAvailableCommands :: Has (State GameState) sig m => Entity -> m () -updateAvailableCommands e = do - let newCaps = e ^. entityCapabilities - keepConsts = \case - Just cap -> cap `S.member` newCaps - Nothing -> False - entityConsts = filter (keepConsts . constCaps) allConst - knownCommands <- use $ discovery . availableCommands . notificationsContent - let newCommands = filter (`notElem` knownCommands) entityConsts - newCount = length newCommands - discovery . availableCommands %= mappend (Notifications newCount newCommands) diff --git a/src/Swarm/Game/Step/Combustion.hs b/src/Swarm/Game/Step/Combustion.hs deleted file mode 100644 --- a/src/Swarm/Game/Step/Combustion.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Some entities are "combustible". A command, 'Swarm.Language.Syntax.Ignite', will --- initiate combustion on such an entity. --- Furthermore, combustion can spread to (4-)adjacent entities, depending --- on the 'ignition' property of that entity. --- --- Short-lived robots are used to illustrate the combusting entity as --- 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.Effect.Lift -import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) -import Control.Monad (forM_, void, when) -import Data.Text qualified as T -import Linear (zero) -import Swarm.Game.CESK (emptyStore, initMachine) -import Swarm.Game.Display -import Swarm.Game.Entity hiding (empty, lookup, singleton, union) -import Swarm.Game.Entity qualified as E -import Swarm.Game.Location -import Swarm.Game.Robot -import Swarm.Game.State -import Swarm.Game.Step.Util -import Swarm.Game.Universe -import Swarm.Language.Context (empty) -import Swarm.Language.Pipeline (ProcessedTerm) -import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Syntax -import Swarm.Language.Text.Markdown qualified as Markdown -import Swarm.Util hiding (both) -import System.Clock (TimeSpec) -import Prelude hiding (Applicative (..), lookup) - -igniteCommand :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Const -> Direction -> m () -igniteCommand c d = do - (loc, me) <- lookInDirection d - -- Ensure there is an entity here. - e <- - me `isJustOrFail` ["There is nothing here to", verb <> "."] - - -- Ensure it can be ignited. - (e `hasProperty` Combustible) - `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."] - - -- Remove the entity from the world. - updateEntityAt loc (const Nothing) - flagRedraw - - -- Start burning process - let selfCombustibility = (e ^. entityCombustion) ? defaultCombustibility - createdAt <- getNow - combustionDurationRand <- addCombustionBot e selfCombustibility createdAt loc - forM_ (getNeighborLocs loc) $ igniteNeighbor createdAt combustionDurationRand - where - verb = "ignite" - verbed = "ignited" - - holdsOrFail = holdsOrFail' c - isJustOrFail = isJustOrFail' c - --- | Construct a "combustion robot" from entity and position --- and add it to the world. --- It has low priority and will be covered --- by placed entities. --- The "combustion bot" represents the burning of a single --- entity; propagating the fire to neighbors is handled upstream, --- within the 'Swarm.Language.Syntax.Ignite' command. -addCombustionBot :: - Has (State GameState) sig m => - Entity -> - Combustibility -> - TimeSpec -> - Cosmic Location -> - m Integer -addCombustionBot inputEntity combustibility ts loc = do - botInventory <- case maybeCombustionProduct of - Nothing -> return [] - Just n -> do - maybeE <- uses (landscape . entityMap) (lookupEntityName n) - return $ maybe [] (pure . (1,)) maybeE - combustionDurationRand <- uniform durationRange - let combustionProg = combustionProgram combustionDurationRand combustibility - void $ - addTRobot $ - mkRobot - () - Nothing - "fire" - (Markdown.fromText $ T.unwords ["A burning", (inputEntity ^. entityName) <> "."]) - (Just loc) - zero - ( defaultEntityDisplay '*' - & displayAttr .~ AWorld "fire" - & displayPriority .~ 0 - ) - (initMachine combustionProg empty emptyStore) - [] - botInventory - True - False - mempty - ts - return combustionDurationRand - where - Combustibility _ durationRange maybeCombustionProduct = combustibility - --- Triggers the ignition of the entity underfoot with some delay. -ignitionProgram :: Integer -> ProcessedTerm -ignitionProgram waitTime = - [tmQ| - wait $int:waitTime; - try { - ignite down; - noop; - } {}; - selfdestruct - |] - --- | A system program for a "combustion robot", to burn an entity --- after it is ignited. --- --- For efficiency, we determine a priori (i.e. the instant --- the combustion robot is spawned) whether any neighbors will eventually --- be burned, based on probabilities. --- --- Note that it is possible that new neighbors may be introduced while --- combustion is in progress. Although it may be more realistic to subject --- these to possible combustion as well, we do not bother. --- --- Though if we did actually want to do that, some options are: --- --- 1. Create sub-partitions (of say, 10-tick duration) of the combustion duration --- to re-evaluate opportunities to light adjacent entities on fire. --- 2. Use the 'Swarm.Language.Syntax.Watch' command to observe for changes to adjacent entities. --- Note that if we "wake" from our 'Swarm.Language.Syntax.Wait' due to the 'Swarm.Language.Syntax.Watch' being triggered, --- we would need to maintain bookkeeping of how much time is left. --- 3. Spawn more robots whose sole purpose is to observe for changes to neighbor --- cells. This would avoid polluting the logic of the currently burning cell --- with logic to manage probabilities of combustion propagation. -combustionProgram :: Integer -> Combustibility -> ProcessedTerm -combustionProgram combustionDuration (Combustibility _ _ maybeCombustionProduct) = - [tmQ| - wait $int:combustionDuration; - if ($int:invQuantity > 0) { - try { - place $str:combustionProduct; - } {}; - } {}; - selfdestruct - |] - where - (invQuantity, combustionProduct) = case maybeCombustionProduct of - 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. -igniteNeighbor :: - Has (State GameState) sig m => - TimeSpec -> - Integer -> - Cosmic Location -> - m () -igniteNeighbor creationTime sourceDuration loc = do - maybeEnt <- entityAt loc - forM_ maybeEnt igniteEntity - where - igniteEntity e = - when (e `hasProperty` Combustible) $ do - threshold <- uniform (0, 1) - when (probabilityOfIgnition >= threshold) $ do - ignitionDelayRand <- uniform (0, 1) - let ignitionDelay = - floor - . min (fromIntegral sourceDuration) - . negate - $ log ignitionDelayRand / rate - addIgnitionBot ignitionDelay e creationTime loc - where - neighborCombustibility = (e ^. entityCombustion) ? defaultCombustibility - rate = E.ignition neighborCombustibility - probabilityOfIgnition = 1 - exp (negate $ rate * fromIntegral sourceDuration) - --- | Construct an invisible "ignition robot" and add it to the world. --- Its sole purpose is to delay the 'Swarm.Language.Syntax.Ignite' command for a neighbor --- that has been a priori determined that it shall be ignited. -addIgnitionBot :: - Has (State GameState) sig m => - Integer -> - Entity -> - TimeSpec -> - Cosmic Location -> - m () -addIgnitionBot ignitionDelay inputEntity ts loc = - void $ - addTRobot $ - mkRobot - () - Nothing - "firestarter" - (Markdown.fromText $ T.unwords ["Delayed ignition of", (inputEntity ^. entityName) <> "."]) - (Just loc) - zero - ( defaultEntityDisplay '*' - & invisible .~ True - ) - (initMachine (ignitionProgram ignitionDelay) empty emptyStore) - [] - [] - True - False - mempty - ts diff --git a/src/Swarm/Game/Step/Pathfinding.hs b/src/Swarm/Game/Step/Pathfinding.hs deleted file mode 100644 --- a/src/Swarm/Game/Step/Pathfinding.hs +++ /dev/null @@ -1,137 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Implementation of the @path@ command for robots. --- --- = Design considerations --- One possible design of the @path@ command entailed storing a computed --- shortest path and providing a mechanism to retrieve parts of it later --- without recomputing the whole thing. --- However, in general the playfield can be dynamic and obstructions may --- appear that invalidate a given computed shortest path. --- Therefore, there can be limited value in caching a computed path for use --- across ticks. --- --- Instead, in the current implementation a complete path is computed --- internally upon invoking the @path@ command, and just the direction of the --- first "move" along that path is returned as a result to the caller. --- --- == Max distance --- --- We allow the caller to supply a max distance, but also impose an internal maximum --- distance to prevent programming errors from irrecoverably freezing the game. -module Swarm.Game.Step.Pathfinding where - -import Control.Carrier.State.Lazy -import Control.Effect.Lens -import Control.Monad (filterM, guard) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Graph.AStar (aStarM) -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Int (Int32) -import Swarm.Game.Entity -import Swarm.Game.Location -import Swarm.Game.State -import Swarm.Game.Step.Util -import Swarm.Game.Universe -import Swarm.Language.Syntax -import Swarm.Util (hoistMaybe) - --- | Shortest paths can either be computed to the nearest entity of --- a given type or to a specific location. -data PathfindingTarget - = LocationTarget Location - | -- | Note: navigation to entities does not benefit from the - -- distance heuristic optimization of the A* algorithm. - EntityTarget EntityName - --- | swarm command arguments are converted to idiomatic Haskell --- types before invoking this function, and conversely the callsite --- is also responsible for translating the output type to a swarm value. --- --- The cost function is uniformly @1@ between adjacent cells. --- --- Viable paths are determined by walkability. --- If the goal type is an Entity, than it is permissible for that --- entity to be 'Unwalkable'. -pathCommand :: - (HasRobotStepState sig m, Has (State GameState) sig m) => - -- | Distance limit - Maybe Integer -> - -- | Starting location - Cosmic Location -> - -- | Search goal - PathfindingTarget -> - m (Maybe Direction) -pathCommand maybeLimit (Cosmic currentSubworld robotLoc) target = do - -- This is a short-circuiting optimization; if the goal itself - -- is not a walkable cell, then no amount of searching will reach it. - isGoalLocWalkable <- case target of - LocationTarget loc -> null <$> checkMoveFailure (Cosmic currentSubworld loc) - EntityTarget _ -> return True - - runMaybeT $ do - guard isGoalLocWalkable - maybeFoundPath <- lift computePath - foundPath <- hoistMaybe maybeFoundPath - return $ nextDir foundPath - where - computePath = - aStarM - (neighborFunc withinDistanceLimit . Cosmic currentSubworld) - (const $ const $ return 1) - (return . distHeuristic) - goalReachedFunc - (return robotLoc) - - withinDistanceLimit :: Location -> Bool - withinDistanceLimit = (<= distanceLimit) . fromIntegral . manhattan robotLoc - - -- Extracts the head of the found path to determine - -- the next direction for the robot to proceed along - nextDir :: [Location] -> Direction - nextDir pathLocs = case pathLocs of - [] -> DRelative DDown - (nextLoc : _) -> DAbsolute $ nearestDirection $ nextLoc .-. robotLoc - - neighborFunc :: - HasRobotStepState sig m => - (Location -> Bool) -> - Cosmic Location -> - m (HashSet Location) - neighborFunc isWithinRange loc = do - locs <- filterM isWalkableLoc neighborLocs - return $ HashSet.fromList $ map (view planar) locs - where - neighborLocs = getNeighborLocs loc - isWalkableLoc someLoc = - if not $ isWithinRange $ view planar someLoc - then return False - else do - isGoal <- goalReachedFunc $ view planar someLoc - if isGoal - then return True - else null <$> checkMoveFailureUnprivileged someLoc - - -- This is an optimization for when a specific location - -- is given as the target. - -- However, it is not strictly necessary, and in fact - -- cannot be used when the target is a certain type of - -- entity. - distHeuristic :: Location -> Int32 - distHeuristic = case target of - LocationTarget gLoc -> manhattan gLoc - EntityTarget _eName -> const 0 - - goalReachedFunc :: Has (State GameState) sig m => Location -> m Bool - goalReachedFunc loc = case target of - LocationTarget gLoc -> return $ loc == gLoc - EntityTarget eName -> do - me <- entityAt $ Cosmic currentSubworld loc - return $ (view entityName <$> me) == Just eName - - -- A failsafe limit is hardcoded to prevent the game from freezing - -- if an error exists in some .sw code. - distanceLimit = maybe maxPathRange (min maxPathRange) maybeLimit diff --git a/src/Swarm/Game/Step/Util.hs b/src/Swarm/Game/Step/Util.hs deleted file mode 100644 --- a/src/Swarm/Game/Step/Util.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -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.Effect.Lift -import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) -import Control.Monad (forM, forM_, guard, join, when) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Array (bounds, (!)) -import Data.IntMap qualified as IM -import Data.List (find) -import Data.Map qualified as M -import Data.Set qualified as S -import Data.Text (Text) -import Data.Text qualified as T -import Linear (zero) -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.State -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.Game.World.Modify qualified as WM -import Swarm.Language.Capability -import Swarm.Language.Requirement qualified as R -import Swarm.Language.Syntax -import Swarm.Util hiding (both) -import System.Clock (TimeSpec) -import System.Clock qualified -import System.Random (UniformRange, uniformR) -import Prelude hiding (Applicative (..), lookup) - --- | All functions that are used for robot step can access 'GameState' and the current 'Robot'. --- --- They can also throw exception of our custom type, which is handled elsewhere. --- Because of that the constraint is only 'Throw', but not 'Catch'/'Error'. -type HasRobotStepState sig m = (Has (State GameState) sig m, Has (State Robot) sig m, Has (Throw Exn) sig m) - -deriveHeading :: HasRobotStepState sig m => Direction -> m Heading -deriveHeading d = do - orient <- use robotOrientation - when (isCardinal d) $ hasCapabilityFor COrient $ TDir d - return $ applyTurn d $ orient ? zero - -lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmic Location, Maybe Entity) -lookInDirection d = do - newHeading <- deriveHeading d - loc <- use robotLocation - let nextLoc = loc `offsetBy` newHeading - (nextLoc,) <$> entityAt nextLoc - --- | Modify the entity (if any) at a given location. -updateEntityAt :: - (Has (State GameState) sig m) => - Cosmic Location -> - (Maybe Entity -> Maybe Entity) -> - m () -updateEntityAt cLoc@(Cosmic subworldName loc) upd = do - someChange <- - zoomWorld subworldName $ - W.updateM @Int (W.locToCoords loc) upd - - forM_ (WM.getModification =<< someChange) $ \_modType -> do - wakeWatchingRobots cLoc - --- * Capabilities - --- | Exempts the robot from various command constraints --- when it is either a system robot or playing in creative mode -isPrivilegedBot :: (Has (State GameState) sig m, Has (State Robot) sig m) => m Bool -isPrivilegedBot = (||) <$> use systemRobot <*> use creativeMode - --- | Test whether the current robot has a given capability (either --- because it has a device which gives it that capability, or it is a --- system robot, or we are in creative mode). -hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool -hasCapability cap = do - isPrivileged <- isPrivilegedBot - caps <- use robotCapabilities - return (isPrivileged || cap `S.member` caps) - --- | Ensure that either a robot has a given capability, OR we are in creative --- mode. -hasCapabilityFor :: - (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m () -hasCapabilityFor cap term = do - h <- hasCapability cap - h `holdsOr` Incapable FixByEquip (R.singletonCap cap) term - --- * Exceptions - -holdsOrFail' :: (Has (Throw Exn) sig m) => Const -> Bool -> [Text] -> m () -holdsOrFail' c a ts = a `holdsOr` cmdExn c ts - -isJustOrFail' :: (Has (Throw Exn) sig m) => Const -> Maybe a -> [Text] -> m a -isJustOrFail' c a ts = a `isJustOr` cmdExn c ts - --- | Create an exception about a command failing. -cmdExn :: Const -> [Text] -> Exn -cmdExn c parts = CmdFailed c (T.unwords parts) Nothing - --- * Some utility functions - -getNow :: Has (Lift IO) sig m => m TimeSpec -getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic - --- | Set a flag telling the UI that the world needs to be redrawn. -flagRedraw :: (Has (State GameState) sig m) => m () -flagRedraw = needsRedraw .= True - --- * World queries - -getNeighborLocs :: Cosmic Location -> [Cosmic Location] -getNeighborLocs loc = map (offsetBy loc . flip applyTurn north . DRelative . DPlanar) listEnums - --- | Perform an action requiring a 'W.World' state component in a --- larger context with a 'GameState'. -zoomWorld :: - (Has (State GameState) sig m) => - SubworldName -> - StateC (W.World Int Entity) Identity b -> - m (Maybe b) -zoomWorld swName n = do - mw <- use $ landscape . multiWorld - forM (M.lookup swName mw) $ \w -> do - let (w', a) = run (runState w n) - landscape . multiWorld %= M.insert swName w' - return a - --- | Get the entity (if any) at a given location. -entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity) -entityAt (Cosmic subworldName loc) = - join <$> zoomWorld subworldName (W.lookupEntityM @Int (W.locToCoords loc)) - --- | Get the robot with a given ID. -robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot) -robotWithID rid = use (robotMap . at rid) - --- | Get the robot with a given name. -robotWithName :: (Has (State GameState) sig m) => Text -> m (Maybe Robot) -robotWithName rname = use (robotMap . to IM.elems . to (find $ \r -> r ^. robotName == rname)) - --- * Randomness - --- | Generate a uniformly random number using the random generator in --- the game state. -uniform :: (Has (State GameState) sig m, UniformRange a) => (a, a) -> m a -uniform bnds = do - rand <- use randGen - let (n, g) = uniformR bnds rand - randGen .= g - return n - --- | Given a weighting function and a list of values, choose one of --- the values randomly (using the random generator in the game --- state), with the probability of each being proportional to its --- weight. Return @Nothing@ if the list is empty. -weightedChoice :: Has (State GameState) sig m => (a -> Integer) -> [a] -> m (Maybe a) -weightedChoice weight as = do - r <- uniform (0, total - 1) - return $ go r as - where - total = sum (map weight as) - - go _ [] = Nothing - go !k (x : xs) - | k < w = Just x - | otherwise = go (k - w) xs - where - w = weight x - --- | Generate a random robot name in the form @adjective_name@. -randomName :: Has (State GameState) sig m => m Text -randomName = do - NameGenerator adjs names <- use $ robotNaming . nameGenerator - i <- uniform (bounds adjs) - j <- uniform (bounds names) - return $ T.concat [adjs ! i, "_", names ! j] - --- * Moving - -data MoveFailureMode = PathBlocked | PathLiquid -data MoveFailureDetails = MoveFailureDetails Entity MoveFailureMode - --- | Make sure nothing is in the way. --- No exception for system robots -checkMoveFailureUnprivileged :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureDetails) -checkMoveFailureUnprivileged nextLoc = do - me <- entityAt nextLoc - caps <- use robotCapabilities - unwalkables <- use unwalkableEntities - return $ do - e <- me - go caps unwalkables e - where - go caps unwalkables e - -- robots can not walk through walls - | e `hasProperty` Unwalkable || (e ^. entityName) `S.member` unwalkables = Just $ MoveFailureDetails e PathBlocked - -- robots drown if they walk over liquid without boat - | e `hasProperty` Liquid && CFloat `S.notMember` caps = - Just $ MoveFailureDetails e PathLiquid - | otherwise = Nothing - --- | Make sure nothing is in the way. Note that system robots implicitly ignore --- and base throws on failure. -checkMoveFailure :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureDetails) -checkMoveFailure nextLoc = do - systemRob <- use systemRobot - runMaybeT $ do - guard $ not systemRob - maybeMoveFailure <- lift $ checkMoveFailureUnprivileged nextLoc - hoistMaybe maybeMoveFailure diff --git a/src/Swarm/Game/Terrain.hs b/src/Swarm/Game/Terrain.hs deleted file mode 100644 --- a/src/Swarm/Game/Terrain.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Terrain types and properties. -module Swarm.Game.Terrain ( - -- * Terrain - TerrainType (..), - readTerrain, - terrainMap, - getTerrainDefaultPaletteChar, - getTerrainWord, -) where - -import Data.Aeson (FromJSON (..), withText) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M -import Data.Text qualified as T -import Swarm.Game.Display -import Swarm.Util (failT, showEnum) -import Text.Read (readMaybe) -import Witch (into) - --- | The different possible types of terrain. Unlike entities and --- robots, these are hard-coded into the game. -data TerrainType - = StoneT - | DirtT - | GrassT - | IceT - | BlankT - deriving (Eq, Ord, Show, Read, Bounded, Enum) - -readTerrain :: T.Text -> Maybe TerrainType -readTerrain t = readMaybe (into @String (T.toTitle t) ++ "T") - -instance Semigroup TerrainType where - t <> BlankT = t - _ <> t = t - -instance Monoid TerrainType where - mempty = BlankT - -instance FromJSON TerrainType where - parseJSON = withText "text" $ \t -> - case readTerrain t of - Just ter -> return ter - Nothing -> failT ["Unknown terrain type:", t] - -getTerrainDefaultPaletteChar :: TerrainType -> Char -getTerrainDefaultPaletteChar = NE.head . showEnum - -getTerrainWord :: TerrainType -> T.Text -getTerrainWord = T.toLower . T.pack . init . show - --- | A map containing a 'Display' record for each different 'TerrainType'. -terrainMap :: Map TerrainType Display -terrainMap = - M.fromList - [ (StoneT, defaultTerrainDisplay '▒' (ATerrain "stone")) - , (DirtT, defaultTerrainDisplay '▒' (ATerrain "dirt")) - , (GrassT, defaultTerrainDisplay '▒' (ATerrain "grass")) - , (IceT, defaultTerrainDisplay ' ' (ATerrain "ice")) - , (BlankT, defaultTerrainDisplay ' ' ADefault) - ] diff --git a/src/Swarm/Game/Universe.hs b/src/Swarm/Game/Universe.hs deleted file mode 100644 --- a/src/Swarm/Game/Universe.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Types and utilities for working with "universal locations"; --- locations that encompass different 2-D subworlds. -module Swarm.Game.Universe where - -import Control.Lens (makeLenses, view) -import Data.Function (on) -import Data.Int (Int32) -import Data.Text (Text) -import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, withText, (.:)) -import GHC.Generics (Generic) -import Linear (V2 (..)) -import Swarm.Game.Location - --- * Referring to subworlds - -data SubworldName = DefaultRootSubworld | SubworldName Text - deriving (Show, Eq, Ord, Generic, ToJSON) - -instance FromJSON SubworldName where - parseJSON = withText "subworld name" $ return . SubworldName - -renderWorldName :: SubworldName -> Text -renderWorldName = \case - SubworldName s -> s - DefaultRootSubworld -> "" - --- * Universal location - --- | The swarm universe consists of locations --- indexed by subworld. --- Not only is this parameterized datatype useful for planar (2D) --- coordinates, but is also used for named waypoints. -data Cosmic a = Cosmic - { _subworld :: SubworldName - , _planar :: a - } - deriving (Show, Eq, Ord, Functor, Generic, ToJSON) - -makeLenses ''Cosmic - -instance (FromJSON a) => FromJSON (Cosmic a) where - parseJSON x = case x of - Object v -> objParse v - _ -> Cosmic DefaultRootSubworld <$> parseJSON x - where - objParse v = - Cosmic - <$> v .: "subworld" - <*> v .: "loc" - --- * Measurement - -data DistanceMeasure b = Measurable b | InfinitelyFar - deriving (Eq, Ord) - -getFiniteDistance :: DistanceMeasure b -> Maybe b -getFiniteDistance = \case - Measurable x -> Just x - InfinitelyFar -> Nothing - --- | Returns 'InfinitelyFar' if not within the same subworld. -cosmoMeasure :: (a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b -cosmoMeasure f a b - | ((/=) `on` view subworld) a b = InfinitelyFar - | otherwise = Measurable $ (f `on` view planar) a b - --- * Utilities - -defaultCosmicLocation :: Cosmic Location -defaultCosmicLocation = Cosmic DefaultRootSubworld origin - -offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location -offsetBy loc v = fmap (.+^ v) loc diff --git a/src/Swarm/Game/Value.hs b/src/Swarm/Game/Value.hs deleted file mode 100644 --- a/src/Swarm/Game/Value.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Conversions from native Haskell values --- to values in the swarm language. -module Swarm.Game.Value where - -import Control.Lens (view) -import Data.Int (Int32) -import Linear (V2 (..)) -import Swarm.Game.Entity -import Swarm.Game.Location -import Swarm.Game.Robot -import Swarm.Language.Direction -import Swarm.Language.Value - --- * Patterns - -type VRect = Value -pattern VRect :: Integer -> Integer -> Integer -> Integer -> VRect -pattern VRect x1 y1 x2 y2 = VPair (VPair (VInt x1) (VInt y1)) (VPair (VInt x2) (VInt y2)) - --- * Conversions - --- | Conversion from native Haskell types --- to their swarm-lang equivalents, useful for --- implementing swarm --- --- in Haskell. -class Valuable a where - asValue :: a -> Value - -instance Valuable Int32 where - asValue = VInt . fromIntegral - -instance Valuable Int where - asValue = VInt . fromIntegral - -instance (Valuable a) => Valuable (V2 a) where - asValue (V2 x y) = asValue (x, y) - -instance (Valuable a, Valuable b) => Valuable (a, b) where - asValue (x, y) = VPair (asValue x) (asValue y) - -instance Valuable Location where - asValue (Location x y) = asValue (x, y) - -instance Valuable Entity where - asValue = VText . view entityName - -instance Valuable Robot where - asValue = VRobot . view robotID - -instance Valuable Direction where - asValue = VDir - -instance (Valuable a) => Valuable (Maybe a) where - asValue Nothing = VInj False VUnit - asValue (Just x) = VInj True $ asValue x - -instance (Valuable a, Valuable b) => Valuable (Either a b) where - asValue (Left x) = VInj False $ asValue x - asValue (Right x) = VInj True $ asValue x diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs deleted file mode 100644 --- a/src/Swarm/Game/World.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A /world/ refers to the grid on which the game takes place, and the --- things in it (besides robots). A world has a base, immutable --- /terrain/ layer, where each cell contains a terrain type, and a --- mutable /entity/ layer, with at most one entity per cell. --- --- A world is technically finite but practically infinite (worlds are --- indexed by 32-bit signed integers, so they correspond to a --- \( 2^{32} \times 2^{32} \) torus). -module Swarm.Game.World ( - -- * World coordinates - Coords (..), - locToCoords, - coordsToLoc, - BoundsRectangle, - - -- * Worlds - WorldFun (..), - runWF, - worldFunFromArray, - World, - MultiWorld, - - -- ** Tile management - loadCell, - loadRegion, - - -- ** World functions - newWorld, - lookupCosmicTerrain, - lookupTerrain, - lookupCosmicEntity, - lookupEntity, - update, - - -- ** Monadic variants - lookupTerrainM, - lookupEntityM, - updateM, - - -- ** Runtime updates - WorldUpdate (..), -) where - -import Control.Algebra (Has) -import Control.Arrow ((&&&)) -import Control.Effect.State (State, get, modify, state) -import Control.Lens -import Data.Array qualified as A -import Data.Array.IArray -import Data.Array.Unboxed qualified as U -import Data.Bifunctor (second) -import Data.Bits -import Data.Foldable (foldl') -import Data.Int (Int32) -import Data.Map (Map) -import Data.Map.Strict qualified as M -import Data.Semigroup (Last (..)) -import Data.Yaml (FromJSON, ToJSON) -import GHC.Generics (Generic) -import Swarm.Game.Entity (Entity) -import Swarm.Game.Location -import Swarm.Game.Terrain (TerrainType (BlankT)) -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) - ------------------------------------------------------------- --- World function ------------------------------------------------------------- - --- | A @WorldFun t e@ represents a 2D world with terrain of type @t@ --- (exactly one per cell) and entities of type @e@ (at most one per --- cell). -newtype WorldFun t e = WF {getWF :: Coords -> (t, Erasable (Last e))} - deriving stock (Functor) - deriving newtype (Semigroup, Monoid) - -runWF :: WorldFun t e -> Coords -> (t, Maybe e) -runWF wf = second (erasableToMaybe . fmap getLast) . getWF wf - -instance Bifunctor WorldFun where - bimap g h (WF z) = WF (bimap g (fmap (fmap h)) . z) - --- | Create a world function from a finite array of specified cells. -worldFunFromArray :: Monoid t => Array (Int32, Int32) (t, Erasable e) -> WorldFun t e -worldFunFromArray arr = WF $ \(Coords (r, c)) -> - if inRange bnds (r, c) - then second (fmap Last) (arr ! (r, c)) - else mempty - where - bnds = bounds arr - ------------------------------------------------------------- --- Tiles and coordinates ------------------------------------------------------------- - --- | The number of bits we need in each coordinate to represent all --- the locations in a tile. In other words, each tile has a size of --- @2^tileBits x 2^tileBits@. --- --- Currently, 'tileBits' is set to 6, giving us 64x64 tiles, with --- 4096 cells in each tile. That seems intuitively like a good size, --- but I don't have a good sense for the tradeoffs here, and I don't --- know how much the choice of tile size matters. -tileBits :: Int -tileBits = 6 - --- | The number consisting of 'tileBits' many 1 bits. We can use this --- to mask out the tile offset of a coordinate. -tileMask :: Int32 -tileMask = (1 `shiftL` tileBits) - 1 - --- | If we think of the world as a grid of /tiles/, we can assign each --- tile some coordinates in the same way we would if each tile was a --- single cell. These are the tile coordinates. -newtype TileCoords = TileCoords {unTileCoords :: Coords} - deriving (Eq, Ord, Show, Ix, Generic) - -instance Rewrapped TileCoords t -instance Wrapped TileCoords - --- | Convert from a cell's coordinates to the coordinates of its tile, --- simply by shifting out 'tileBits' many bits. -tileCoords :: Coords -> TileCoords -tileCoords = TileCoords . over (_Wrapped . both) (`shiftR` tileBits) - --- | Find the coordinates of the upper-left corner of a tile. -tileOrigin :: TileCoords -> Coords -tileOrigin = over (_Wrapped . both) (`shiftL` tileBits) . unTileCoords - --- | A 'TileOffset' represents an offset from the upper-left corner of --- some tile to a cell in its interior. -newtype TileOffset = TileOffset Coords - deriving (Eq, Ord, Show, Ix, Generic) - --- | The offsets of the upper-left and lower-right corners of a tile: --- (0,0) to ('tileMask', 'tileMask'). -tileBounds :: (TileOffset, TileOffset) -tileBounds = (TileOffset (Coords (0, 0)), TileOffset (Coords (tileMask, tileMask))) - --- | Compute the offset of a given coordinate within its tile. -tileOffset :: Coords -> TileOffset -tileOffset = TileOffset . over (_Wrapped . both) (.&. tileMask) - --- | Add a tile offset to the coordinates of the tile's upper left --- corner. NOTE that for efficiency, this function only works when --- the first argument is in fact the coordinates of a tile's --- upper-left corner (/i.e./ it is an output of 'tileOrigin'). In --- that case the coordinates will end with all 0 bits, and we can --- add the tile offset just by doing a coordinatewise 'xor'. -plusOffset :: Coords -> TileOffset -> Coords -plusOffset (Coords (x1, y1)) (TileOffset (Coords (x2, y2))) = Coords (x1 `xor` x2, y1 `xor` y2) - -instance Rewrapped TileOffset t -instance Wrapped TileOffset - --- | A terrain tile is an unboxed array of terrain values. -type TerrainTile t = U.UArray TileOffset t - --- | An entity tile is an array of possible entity values. Note it --- cannot be an unboxed array since entities are complex records --- which have to be boxed. -type EntityTile e = A.Array TileOffset (Maybe e) - -type MultiWorld t e = Map SubworldName (World t e) - --- | A 'World' consists of a 'WorldFun' that specifies the initial --- world, a cache of loaded square tiles to make lookups faster, and --- a map storing locations whose entities have changed from their --- initial values. --- --- Right now the 'World' simply holds on to all the tiles it has --- ever loaded. Ideally it would use some kind of LRU caching --- scheme to keep memory usage bounded, but it would be a bit --- tricky, and in any case it's probably not going to matter much --- for a while. Once tile loads can trigger robots to spawn, it --- would also make for some difficult decisions in terms of how to --- handle respawning. -data World t e = World - { _worldFun :: WorldFun t e - , _tileCache :: M.Map TileCoords (TerrainTile t, EntityTile e) - , _changed :: M.Map Coords (Maybe e) - } - --- | Create a new 'World' from a 'WorldFun'. -newWorld :: WorldFun t e -> World t e -newWorld f = World f M.empty M.empty - -lookupCosmicTerrain :: - IArray U.UArray Int => - Cosmic Coords -> - MultiWorld Int e -> - TerrainType -lookupCosmicTerrain (Cosmic subworldName i) multiWorld = - maybe BlankT (toEnum . lookupTerrain i) $ M.lookup subworldName multiWorld - --- | Look up the terrain value at certain coordinates: try looking it --- up in the tile cache first, and fall back to running the 'WorldFun' --- otherwise. --- --- This function does /not/ ensure that the tile containing the --- given coordinates is loaded. For that, see 'lookupTerrainM'. -lookupTerrain :: (IArray U.UArray t) => Coords -> World t e -> t -lookupTerrain i (World f t _) = - ((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t) - ? fst (runWF f i) - --- | A stateful variant of 'lookupTerrain', which first loads the tile --- containing the given coordinates if it is not already loaded, --- then looks up the terrain value. -lookupTerrainM :: - forall t e sig m. - (Has (State (World t e)) sig m, IArray U.UArray t) => - Coords -> - m t -lookupTerrainM c = do - modify @(World t e) $ loadCell c - lookupTerrain c <$> get @(World t e) - -lookupCosmicEntity :: Cosmic Coords -> MultiWorld t e -> Maybe e -lookupCosmicEntity (Cosmic subworldName i) multiWorld = - lookupEntity i =<< M.lookup subworldName multiWorld - --- | Look up the entity at certain coordinates: first, see if it is in --- the map of locations with changed entities; then try looking it --- up in the tile cache first; and finally fall back to running the --- 'WorldFun'. --- --- This function does /not/ ensure that the tile containing the --- given coordinates is loaded. For that, see 'lookupEntityM'. -lookupEntity :: Coords -> World t e -> Maybe e -lookupEntity i (World f t m) = - M.lookup i m - ? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t) - ? snd (runWF f i) - --- | A stateful variant of 'lookupEntity', which first loads the tile --- containing the given coordinates if it is not already loaded, --- then looks up the terrain value. -lookupEntityM :: - forall t e sig m. - (Has (State (World t e)) sig m, IArray U.UArray t) => - Coords -> - m (Maybe e) -lookupEntityM c = do - modify @(World t e) $ loadCell c - lookupEntity c <$> get @(World t e) - --- | Update the entity (or absence thereof) at a certain location, --- returning an updated 'World' and a Boolean indicating whether --- the update changed the entity here. --- See also 'updateM'. -update :: - Coords -> - (Maybe Entity -> Maybe Entity) -> - World t Entity -> - (World t Entity, CellUpdate Entity) -update i g w@(World f t m) = - (wNew, classifyModification entityBefore entityAfter) - where - wNew = World f t $ M.insert i entityAfter m - entityBefore = lookupEntity i w - entityAfter = g entityBefore - --- | A stateful variant of 'update', which also ensures the tile --- containing the given coordinates is loaded. -updateM :: - forall t sig m. - (Has (State (World t Entity)) sig m, IArray U.UArray t) => - Coords -> - (Maybe Entity -> Maybe Entity) -> - m (CellUpdate Entity) -updateM c g = do - state @(World t Entity) $ update c g . loadCell c - --- | Load the tile containing a specific cell. -loadCell :: (IArray U.UArray t) => Coords -> World t e -> World t e -loadCell c = loadRegion (c, c) - --- | Load all the tiles which overlap the given rectangular region --- (specified as an upper-left and lower-right corner, inclusive). -loadRegion :: - forall t e. - (IArray U.UArray t) => - (Coords, Coords) -> - World t e -> - World t e -loadRegion reg (World f t m) = World f t' m - where - tiles = range (over both tileCoords reg) - t' = foldl' (\hm (i, tile) -> maybeInsert i tile hm) t (map (id &&& loadTile) tiles) - - maybeInsert k v tm - | k `M.member` tm = tm - | otherwise = M.insert k v tm - - loadTile :: TileCoords -> (TerrainTile t, EntityTile e) - loadTile tc = (listArray tileBounds terrain, listArray tileBounds entities) - where - tileCorner = tileOrigin tc - (terrain, entities) = unzip $ map (runWF f . plusOffset tileCorner) (range tileBounds) - ---------------------------------------------------------------------- --- Runtime world update ---------------------------------------------------------------------- - --- | Enumeration of world updates. This type is used for changes by --- /e.g./ the @drill@ command which must be carried out at a later --- tick. Using a first-order representation (as opposed to /e.g./ --- just a @World -> World@ function) allows us to serialize and --- inspect the updates. -data WorldUpdate e = ReplaceEntity - { updatedLoc :: Cosmic Location - , originalEntity :: e - , newEntity :: Maybe e - } - deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) diff --git a/src/Swarm/Game/World/Abstract.hs b/src/Swarm/Game/World/Abstract.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Abstract.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Explicitly type-preserving bracket abstraction, a la Oleg Kiselyov. --- Turn elaborated, type-indexed terms into variableless, type-indexed --- terms with only constants and application. --- --- For more information, see: --- --- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ -module Swarm.Game.World.Abstract where - -import Data.Kind (Type) -import Swarm.Game.World.Typecheck (Applicable (..), Const (..), HasConst (..), Idx (..), TTerm (..), ($$.), (.$$), (.$$.)) - ------------------------------------------------------------- --- Bracket abstraction ------------------------------------------------------------- - --------------------------------------------------- --- Closed terms - --- | Closed, fully abstracted terms. All computation is represented --- by combinators. This is the ultimate target for the bracket --- abstraction operation. -data BTerm :: Type -> Type where - BApp :: BTerm (a -> b) -> BTerm a -> BTerm b - BConst :: Const a -> BTerm a - -deriving instance Show (BTerm t) - -instance Applicable BTerm where - ($$) = BApp - -instance HasConst BTerm where - embed = BConst - --------------------------------------------------- --- Open terms - --- | These explicitly open terms are an intermediate stage in the --- bracket abstraction algorithm, /i.e./ they represent terms which have --- been only partially abstracted. -data OTerm :: [Type] -> Type -> Type where - -- Embedded closed term. - E :: BTerm a -> OTerm g a - -- Reference to the innermost/top environment variable, i.e. Z - V :: OTerm (a ': g) a - -- Internalize the topmost env variable as a function argument - N :: OTerm g (a -> b) -> OTerm (a ': g) b - -- Ignore the topmost env variable - W :: OTerm g b -> OTerm (a ': g) b - -instance HasConst (OTerm g) where - embed = E . embed - --- | Bracket abstraction: convert the 'TTerm' to an 'OTerm', then --- project out the embedded 'BTerm'. GHC can see this is total --- since 'E' is the only constructor that can produce an 'OTerm' --- with an empty environment. -bracket :: TTerm '[] a -> BTerm a -bracket t = case conv t of - E t' -> t' - --- | Type-preserving conversion from 'TTerm' to 'OTerm' ('conv' + the --- 'Applicable' instance). Taken directly from Kiselyov. -conv :: TTerm g a -> OTerm g a -conv (TVar VZ) = V -conv (TVar (VS x)) = W (conv (TVar x)) -conv (TLam t) = case conv t of - V -> E (BConst I) - E d -> E (K .$$ d) - N e -> e - W e -> K .$$ e -conv (TApp t1 t2) = conv t1 $$ conv t2 -conv (TConst c) = embed c - -instance Applicable (OTerm g) where - ($$) :: OTerm g (a -> b) -> OTerm g a -> OTerm g b - W e1 $$ W e2 = W (e1 $$ e2) - W e $$ E d = W (e $$ E d) - E d $$ W e = W (E d $$ e) - W e $$ V = N e - V $$ W e = N (E (C .$$. I) $$ e) - W e1 $$ N e2 = N (B .$$ e1 $$ e2) - N e1 $$ W e2 = N (C .$$ e1 $$ e2) - N e1 $$ N e2 = N (S .$$ e1 $$ e2) - N e $$ V = N (S .$$ e $$. I) - V $$ N e = N (E (S .$$. I) $$ e) - E d $$ N e = N (E (B .$$ d) $$ e) - E d $$ V = N (E d) - V $$ E d = N (E (C .$$. I $$ d)) - N e $$ E d = N (E (C .$$. C $$ d) $$ e) - E d1 $$ E d2 = E (d1 $$ d2) - --- There are only 15 cases above: GHC can tell that V $$ V is --- impossible (it would be ill-typed)! diff --git a/src/Swarm/Game/World/Compile.hs b/src/Swarm/Game/World/Compile.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Compile.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Compiling abstracted combinator expressions ('BTerm') to native --- Haskell terms. This can supposedly be more efficient than directly --- interpreting 'BTerm's, but some benchmarking is probably needed to --- decide whether we want this or not. --- --- For more info, see: --- --- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ -module Swarm.Game.World.Compile where - -import Data.ByteString (ByteString) -import Data.Hash.Murmur (murmur3) -import Data.Kind (Constraint) -import Data.Tagged (Tagged (unTagged)) -import Numeric.Noise.Perlin (noiseValue, perlin) -import Swarm.Game.Location (pattern Location) -import Swarm.Game.World.Abstract (BTerm (..)) -import Swarm.Game.World.Coords (Coords (..), coordsToLoc) -import Swarm.Game.World.Gen (Seed) -import Swarm.Game.World.Interpret (interpReflect, interpRot) -import Swarm.Game.World.Syntax (Axis (..), Rot, World) -import Swarm.Game.World.Typecheck (Applicable (..), Const (..), Empty (..), NotFun, Over (..)) -import Witch (from) -import Witch.Encoding qualified as Encoding - -data CTerm a where - CFun :: (CTerm a -> CTerm b) -> CTerm (a -> b) - CConst :: (NotFun a) => a -> CTerm a - -instance Applicable CTerm where - CFun f $$ x = f x - -compile :: Seed -> BTerm a -> CTerm a -compile seed (BApp b1 b2) = compile seed b1 $$ compile seed b2 -compile seed (BConst c) = compileConst seed c - -compileConst :: Seed -> Const a -> CTerm a -compileConst seed = \case - CLit i -> CConst i - CCell c -> CConst c - CFI -> unary fromIntegral - CIf -> CFun $ \(CConst b) -> CFun $ \t -> CFun $ \e -> if b then t else e - CNot -> unary not - CNeg -> unary negate - CAbs -> unary abs - CAnd -> binary (&&) - COr -> binary (||) - CAdd -> binary (+) - CSub -> binary (-) - CMul -> binary (*) - CDiv -> binary (/) - CIDiv -> binary div - CMod -> binary mod - CEq -> binary (==) - CNeq -> binary (/=) - CLt -> binary (<) - CLeq -> binary (<=) - CGt -> binary (>) - CGeq -> binary (>=) - CMask -> compileMask - CSeed -> CConst (fromIntegral seed) - CCoord ax -> CFun $ \(CConst (coordsToLoc -> Location x y)) -> CConst (fromIntegral (case ax of X -> x; Y -> y)) - CHash -> compileHash - CPerlin -> compilePerlin - CReflect ax -> compileReflect ax - CRot rot -> compileRot rot - COver -> binary () - K -> CFun $ \x -> CFun $ const x - S -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ x $$ (g $$ x) - I -> CFun id - B -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ (g $$ x) - C -> CFun $ \f -> CFun $ \x -> CFun $ \y -> f $$ y $$ x - Φ -> CFun $ \c -> CFun $ \f -> CFun $ \g -> CFun $ \x -> c $$ (f $$ x) $$ (g $$ x) - -unary :: (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b) -unary op = CFun $ \(CConst x) -> CConst (op x) - -binary :: (NotFun a, NotFun b, NotFun c) => (a -> b -> c) -> CTerm (a -> b -> c) -binary op = CFun $ \(CConst x) -> CFun $ \(CConst y) -> CConst (op x y) - --- Note we could desugar 'mask p a -> if p a empty' but that would --- require an explicit 'empty' node, whose type can't be inferred. -compileMask :: (NotFun a, Empty a) => CTerm (World Bool -> World a -> World a) -compileMask = CFun $ \p -> CFun $ \a -> CFun $ \ix -> - case p $$ ix of - CConst b -> if b then a $$ ix else CConst empty - -compileHash :: CTerm (Coords -> Integer) -compileHash = CFun $ \(CConst (Coords ix)) -> CConst (fromIntegral (h ix)) - where - h = murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show - -compilePerlin :: CTerm (Integer -> Integer -> Double -> Double -> World Double) -compilePerlin = - CFun $ \(CConst s) -> - CFun $ \(CConst o) -> - CFun $ \(CConst k) -> - CFun $ \(CConst p) -> - let noise = perlin (fromIntegral s) (fromIntegral o) k p - in CFun $ \(CConst (Coords ix)) -> CConst (sample ix noise) - where - sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0) - -compileReflect :: Axis -> CTerm (World a -> World a) -compileReflect ax = CFun $ \w -> CFun $ \(CConst c) -> w $$ CConst (interpReflect ax c) - -compileRot :: Rot -> CTerm (World a -> World a) -compileRot rot = CFun $ \w -> CFun $ \(CConst c) -> w $$ CConst (interpRot rot c) - -type family NoFunParams a :: Constraint where - NoFunParams (a -> b) = (NotFun a, NoFunParams b) - NoFunParams _ = () - --- | Interpret a compiled term into the host language. -runCTerm :: (NoFunParams a) => CTerm a -> a -runCTerm (CConst a) = a -runCTerm (CFun f) = runCTerm . f . CConst diff --git a/src/Swarm/Game/World/Coords.hs b/src/Swarm/Game/World/Coords.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Coords.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- World coordinates. -module Swarm.Game.World.Coords ( - Coords (..), - locToCoords, - coordsToLoc, - BoundsRectangle, -) -where - -import Control.Lens (Rewrapped, Wrapped) -import Data.Array.IArray (Ix) -import Data.Int (Int32) -import GHC.Generics (Generic) -import Swarm.Game.Location (Location, pattern Location) - ------------------------------------------------------------- --- World coordinates ------------------------------------------------------------- - --- | World coordinates use @(row,column)@ format, with the row --- increasing as we move down the screen. We use this format for --- indexing worlds internally, since it plays nicely with things --- like drawing the screen, and reading maps from configuration --- files. The 'locToCoords' and 'coordsToLoc' functions convert back --- and forth between this type and t'Location', which is used when --- presenting coordinates externally to the player. -newtype Coords = Coords {unCoords :: (Int32, Int32)} - deriving (Eq, Ord, Show, Ix, Generic) - -instance Rewrapped Coords t -instance Wrapped Coords - --- | Convert an external @(x,y)@ location to an internal 'Coords' value. -locToCoords :: Location -> Coords -locToCoords (Location x y) = Coords (-y, x) - --- | Convert an internal 'Coords' value to an external @(x,y)@ location. -coordsToLoc :: Coords -> Location -coordsToLoc (Coords (r, c)) = Location c (-r) - --- | Represents the top-left and bottom-right coordinates --- of a bounding rectangle of cells in the world map -type BoundsRectangle = (Coords, Coords) diff --git a/src/Swarm/Game/World/Eval.hs b/src/Swarm/Game/World/Eval.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Eval.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Evaluation for the Swarm world description DSL. -module Swarm.Game.World.Eval ( - runWorld, -) where - -import Swarm.Game.Entity (Entity) -import Swarm.Game.Terrain (TerrainType (..)) -import Swarm.Game.World (WorldFun (..)) -import Swarm.Game.World.Abstract (bracket) -import Swarm.Game.World.Coords (Coords) -import Swarm.Game.World.Gen (Seed) -import Swarm.Game.World.Interpret (interpBTerm) -import Swarm.Game.World.Syntax -import Swarm.Game.World.Typecheck - --- | Run a typechecked world description DSL term to produce a --- 'WorldFun'. -runWorld :: TTerm '[] (World CellVal) -> Seed -> WorldFun TerrainType Entity -runWorld t seed = convertWF . interpBTerm seed . bracket $ t - --- Currently we run a DSL term by performing bracket abstraction, --- producing a 'BTerm', then directly interpreting the 'BTerm' with --- 'interpBTerm'. We could also compile the 'BTerm' to a 'CTerm' and --- run it, i.e. --- --- convertWF . runCTerm . compile seed . bracket $ t --- --- which can supposedly give a performance boost, but it is unclear --- whether this actually makes a difference in our case. - --- | Simple adapter function to convert a plain @Coords -> CellVal@ --- function into a 'WorldFun' value. -convertWF :: (Coords -> CellVal) -> WorldFun TerrainType Entity -convertWF f = WF ((\(CellVal t e _) -> (t, e)) . f) diff --git a/src/Swarm/Game/World/Gen.hs b/src/Swarm/Game/World/Gen.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Gen.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- 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.Set qualified as S -import Data.Text (Text) -import Swarm.Game.Entity -import Swarm.Game.World -import Swarm.Game.World.Syntax (CellVal (..)) -import Swarm.Game.World.Typecheck (Const (CCell), TTerm (..)) -import Swarm.Util.Erasable - -type Seed = Int - --- | Extract a list of all entities mentioned in a given world DSL term. -extractEntities :: TTerm g a -> S.Set Entity -extractEntities (TLam t) = extractEntities t -extractEntities (TApp t1 t2) = extractEntities t1 <> extractEntities t2 -extractEntities (TConst (CCell (CellVal _ ee _))) = getEntity ee - where - 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/Game/World/Interpret.hs b/src/Swarm/Game/World/Interpret.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Interpret.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE GADTs #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Interpreter for the Swarm world description DSL. -module Swarm.Game.World.Interpret ( - interpBTerm, - interpConst, - interpReflect, - interpRot, -) where - -import Control.Applicative (Applicative (..)) -import Data.ByteString (ByteString) -import Data.Hash.Murmur (murmur3) -import Data.Tagged (unTagged) -import Numeric.Noise.Perlin (noiseValue, perlin) -import Swarm.Game.World.Abstract (BTerm (..)) -import Swarm.Game.World.Coords (Coords (..)) -import Swarm.Game.World.Gen (Seed) -import Swarm.Game.World.Syntax (Axis (..), Rot (..)) -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 -interpBTerm seed (BApp f x) = interpBTerm seed f (interpBTerm seed x) -interpBTerm seed (BConst c) = interpConst seed c - --- | Interpret a constant into the host language. -interpConst :: Seed -> Const a -> a -interpConst seed = \case - CLit a -> a - CCell c -> c - CIf -> \b t e -> if b then t else e - CNot -> not - CNeg -> negate - CAbs -> abs - CAnd -> (&&) - COr -> (||) - CAdd -> (+) - CSub -> (-) - CMul -> (*) - CDiv -> (/) - CIDiv -> div - CMod -> mod - CEq -> (==) - CNeq -> (/=) - CLt -> (<) - CLeq -> (<=) - CGt -> (>) - CGeq -> (>=) - CMask -> \b x c -> if b c then x c else empty - CSeed -> fromIntegral seed - CCoord ax -> \(Coords (x, y)) -> fromIntegral (case ax of X -> x; Y -> y) - CHash -> \(Coords ix) -> fromIntegral . murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ ix - CPerlin -> \s o k p -> - let noise = perlin (fromIntegral s) (fromIntegral o) k p - sample (i, j) = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0) - in \(Coords ix) -> sample ix - CReflect ax -> \w -> w . interpReflect ax - CRot r -> \w -> w . interpRot r - CFI -> fromInteger - COver -> () - K -> const - S -> (<*>) - I -> id - B -> (.) - C -> flip - Φ -> liftA2 - --- | Interprect a reflection. -interpReflect :: Axis -> Coords -> Coords -interpReflect ax (Coords (r, c)) = Coords (case ax of X -> (r, -c); Y -> (-r, c)) - --- | Interpret a rotation. -interpRot :: Rot -> Coords -> Coords -interpRot rot (Coords crd) = Coords (rotTuple rot crd) - where - rotTuple = \case - Rot0 -> id - Rot90 -> \(r, c) -> (-c, r) - Rot180 -> \(r, c) -> (-r, -c) - Rot270 -> \(r, c) -> (c, -r) diff --git a/src/Swarm/Game/World/Load.hs b/src/Swarm/Game/World/Load.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Load.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Loading world descriptions from `worlds/*.world`. -module Swarm.Game.World.Load where - -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.Entity (EntityMap) -import Swarm.Game.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..)) -import Swarm.Game.ResourceLoading (getDataDirSafe) -import Swarm.Game.World.Parse (parseWExp, runParser) -import Swarm.Game.World.Typecheck -import Swarm.Language.Pretty (prettyText) -import Swarm.Util (acquireAllWithExt) -import Swarm.Util.Effect (throwToWarning, 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. -loadWorlds :: - (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => - EntityMap -> - m WorldMap -loadWorlds em = 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 em) worldFiles - return . M.fromList . catMaybes $ ws - --- | Load a file containing a world DSL term, throwing an exception if --- it fails to parse or typecheck. -loadWorld :: - (Has (Throw SystemFailure) sig m) => - FilePath -> - EntityMap -> - (FilePath, String) -> - m (Text, Some (TTerm '[])) -loadWorld dir em (fp, src) = do - wexp <- - liftEither . left (AssetNotLoaded (Data Worlds) fp . CanNotParseMegaparsec) $ - runParser parseWExp (into @Text src) - t <- - withThrow (AssetNotLoaded (Data Worlds) fp . DoesNotTypecheck . prettyText @CheckErr) $ - runReader em . runReader @WorldMap M.empty $ - infer CNil wexp - return (into @Text (dropExtension (stripDir dir fp)), t) - --- | Strip a leading directory from a 'FilePath'. -stripDir :: FilePath -> FilePath -> FilePath -stripDir dir fp = joinPath (drop (length (splitPath dir)) (splitPath fp)) diff --git a/src/Swarm/Game/World/Modify.hs b/src/Swarm/Game/World/Modify.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Modify.hs +++ /dev/null @@ -1,40 +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. - 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/Game/World/Parse.hs b/src/Swarm/Game/World/Parse.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Parse.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} --- FromJSON WExp -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Parser for the Swarm world description DSL. -module Swarm.Game.World.Parse where - -import Control.Monad (void) -import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) -import Control.Monad.Combinators.NonEmpty qualified as CNE (sepBy1) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Void (Void) -import Data.Yaml (FromJSON (parseJSON), withText) -import Swarm.Game.World.Syntax -import Swarm.Util (failT, showT, squote) -import Swarm.Util.Parse (fully) -import Text.Megaparsec hiding (runParser) -import Text.Megaparsec.Char -import Text.Megaparsec.Char.Lexer qualified as L -import Witch (into) - -type Parser = Parsec Void Text -type ParserError = ParseErrorBundle Text Void - ------------------------------------------------------------- --- Lexing - -reservedWords :: [Text] -reservedWords = - [ "not" - , "true" - , "false" - , "seed" - , "x" - , "y" - , "hash" - , "let" - , "in" - , "overlay" - , "hcat" - , "vcat" - , "if" - , "then" - , "else" - , "perlin" - , "mask" - , "empty" - , "abs" - ] - --- | Skip spaces and comments. -sc :: Parser () -sc = - L.space - space1 - (L.skipLineComment "//") - (L.skipBlockComment "/*" "*/") - --- | In general, we follow the convention that every token parser --- assumes no leading whitespace and consumes all trailing --- whitespace. Concretely, we achieve this by wrapping every token --- parser using 'lexeme'. -lexeme :: Parser a -> Parser a -lexeme = L.lexeme sc - --- | A lexeme consisting of a literal string. -symbol :: Text -> Parser Text -symbol = L.symbol sc - -operatorChar :: Parser Char -operatorChar = oneOf ("!@#$%^&*=+-/<>" :: String) - -operator :: Text -> Parser Text -operator op = (lexeme . try) $ string op <* notFollowedBy operatorChar - --- | A positive integer literal token. -integerOrFloat :: Parser (Either Integer Double) -integerOrFloat = - label "numeric literal" $ - lexeme (Right <$> try L.float <|> Left <$> L.decimal) - --- | Parse a case-insensitive reserved word, making sure it is not a --- prefix of a longer variable name, and allowing the parser to --- backtrack if it fails. -reserved :: Text -> Parser () -reserved w = (lexeme . try) $ string' w *> notFollowedBy (alphaNumChar <|> char '_') - --- | Parse an identifier, i.e. any non-reserved string containing --- alphanumeric characters and underscores and not starting with a --- number. -identifier :: Parser Var -identifier = (lexeme . try) (p >>= check) "variable name" - where - p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'') - check (into @Text -> t) - | T.toLower t `elem` reservedWords = - failT ["reserved word", squote t, "cannot be used as variable name"] - | otherwise = return t - -brackets :: Parser a -> Parser a -brackets = between (symbol "[") (symbol "]") - -parens :: Parser a -> Parser a -parens = between (symbol "(") (symbol ")") - -braces :: Parser a -> Parser a -braces = between (symbol "{") (symbol "}") - -comma :: Parser () -comma = void $ symbol "," - ------------------------------------------------------------- --- Parser - ----------------------------------------------------------------------- --- NOTE: when updating the parser, be sure to update the BNF in --- data/worlds/README.md to match! ----------------------------------------------------------------------- - -parseWExpAtom :: Parser WExp -parseWExpAtom = - either WInt WFloat <$> integerOrFloat - <|> WBool <$> (True <$ reserved "true" <|> False <$ reserved "false") - <|> parseCell - <|> WVar <$> identifier - <|> WSeed <$ reserved "seed" - <|> WCoord <$> (X <$ reserved "x" <|> Y <$ reserved "y") - <|> WHash <$ reserved "hash" - <|> parseIf - <|> parsePerlin - <|> parseAbs - <|> parseLet - <|> parseOverlay - <|> parseMask - <|> parseImport - -- <|> parseCat - -- <|> parseStruct - <|> parens parseWExp - -parseWExp :: Parser WExp -parseWExp = - makeExprParser - parseWExpAtom - [ - [ Prefix (unary Not <$ reserved "not") - , Prefix (unary Neg <$ operator "-") - ] - , - [ InfixL (binary Mul <$ operator "*") - , InfixL (binary Div <$ operator "/") - , InfixL (binary Mod <$ operator "%") - ] - , - [ InfixL (binary Add <$ operator "+") - , InfixL (binary Sub <$ operator "-") - , InfixR (binary Overlay <$ operator "<>") - ] - , - [ InfixN (binary Eq <$ operator "==") - , InfixN (binary Neq <$ operator "/=") - , InfixN (binary Lt <$ operator "<") - , InfixN (binary Leq <$ operator "<=") - , InfixN (binary Gt <$ operator ">") - , InfixN (binary Geq <$ operator ">=") - ] - , [InfixR (binary And <$ operator "&&")] - , [InfixR (binary Or <$ operator "||")] - ] - where - unary op x = WOp op [x] - binary op x1 x2 = WOp op [x1, x2] - -parseCell :: Parser WExp -parseCell = - braces $ WCell <$> parseCellItem `sepBy1` comma - -parseCellItem :: Parser (Maybe CellTag, Text) -parseCellItem = - (,) - <$> optional (try (parseCellTag <* symbol ":")) - <*> parseName - -parseCellTag :: Parser CellTag -parseCellTag = choice (map mkCellTagParser [minBound .. maxBound :: CellTag]) - where - mkCellTagParser ct = ct <$ string' (T.drop 4 $ showT ct) - -parseName :: Parser Text -parseName = - into @Text - <$> manyTill anySingle (lookAhead (satisfy (\c -> c == ',' || c == '}' || c == ']'))) - -parseIf :: Parser WExp -parseIf = - (\i t e -> WOp If [i, t, e]) - <$> (reserved "if" *> parseWExp) - <*> (reserved "then" *> parseWExp) - <*> (reserved "else" *> parseWExp) - -parsePerlin :: Parser WExp -parsePerlin = - (\s o k p -> WOp Perlin [s, o, k, p]) - <$> (reserved "perlin" *> parseWExpAtom) - <*> parseWExpAtom - <*> parseWExpAtom - <*> parseWExpAtom - -parseAbs :: Parser WExp -parseAbs = - WOp Abs . (: []) <$> (reserved "abs" *> parseWExpAtom) - -parseLet :: Parser WExp -parseLet = - WLet - <$> ( reserved "let" - *> (((,) <$> identifier <*> (symbol "=" *> parseWExp)) `sepBy` comma) - ) - <*> (reserved "in" *> parseWExp) - -parseOverlay :: Parser WExp -parseOverlay = do - reserved "overlay" - brackets $ WOverlay <$> parseWExp `CNE.sepBy1` comma - -parseMask :: Parser WExp -parseMask = do - reserved "mask" - w1 <- parseWExpAtom - w2 <- parseWExpAtom - return $ WOp Mask [w1, w2] - -parseImport :: Parser WExp -parseImport = WImport . into @Text <$> between (symbol "\"") (symbol "\"") (some (satisfy (/= '"'))) - --- parseCat :: Parser WExp --- parseCat = --- WCat --- <$> (X <$ reserved "hcat" <|> Y <$ reserved "vcat") --- <*> brackets (parseWExp `sepBy` comma) - --- parseStruct :: Parser WExp --- parseStruct = reserved "struct" *> fail "struct not implemented" - ------------------------------------------------------------- --- Utility - -runParser :: Parser a -> Text -> Either ParserError a -runParser p = parse (fully sc p) "" - ------------------------------------------------------------- --- JSON instance - -instance FromJSON WExp where - parseJSON = withText "World DSL program" $ \t -> - case runParser parseWExp t of - Left err -> error (errorBundlePretty err) - Right wexp -> return wexp diff --git a/src/Swarm/Game/World/Render.hs b/src/Swarm/Game/World/Render.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Render.hs +++ /dev/null @@ -1,65 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- TUI-independent world rendering. -module Swarm.Game.World.Render where - -import Control.Effect.Lift (sendIO) -import Control.Lens (view) -import Data.List.NonEmpty qualified as NE -import Swarm.Doc.Gen (loadStandaloneScenario) -import Swarm.Game.Display (defaultChar) -import Swarm.Game.ResourceLoading (initNameGenerator, readAppData) -import Swarm.Game.Scenario (Scenario, area, scenarioWorlds, ul, worldName) -import Swarm.Game.Scenario.Status (emptyLaunchParams) -import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), getAreaDimensions, isEmpty, upperLeftToBottomRight) -import Swarm.Game.Scenario.Topography.Cell -import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade) -import Swarm.Game.State -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.TUI.Editor.Util (getContentAt, getMapRectangle) -import Swarm.Util.Effect (simpleErrorHandle) -import Swarm.Util.Erasable (erasableToMaybe) - -getDisplayChar :: PCell EntityFacade -> Char -getDisplayChar = maybe ' ' facadeChar . erasableToMaybe . cellEntity - where - facadeChar (EntityFacade _ d) = view defaultChar d - -getDisplayGrid :: Scenario -> GameState -> [[PCell EntityFacade]] -getDisplayGrid myScenario gs = - getMapRectangle - mkFacade - (getContentAt worlds . mkCosmic) - boundingBox - where - worlds = view (landscape . multiWorld) gs - - firstScenarioWorld = NE.head $ view scenarioWorlds myScenario - worldArea = area firstScenarioWorld - upperLeftLocation = ul firstScenarioWorld - rawAreaDims = getAreaDimensions worldArea - areaDims = - if isEmpty rawAreaDims - then AreaDimensions 20 10 - else rawAreaDims - lowerRightLocation = upperLeftToBottomRight areaDims upperLeftLocation - - mkCosmic = Cosmic $ worldName firstScenarioWorld - boundingBox = (W.locToCoords upperLeftLocation, W.locToCoords lowerRightLocation) - -renderScenarioMap :: FilePath -> IO [String] -renderScenarioMap fp = simpleErrorHandle $ do - (myScenario, (worldDefs, entities, recipes)) <- loadStandaloneScenario fp - appDataMap <- readAppData - nameGen <- initNameGenerator appDataMap - let gsc = GameStateConfig nameGen entities recipes worldDefs - gs <- sendIO $ scenarioToGameState myScenario emptyLaunchParams gsc - let grid = getDisplayGrid myScenario gs - - return $ map (map getDisplayChar) grid - -printScenarioMap :: [String] -> IO () -printScenarioMap = - sendIO . mapM_ putStrLn diff --git a/src/Swarm/Game/World/Syntax.hs b/src/Swarm/Game/World/Syntax.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Syntax.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Abstract syntax for the Swarm world description DSL. -module Swarm.Game.World.Syntax ( - -- | Various component types - World, - RawCellVal, - CellTag (..), - CellVal (..), - Rot (..), - Var, - Axis (..), - Op (..), - -- | The main AST type - WExp (..), -) -where - -import Control.Lens (view, (^.)) -import Data.List.NonEmpty qualified as NE -import Data.Semigroup (Last (..)) -import Data.Text (Text) -import Data.Text qualified as T -import Prettyprinter -import Swarm.Game.Entity (Entity, entityName) -import Swarm.Game.Robot (Robot, robotName) -import Swarm.Game.Terrain -import Swarm.Game.World.Coords -import Swarm.Language.Pretty -import Swarm.Util (showT) -import Swarm.Util.Erasable - ------------------------------------------------------------- --- Bits and bobs - -type World b = Coords -> b - -data CellTag = CellTerrain | CellEntity | CellRobot - deriving (Eq, Ord, Show, Enum, Bounded) - -instance PrettyPrec CellTag where - prettyPrec _ = \case - CellTerrain -> "terrain" - CellEntity -> "an entity" - CellRobot -> "a robot" - -type RawCellVal = [(Maybe CellTag, Text)] - -prettyRawCellItem :: (Maybe CellTag, Text) -> Doc ann -prettyRawCellItem (Nothing, t) = pretty t -prettyRawCellItem (Just tag, t) = pretty (T.toLower . T.drop 4 . showT $ tag) <> ":" <> pretty t - -data CellVal = CellVal TerrainType (Erasable (Last Entity)) [Robot] - deriving (Eq, Show) - -instance PrettyPrec CellVal where - prettyPrec _ (CellVal terr ent rs) = - "{" <> hsep (punctuate "," (map prettyRawCellItem items)) <> "}" - where - items = - [(Just CellTerrain, getTerrainWord terr) | terr /= BlankT] - ++ [(Just CellEntity, e ^. entityName) | EJust (Last e) <- [ent]] - ++ map ((Just CellRobot,) . view robotName) rs - -data Rot = Rot0 | Rot90 | Rot180 | Rot270 - deriving (Eq, Ord, Show, Bounded, Enum) - -instance PrettyPrec Rot where - prettyPrec _ = \case - Rot0 -> "rot0" - Rot90 -> "rot90" - Rot180 -> "rot180" - Rot270 -> "rot270" - -type Var = Text - -data Axis = X | Y - deriving (Eq, Ord, Show, Bounded, Enum) - -instance PrettyPrec Axis where - prettyPrec _ = \case X -> "x"; Y -> "y" - -data Op = Not | Neg | And | Or | Add | Sub | Mul | Div | Mod | Eq | Neq | Lt | Leq | Gt | Geq | If | Perlin | Reflect Axis | Rot Rot | Mask | Overlay | Abs - deriving (Eq, Ord, Show) - ------------------------------------------------------------- --- Main AST - -data WExp where - WInt :: Integer -> WExp - WFloat :: Double -> WExp - WBool :: Bool -> WExp - WCell :: RawCellVal -> WExp - WVar :: Text -> WExp - -- Require all operators to be fully saturated. Just embedding - -- operators as constants and including function application would - -- be a more elegant encoding, but it requires being more clever - -- with type inference. - WOp :: Op -> [WExp] -> WExp - WSeed :: WExp - WCoord :: Axis -> WExp - WHash :: WExp - WLet :: [(Var, WExp)] -> WExp -> WExp - WOverlay :: NE.NonEmpty WExp -> WExp - WImport :: Text -> WExp - deriving (Eq, Show) - --- We don't have an explicit Empty case because we can't infer its --- type. It could be done but it would require a lot more care with --- inference vs checking mode. - --- TODO (#1394): Add hcat and vcat operations --- WCat :: Axis -> [WExp] -> WExp - --- TODO (#1394): Add support for structures --- WStruct :: WorldPalette Text -> [Text] -> WExp diff --git a/src/Swarm/Game/World/Typecheck.hs b/src/Swarm/Game/World/Typecheck.hs deleted file mode 100644 --- a/src/Swarm/Game/World/Typecheck.hs +++ /dev/null @@ -1,687 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Typechecking and elaboration for the Swarm world DSL. For more --- information, see: --- --- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ -module Swarm.Game.World.Typecheck where - -import Control.Algebra (Has) -import Control.Effect.Reader (Reader, ask) -import Control.Effect.Throw (Throw, throwError) -import Data.Foldable qualified as F -import Data.Functor.Const qualified as F -import Data.Kind (Type) -import Data.List (foldl') -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M -import Data.Semigroup (Last (..)) -import Data.Text (Text) -import Data.Type.Equality (TestEquality (..), type (:~:) (Refl)) -import Prettyprinter -import Swarm.Game.Entity (EntityMap, lookupEntityName) -import Swarm.Game.Terrain (readTerrain) -import Swarm.Game.World.Syntax -import Swarm.Language.Pretty -import Swarm.Util (showT) -import Swarm.Util.Erasable -import Prelude hiding (lookup) - ------------------------------------------------------------- --- Type classes for monoidal world values - --- We could use Semigroup and Monoid, but we want to use the two --- classes separately and make instances for base types, so it's --- cleaner to just make our own classes (the instances would be --- orphans if we used Semigroup and Monoid). - -class Empty e where - empty :: e - -instance Empty CellVal where - empty = CellVal mempty mempty mempty - -class Over m where - () :: m -> m -> m - -instance Over Bool where - _ x = x - -instance Over Integer where - _ x = x - -instance Over Double where - _ x = x - -instance Over CellVal where - CellVal t1 e1 r1 CellVal t2 e2 r2 = CellVal (t1 <> t2) (e1 <> e2) (r1 <> r2) - ------------------------------------------------------------- --- Type class for type-indexed application - -infixl 1 $$ -class Applicable t where - ($$) :: t (a -> b) -> t a -> t b - ------------------------------------------------------------- --- Distinguishing functions and non-functions at the type level - --- In several places, for efficiency we will require something to be --- not a function, which we can enforce using the 'NotFun' constraint. - -type family IsFun a where - IsFun (_ -> _) = 'True - IsFun _ = 'False - -type NotFun a = IsFun a ~ 'False - ------------------------------------------------------------- --- Type-indexed constants - --- | Type-indexed constants. These include both language built-ins --- (@if@, arithmetic, comparison, @<>@, etc.) as well as combinators --- (@S@, @I@, @C@, @K@, @B@, @Φ@) we will use both for elaboration --- and later as a compilation target. -data Const :: Type -> Type where - CLit :: (Show a, NotFun a) => a -> Const a - CCell :: CellVal -> Const CellVal - -- We have a separate CCell instead of using CLit for cells so that we can - -- later extract all the entities from a world expression. - CFI :: Const (Integer -> Double) - CIf :: Const (Bool -> a -> a -> a) - CNot :: Const (Bool -> Bool) - CNeg :: (Num a, NotFun a) => Const (a -> a) - CAbs :: (Num a, NotFun a) => Const (a -> a) - CAnd :: Const (Bool -> Bool -> Bool) - COr :: Const (Bool -> Bool -> Bool) - CAdd :: (Num a, NotFun a) => Const (a -> a -> a) - CSub :: (Num a, NotFun a) => Const (a -> a -> a) - CMul :: (Num a, NotFun a) => Const (a -> a -> a) - CDiv :: (Fractional a, NotFun a) => Const (a -> a -> a) - CIDiv :: (Integral a, NotFun a) => Const (a -> a -> a) - CMod :: (Integral a, NotFun a) => Const (a -> a -> a) - CEq :: (Eq a, NotFun a) => Const (a -> a -> Bool) - CNeq :: (Eq a, NotFun a) => Const (a -> a -> Bool) - CLt :: (Ord a, NotFun a) => Const (a -> a -> Bool) - CLeq :: (Ord a, NotFun a) => Const (a -> a -> Bool) - CGt :: (Ord a, NotFun a) => Const (a -> a -> Bool) - CGeq :: (Ord a, NotFun a) => Const (a -> a -> Bool) - CMask :: (Empty a, NotFun a) => Const (World Bool -> World a -> World a) - CSeed :: Const Integer - CCoord :: Axis -> Const (World Integer) - CHash :: Const (World Integer) - CPerlin :: Const (Integer -> Integer -> Double -> Double -> World Double) - CReflect :: Axis -> Const (World a -> World a) - CRot :: Rot -> Const (World a -> World a) - COver :: (Over a, NotFun a) => Const (a -> a -> a) - -- Combinators generated during elaboration + variable abstraction - K :: Const (a -> b -> a) - S :: Const ((a -> b -> c) -> (a -> b) -> a -> c) - I :: Const (a -> a) - B :: Const ((b -> c) -> (a -> b) -> a -> c) - C :: Const ((a -> b -> c) -> b -> a -> c) - -- Phoenix combinator, aka liftA2. Including this combinator in the - -- target set is not typical, but it turns out to be very helpful in - -- elaborating the "over" operation. - Φ :: Const ((a -> b -> c) -> (d -> a) -> (d -> b) -> (d -> c)) - -deriving instance Show (Const ty) - -class HasConst t where - embed :: Const a -> t a - -infixl 1 .$$ -(.$$) :: (HasConst t, Applicable t) => Const (a -> b) -> t a -> t b -c .$$ t = embed c $$ t - -infixl 1 $$. -($$.) :: (HasConst t, Applicable t) => t (a -> b) -> Const a -> t b -t $$. c = t $$ embed c - -infixl 1 .$$. -(.$$.) :: (HasConst t, Applicable t) => Const (a -> b) -> Const a -> t b -c1 .$$. c2 = embed c1 $$ embed c2 - -instance PrettyPrec (Const α) where - prettyPrec _ = \case - CLit a -> pretty (showT a) - CCell c -> ppr c - CFI -> "fromIntegral" - CIf -> "if" - CNot -> "not" - CNeg -> "negate" - CAbs -> "abs" - CAnd -> "and" - COr -> "or" - CAdd -> "add" - CSub -> "sub" - CMul -> "mul" - CDiv -> "div" - CIDiv -> "idiv" - CMod -> "mod" - CEq -> "eq" - CNeq -> "neq" - CLt -> "lt" - CLeq -> "leq" - CGt -> "gt" - CGeq -> "geq" - CMask -> "mask" - CSeed -> "seed" - CCoord ax -> ppr ax - CHash -> "hash" - CPerlin -> "perlin" - CReflect ax -> case ax of X -> "vreflect"; Y -> "hreflect" - CRot rot -> ppr rot - COver -> "over" - K -> "K" - S -> "S" - I -> "I" - B -> "B" - C -> "C" - Φ -> "Φ" - ------------------------------------------------------------- --- Intrinsically typed core language - --- | Type-level list append. -type family Append (xs :: [k]) (ys :: [k]) :: [k] where - Append '[] ys = ys - Append (x ': xs) ys = x ': Append xs ys - --- | Type- and context-indexed de Bruijn indices. (v :: Idx g a) means --- v represents a variable with type a in a type context g. -data Idx :: [Type] -> Type -> Type where - VZ :: Idx (ty ': g) ty - VS :: Idx g ty -> Idx (x ': g) ty - -deriving instance Show (Idx g ty) - -idxToNat :: Idx g a -> Int -idxToNat VZ = 0 -idxToNat (VS x) = 1 + idxToNat x - --- | A variable valid in one context is also valid in another extended --- context with additional variables. -weakenVar :: forall h g a. Idx g a -> Idx (Append g h) a -weakenVar VZ = VZ -weakenVar (VS x) = VS (weakenVar @h x) - --- | Type-indexed terms. Note this is a stripped-down core language, --- with only variables, lambdas, application, and constants. -data TTerm :: [Type] -> Type -> Type where - TVar :: Idx g a -> TTerm g a - TLam :: TTerm (ty1 ': g) ty2 -> TTerm g (ty1 -> ty2) - TApp :: TTerm g (a -> b) -> TTerm g a -> TTerm g b - TConst :: Const a -> TTerm g a - -deriving instance Show (TTerm g ty) - -instance Applicable (TTerm g) where - TConst I $$ x = x - f $$ x = TApp f x - -instance HasConst (TTerm g) where - embed = TConst - -instance PrettyPrec (TTerm g α) where - prettyPrec :: Int -> TTerm g α -> Doc ann - prettyPrec p = \case - TVar ix -> pretty (idxToNat ix) - TLam t -> - pparens (p > 0) $ - "λ." <+> ppr t - TApp t1 t2 -> - pparens (p > 1) $ - prettyPrec 1 t1 <+> prettyPrec 2 t2 - TConst c -> ppr c - --- | A term valid in one context is also valid in another extended --- context with additional variables (which the term does not use). -weaken :: forall h g a. TTerm g a -> TTerm (Append g h) a -weaken (TVar x) = TVar (weakenVar @h x) -weaken (TLam t) = TLam (weaken @h t) -weaken (TApp t1 t2) = TApp (weaken @h t1) (weaken @h t2) -weaken (TConst c) = TConst c - ------------------------------------------------------------- --- Errors - --- | Errors that can occur during typechecking/elaboration. -data CheckErr where - ApplyErr :: Some (TTerm g) -> Some (TTerm g) -> CheckErr - NoInstance :: Text -> TTy a -> CheckErr - Unbound :: Text -> CheckErr - BadType :: Some (TTerm g) -> TTy b -> CheckErr - BadDivType :: TTy a -> CheckErr - UnknownImport :: Text -> CheckErr - NotAThing :: Text -> CellTag -> CheckErr - NotAnything :: Text -> CheckErr - -deriving instance Show CheckErr - -instance PrettyPrec CheckErr where - prettyPrec _ = \case - ApplyErr (Some ty1 t1) (Some ty2 t2) -> - nest 2 . vsep $ - [ "Error in application:" - , squotes (ppr t1) <> " has type " <> squotes (ppr ty1) - , "and cannot be applied to" - , squotes (ppr t2) <> " which has type " <> squotes (ppr ty2) - ] - NoInstance cls ty -> squotes (ppr ty) <+> "is not an instance of" <+> pretty cls - Unbound x -> "Undefined variable" <+> pretty x - BadType (Some tty t) ty -> - 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) - 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) - ------------------------------------------------------------- --- Type representations - --- | Base types. -data Base :: Type -> Type where - BInt :: Base Integer - BFloat :: Base Double - BBool :: Base Bool - BCell :: Base CellVal - -deriving instance Show (Base ty) - --- | Testing base type representations for equality to yield reflected --- type-level equalities. -instance TestEquality Base where - testEquality BInt BInt = Just Refl - testEquality BFloat BFloat = Just Refl - testEquality BBool BBool = Just Refl - testEquality BCell BCell = Just Refl - testEquality _ _ = Nothing - -instance PrettyPrec (Base α) where - prettyPrec _ = \case - BInt -> "int" - BFloat -> "float" - BBool -> "bool" - BCell -> "cell" - --- | Type representations indexed by the corresponding host language --- type. -data TTy :: Type -> Type where - TTyBase :: Base t -> TTy t - (:->:) :: TTy a -> TTy b -> TTy (a -> b) - TTyWorld :: TTy t -> TTy (World t) - -infixr 0 :->: - -pattern TTyBool :: TTy Bool -pattern TTyBool = TTyBase BBool - -pattern TTyInt :: TTy Integer -pattern TTyInt = TTyBase BInt - -pattern TTyFloat :: TTy Double -pattern TTyFloat = TTyBase BFloat - -pattern TTyCell :: TTy CellVal -pattern TTyCell = TTyBase BCell - -deriving instance Show (TTy ty) - --- | Testing type representations for equality to yield reflected --- type-level equalities. -instance TestEquality TTy where - testEquality (TTyBase b1) (TTyBase b2) = testEquality b1 b2 - testEquality (TTyWorld b1) (TTyWorld b2) = - case testEquality b1 b2 of - Just Refl -> Just Refl - Nothing -> Nothing - testEquality _ _ = Nothing - -instance PrettyPrec (TTy ty) where - prettyPrec :: Int -> TTy ty -> Doc ann - prettyPrec _ (TTyBase b) = ppr b - prettyPrec p (α :->: β) = - pparens (p > 0) $ - prettyPrec 1 α <+> "->" <+> prettyPrec 0 β - prettyPrec p (TTyWorld t) = - pparens (p > 1) $ - "World" <+> prettyPrec 2 t - ------------------------------------------------------------- --- Instance checking - --- | Check that a particular type has an 'GHC.Classes.Eq' instance, and run a --- computation in a context provided with an 'GHC.Classes.Eq' constraint. The --- other @checkX@ functions are similar. -checkEq :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Eq ty, NotFun ty) => m a) -> m a -checkEq (TTyBase BBool) a = a -checkEq (TTyBase BInt) a = a -checkEq (TTyBase BFloat) a = a -checkEq ty _ = throwError $ NoInstance "Eq" ty - -checkOrd :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Ord ty, NotFun ty) => m a) -> m a -checkOrd (TTyBase BBool) a = a -checkOrd (TTyBase BInt) a = a -checkOrd (TTyBase BFloat) a = a -checkOrd ty _ = throwError $ NoInstance "Ord" ty - -checkNum :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Num ty, NotFun ty) => m a) -> m a -checkNum (TTyBase BInt) a = a -checkNum (TTyBase BFloat) a = a -checkNum ty _ = throwError $ NoInstance "Num" ty - -checkIntegral :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Integral ty, NotFun ty) => m a) -> m a -checkIntegral (TTyBase BInt) a = a -checkIntegral ty _ = throwError $ NoInstance "Integral" ty - -checkEmpty :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Empty ty, NotFun ty) => m a) -> m a -checkEmpty (TTyBase BCell) a = a -checkEmpty ty _ = throwError $ NoInstance "Empty" ty - -checkOver :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Over ty, NotFun ty) => m a) -> m a -checkOver (TTyBase BBool) a = a -checkOver (TTyBase BInt) a = a -checkOver (TTyBase BFloat) a = a -checkOver (TTyBase BCell) a = a -checkOver ty _ = throwError $ NoInstance "Over" ty - ------------------------------------------------------------- --- Existential wrappers - --- | Wrap up a type-indexed thing to hide the type index, but package --- it with a 'TTy' which we can pattern-match on to recover the type --- later. -data Some :: (Type -> Type) -> Type where - Some :: TTy α -> t α -> Some t - -deriving instance (forall α. Show (t α)) => Show (Some t) - -mapSome :: (forall α. s α -> t α) -> Some s -> Some t -mapSome f (Some ty t) = Some ty (f t) - -type SomeTy = Some (F.Const ()) - -pattern SomeTy :: TTy α -> SomeTy -pattern SomeTy α = Some α (F.Const ()) -{-# COMPLETE SomeTy #-} - ------------------------------------------------------------- --- Type inference/checking + elaboration - -type WorldMap = Map Text (Some (TTerm '[])) - --- | Type contexts, indexed by a type-level list of types of all the --- variables in the context. -data Ctx :: [Type] -> Type where - CNil :: Ctx '[] - CCons :: Text -> TTy ty -> Ctx g -> Ctx (ty ': g) - --- | Look up a variable name in the context, returning a type-indexed --- de Bruijn index. -lookup :: (Has (Throw CheckErr) sig m) => Text -> Ctx g -> m (Some (Idx g)) -lookup x CNil = throwError $ Unbound x -lookup x (CCons y ty ctx) - | x == y = return $ Some ty VZ - | otherwise = mapSome VS <$> lookup x ctx - --- | Check that a term has a given type, and if so, return a --- corresponding elaborated and type-indexed term. Note that this --- also deals with subtyping: for example, if we check that the term --- @3@ has type @World Int@, we will get back a suitably lifted --- value (/i.e./ @const 3@). -check :: - ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m - , Has (Reader WorldMap) sig m - ) => - Ctx g -> - TTy t -> - WExp -> - m (TTerm g t) -check e ty t = do - t1 <- infer e t - Some ty' t' <- apply (Some (ty :->: ty) (embed I)) t1 - case testEquality ty ty' of - Nothing -> throwError $ BadType t1 ty - Just Refl -> return t' - --- | Get the underlying base type of a term which either has a base --- type or a World type. -getBaseType :: Some (TTerm g) -> SomeTy -getBaseType (Some (TTyWorld ty) _) = SomeTy ty -getBaseType (Some ty _) = SomeTy ty - --- | Apply one term to another term, automatically handling promotion --- and lifting, via the fact that World is Applicative. That is, --- (1) if a term of type T is used where a term of type World T is --- expected, it will automatically be promoted (by an application of --- const); (2) if a function of type (T1 -> T2 -> ... -> Tn) is --- applied to any arguments of type (World Ti), the function will be --- lifted to (World T1 -> World T2 -> ... -> World Tn). -apply :: (Has (Throw CheckErr) sig m) => Some (TTerm g) -> Some (TTerm g) -> m (Some (TTerm g)) --- Normal function application -apply (Some (ty11 :->: ty12) t1) (Some ty2 t2) - | Just Refl <- testEquality ty11 ty2 = return $ Some ty12 (t1 $$ t2) --- (World T -> ...) applied to T: promote the argument to (World T) with const -apply (Some (TTyWorld ty11 :->: ty12) t1) (Some ty2 t2) - | Just Refl <- testEquality ty11 ty2 = return $ Some ty12 (t1 $$ (K .$$ t2)) --- (S -> T) applied to (World S): lift the function to (World S -> World T). -apply (Some (ty11 :->: ty12) t1) (Some (TTyWorld ty2) t2) - | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (B .$$ t1 $$ t2) --- World (S -> T) applied to S. Note this case and the next are --- needed because in the previous case, when (S -> T) is lifted to --- (World S -> World T), T may itself be a function type. -apply (Some (TTyWorld (ty11 :->: ty12)) t1) (Some ty2 t2) - | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (S .$$ t1 $$ (K .$$ t2)) --- World (S -> T) applied to (World S) -apply (Some (TTyWorld (ty11 :->: ty12)) t1) (Some (TTyWorld ty2) t2) - | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (S .$$ t1 $$ t2) -apply t1 t2 = throwError $ ApplyErr t1 t2 - -applyTo :: (Has (Throw CheckErr) sig m) => Some (TTerm g) -> Some (TTerm g) -> m (Some (TTerm g)) -applyTo = flip apply - --- | Infer the type of an operator: turn a raw operator into a --- type-indexed constant. However, some operators are polymorphic, --- so we also provide a list of type arguments. For example, the --- type of the negation operator can be either (Int -> Int) or --- (Float -> Float) so we provide it as an argument. --- --- Currently, all operators take at most one type argument, so --- (Maybe SomeTy) might seem more appropriate than [SomeTy], but --- that is just a coincidence; in general one can easily imagine --- operators that are polymorphic in more than one type variable, --- and we may wish to add such in the future. -inferOp :: (Has (Throw CheckErr) sig m) => [SomeTy] -> Op -> m (Some (TTerm g)) -inferOp _ Not = return $ Some (TTyBool :->: TTyBool) (embed CNot) -inferOp [SomeTy tyA] Neg = Some (tyA :->: tyA) <$> checkNum tyA (return $ embed CNeg) -inferOp _ And = return $ Some (TTyBool :->: TTyBool :->: TTyBool) (embed CAnd) -inferOp _ Or = return $ Some (TTyBool :->: TTyBool :->: TTyBool) (embed COr) -inferOp [SomeTy tyA] Abs = Some (tyA :->: tyA) <$> checkNum tyA (return $ embed CAbs) -inferOp [SomeTy tyA] Add = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CAdd) -inferOp [SomeTy tyA] Sub = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CSub) -inferOp [SomeTy tyA] Mul = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CMul) -inferOp [SomeTy tyA] Div = case tyA of - TTyBase BInt -> return $ Some (tyA :->: tyA :->: tyA) (embed CIDiv) - TTyBase BFloat -> return $ Some (tyA :->: tyA :->: tyA) (embed CDiv) - _ -> throwError $ BadDivType tyA -inferOp [SomeTy tyA] Mod = Some (tyA :->: tyA :->: tyA) <$> checkIntegral tyA (return $ embed CMod) -inferOp [SomeTy tyA] Eq = Some (tyA :->: tyA :->: TTyBool) <$> checkEq tyA (return $ embed CEq) -inferOp [SomeTy tyA] Neq = Some (tyA :->: tyA :->: TTyBool) <$> checkEq tyA (return $ embed CNeq) -inferOp [SomeTy tyA] Lt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CLt) -inferOp [SomeTy tyA] Leq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CLeq) -inferOp [SomeTy tyA] Gt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGt) -inferOp [SomeTy tyA] Geq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGeq) -inferOp [SomeTy tyA] If = return $ Some (TTyBool :->: tyA :->: tyA :->: tyA) (embed CIf) -inferOp _ Perlin = return $ Some (TTyInt :->: TTyInt :->: TTyFloat :->: TTyFloat :->: TTyWorld TTyFloat) (embed CPerlin) -inferOp [SomeTy tyA] (Reflect r) = return $ Some (TTyWorld tyA :->: TTyWorld tyA) (embed (CReflect r)) -inferOp [SomeTy tyA] (Rot r) = return $ Some (TTyWorld tyA :->: TTyWorld tyA) (embed (CRot r)) -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 tys op = error $ "bad call to inferOp: " ++ show tys ++ " " ++ show op - --- | Given a raw operator and the terms the operator is applied to, --- select which types should be supplied as the type arguments to --- the operator. For example, for an operator like @+@ we can just --- select the type of its first argument; for an operator like @if@, --- we must select the type of its second argument, since @if : Bool --- -> a -> a -> a@. In all cases we must also select the underlying --- base type in case the argument has a @World@ type. For example --- if @+@ is applied to an argument of type @World Int@ we still --- want to give @+@ the type @Int -> Int -> Int@. It can be lifted --- to have type @World Int -> World Int -> World Int@ but that will --- be taken care of by application, which will insert the right --- combinators to do the lifting. -typeArgsFor :: Op -> [Some (TTerm g)] -> [SomeTy] -typeArgsFor op (t : _) - | op `elem` [Neg, Abs, Add, Sub, Mul, Div, Mod, Eq, Neq, Lt, Leq, Gt, Geq] = [getBaseType t] -typeArgsFor (Reflect _) (t : _) = [getBaseType t] -typeArgsFor (Rot _) (t : _) = [getBaseType t] -typeArgsFor op (_ : t : _) - | op `elem` [If, Mask, Overlay] = [getBaseType t] -typeArgsFor _ _ = [] - --- | Typecheck the application of an operator to some terms, returning --- a typed, elaborated version of the application. -applyOp :: - ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m - , Has (Reader WorldMap) sig m - ) => - Ctx g -> - Op -> - [WExp] -> - m (Some (TTerm g)) -applyOp ctx op ts = do - tts <- mapM (infer ctx) ts - foldl (\r -> (r >>=) . applyTo) (inferOp (typeArgsFor op tts) op) tts - --- | Infer the type of a term, and elaborate along the way. -infer :: - forall sig m g. - ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m - , Has (Reader WorldMap) sig m - ) => - Ctx g -> - WExp -> - m (Some (TTerm g)) -infer _ (WInt i) = return $ Some (TTyBase BInt) (embed (CLit i)) -infer _ (WFloat f) = return $ Some (TTyBase BFloat) (embed (CLit f)) -infer _ (WBool b) = return $ Some (TTyBase BBool) (embed (CLit b)) -infer _ (WCell c) = do - c' <- resolveCell c - return $ Some TTyCell (embed (CCell c')) -infer ctx (WVar x) = mapSome TVar <$> lookup x ctx -infer ctx (WOp op ts) = applyOp ctx op ts -infer _ WSeed = return $ Some TTyInt (embed CSeed) -infer _ (WCoord ax) = return $ Some (TTyWorld TTyInt) (embed (CCoord ax)) -infer _ WHash = return $ Some (TTyWorld TTyInt) (embed CHash) -infer ctx (WLet defs body) = inferLet ctx defs body -infer ctx (WOverlay ts) = inferOverlay ctx ts -infer _ctx (WImport key) = do - worldMap <- ask @WorldMap - case M.lookup key worldMap of - Just (Some ty t) -> return (Some ty (weaken @g t)) - Nothing -> throwError $ UnknownImport key - --- | Try to resolve a 'RawCellVal'---containing only 'Text' names for --- terrain, entities, and robots---into a real 'CellVal' with --- references to actual terrain, entities, and robots. -resolveCell :: - (Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m) => - RawCellVal -> - m CellVal -resolveCell items = do - cellVals <- mapM resolveCellItem items - return $ foldl' () empty cellVals - --- | Try to resolve one cell item name into an actual item (terrain, --- entity, robot, etc.). -resolveCellItem :: - forall sig m. - (Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m) => - (Maybe CellTag, Text) -> - m CellVal -resolveCellItem (mCellTag, item) = case mCellTag of - Just cellTag -> do - -- The item was tagged specifically, like {terrain: dirt} or {entity: water} - mCell <- resolverByTag cellTag item - maybe (throwError $ NotAThing item cellTag) return mCell - Nothing -> do - -- The item was not tagged; try resolving in all possible ways and choose - -- the first that works - maybeCells <- mapM (`resolverByTag` item) [minBound .. maxBound :: CellTag] - case F.asum maybeCells of - Nothing -> throwError $ NotAnything item - Just cell -> return cell - where - mkTerrain t = CellVal t mempty mempty - mkEntity e = CellVal mempty (EJust (Last e)) mempty - resolverByTag :: CellTag -> Text -> m (Maybe CellVal) - resolverByTag = \case - CellTerrain -> return . fmap mkTerrain . readTerrain - CellEntity -> \eName -> - case eName of - "erase" -> return $ Just (CellVal mempty EErase mempty) - _ -> do - em <- ask @EntityMap - return . fmap mkEntity $ lookupEntityName eName em - CellRobot -> \_ -> return Nothing -- TODO (#1396): support robots - --- | Infer the type of a let expression, and elaborate into a series --- of lambda applications. -inferLet :: - ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m - , Has (Reader WorldMap) sig m - ) => - Ctx g -> - [(Var, WExp)] -> - WExp -> - m (Some (TTerm g)) -inferLet ctx [] body = infer ctx body -inferLet ctx ((x, e) : xs) body = do - e'@(Some ty1 _) <- infer ctx e - Some ty2 let' <- inferLet (CCons x ty1 ctx) xs body - apply (Some (ty1 :->: ty2) (TLam let')) e' - --- | Infer the type of an @overlay@ expression, and elaborate into a --- chain of @<>@ (over) operations. -inferOverlay :: - ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m - , Has (Reader WorldMap) sig m - ) => - Ctx g -> - NE.NonEmpty WExp -> - m (Some (TTerm g)) -inferOverlay ctx es = case NE.uncons es of - -- @overlay [e] = e@ - (e, Nothing) -> infer ctx e - -- @overlay (e : es') = e <> overlay es'@ - (e, Just es') -> do - e' <- infer ctx e - o' <- inferOverlay ctx es' - case getBaseType e' of - SomeTy ty -> do - let wty = TTyWorld ty - c <- checkOver ty (return $ embed COver) - apply (Some (wty :->: wty :->: wty) (Φ .$$ c)) e' >>= applyTo o' diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs deleted file mode 100644 --- a/src/Swarm/Language/Capability.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Capabilities needed to evaluate and execute programs. Language --- constructs or commands require certain capabilities, and in turn --- capabilities are provided by various devices. A robot must have an --- appropriate device equipped in order to make use of each language --- construct or command. -module Swarm.Language.Capability ( - Capability (..), - capabilityName, - constCaps, -) where - -import Data.Aeson (FromJSONKey, ToJSONKey) -import Data.Char (toLower) -import Data.Data (Data) -import Data.Hashable (Hashable) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Yaml -import GHC.Generics (Generic) -import Swarm.Language.Syntax -import Swarm.Util (failT) -import Text.Read (readMaybe) -import Witch (from) -import Prelude hiding (lookup) - --- | Various capabilities which robots can have. -data Capability - = -- | Be powered, i.e. execute anything at all - CPower - | -- | Execute the 'Move' command - CMove - | -- | Execute the 'Backup' command - CBackup - | -- | 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 '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 '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 - CFloat - | -- | Evaluate conditional expressions - CCond - | -- | Negate boolean value - CNegation - | -- | Evaluate comparison operations - CCompare - | -- | Use cardinal direction constants. - 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. - CProd - | -- | Capability for working with record types. - CRecord - | -- | Debug capability. - CDebug - | -- | Capability to handle keyboard input. - CHandleinput - | -- | Capability to make other robots halt. - CHalt - | -- | 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) - -capabilityName :: Capability -> Text -capabilityName = from @String . map toLower . drop 1 . show - -instance ToJSON Capability where - toJSON = String . capabilityName - -instance FromJSON Capability where - parseJSON = withText "Capability" tryRead - where - tryRead :: Text -> Parser Capability - tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of - Just c -> return c - Nothing -> failT ["Unknown capability", t] - --- | Capabilities needed to evaluate or execute a constant. -constCaps :: Const -> Maybe Capability -constCaps = \case - -- ---------------------------------------------------------------- - -- Some built-in constants that don't require any special capability. - Noop -> Nothing - AppF -> Nothing - Force -> Nothing - Return -> Nothing - Parent -> Nothing - Base -> Nothing - Setname -> Nothing - Undefined -> Nothing - Fail -> Nothing - Has -> Nothing - Equipped -> Nothing - -- speaking is natural to robots (unlike listening) - Say -> Nothing - -- 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 - Path -> Just CPath - Push -> Just CPush - Stride -> Just CMovemultiple - Turn -> Just CTurn - Grab -> Just CGrab - Harvest -> Just CHarvest - 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 - 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 - 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 diff --git a/src/Swarm/Language/Context.hs b/src/Swarm/Language/Context.hs deleted file mode 100644 --- a/src/Swarm/Language/Context.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | --- 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. -module Swarm.Language.Context where - -import Control.Lens.Empty (AsEmpty (..)) -import Control.Lens.Prism (prism) -import Control.Monad.Reader (MonadReader, local) -import Data.Aeson (FromJSON, ToJSON) -import Data.Data (Data) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Text (Text) -import GHC.Generics (Generic) -import Prelude hiding (lookup) - --- | We use 'Text' values to represent variables. -type Var = Text - --- | A context is a mapping from variable names to things. -newtype Ctx t = Ctx {unCtx :: Map Var t} - deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON) - --- | The semigroup operation for contexts is /right/-biased union. -instance Semigroup (Ctx t) where - (<>) = union - -instance Monoid (Ctx t) where - mempty = empty - mappend = (<>) - -instance AsEmpty (Ctx t) where - _Empty = prism (const empty) isEmpty - where - isEmpty (Ctx c) - | M.null c = Right () - | otherwise = Left (Ctx c) - --- | The empty context. -empty :: Ctx t -empty = Ctx M.empty - --- | A singleton context. -singleton :: Var -> t -> Ctx t -singleton x t = Ctx (M.singleton x t) - --- | Look up a variable in a context. -lookup :: Var -> Ctx t -> Maybe t -lookup x (Ctx c) = M.lookup x c - --- | Delete a variable from a context. -delete :: Var -> Ctx t -> Ctx t -delete x (Ctx c) = Ctx (M.delete x c) - --- | Get the list of key-value associations from a context. -assocs :: Ctx t -> [(Var, t)] -assocs = M.assocs . 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) - --- | /Right/-biased union of contexts. -union :: Ctx t -> Ctx t -> Ctx t -union (Ctx c1) (Ctx c2) = Ctx (c2 `M.union` c1) - --- | Locally extend the context with an additional binding. -withBinding :: MonadReader (Ctx t) m => Var -> t -> m a -> m a -withBinding x ty = local (addBinding x ty) - --- | Locally extend the context with an additional context of --- bindings. -withBindings :: MonadReader (Ctx t) m => Ctx t -> m a -> m a -withBindings ctx = local (`union` ctx) diff --git a/src/Swarm/Language/Direction.hs b/src/Swarm/Language/Direction.hs deleted file mode 100644 --- a/src/Swarm/Language/Direction.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Types and helper functions for working with directions -module Swarm.Language.Direction ( - -- * Directions - Direction (..), - AbsoluteDir (..), - RelativeDir (..), - PlanarRelativeDir (..), - directionSyntax, - isCardinal, - allDirs, -) where - -import Data.Aeson.Types hiding (Key) -import Data.Char qualified as C (toLower) -import Data.Data (Data) -import Data.Hashable (Hashable) -import Data.List qualified as L (tail) -import Data.Text hiding (filter, length, map) -import Data.Text qualified as T -import GHC.Generics (Generic) -import Swarm.Util qualified as Util -import Witch.From (from) - ------------------------------------------------------------- --- Directions ------------------------------------------------------------- - --- | An absolute direction is one which is defined with respect to an --- external frame of reference; robots need a compass in order to --- use them. --- --- NOTE: These values are ordered by increasing angle according to --- the standard mathematical convention. --- That is, the right-pointing direction, East, is considered --- the "reference angle" and the order proceeds counter-clockwise. --- See https://en.wikipedia.org/wiki/Polar_coordinate_system#Conventions --- --- Do not alter this ordering, as there exist functions that depend on it --- (e.g. 'Swarm.Game.Location.nearestDirection' and 'Swarm.Game.Location.relativeTo'). -data AbsoluteDir = DEast | DNorth | DWest | DSouth - deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, Enum, Bounded) - -directionJsonModifier :: String -> String -directionJsonModifier = map C.toLower . L.tail - -directionJsonOptions :: Options -directionJsonOptions = - defaultOptions - { constructorTagModifier = directionJsonModifier - } - -instance FromJSON AbsoluteDir where - parseJSON = genericParseJSON directionJsonOptions - -instance ToJSON AbsoluteDir where - toJSON = genericToJSON directionJsonOptions - -cardinalDirectionKeyOptions :: JSONKeyOptions -cardinalDirectionKeyOptions = - defaultJSONKeyOptions - { keyModifier = directionJsonModifier - } - -instance ToJSONKey AbsoluteDir where - toJSONKey = genericToJSONKey cardinalDirectionKeyOptions - -instance FromJSONKey AbsoluteDir where - fromJSONKey = genericFromJSONKey cardinalDirectionKeyOptions - --- | A relative direction is one which is defined with respect to the --- robot's frame of reference; no special capability is needed to --- use them. -data RelativeDir = DPlanar PlanarRelativeDir | DDown - deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON) - --- | Caution: Do not alter this ordering, as there exist functions that depend on it --- (e.g. 'Swarm.Game.Location.nearestDirection' and 'Swarm.Game.Location.relativeTo'). -data PlanarRelativeDir = DForward | DLeft | DBack | DRight - deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, Enum, Bounded) - -instance FromJSON PlanarRelativeDir where - parseJSON = genericParseJSON directionJsonOptions - -instance ToJSON PlanarRelativeDir where - toJSON = genericToJSON directionJsonOptions - --- | The type of directions. Used /e.g./ to indicate which way a robot --- will turn. -data Direction = DAbsolute AbsoluteDir | DRelative RelativeDir - deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON) - --- | Direction name is generated from the deepest nested data constructor --- e.g. 'DLeft' becomes "left" -directionSyntax :: Direction -> Text -directionSyntax d = toLower . T.tail . from $ case d of - DAbsolute x -> show x - DRelative x -> case x of - DPlanar y -> show y - _ -> show x - --- | Check if the direction is absolute (e.g. 'Swarm.Game.Location.north' or 'Swarm.Game.Location.south'). -isCardinal :: Direction -> Bool -isCardinal = \case - DAbsolute _ -> True - _ -> False - -allDirs :: [Direction] -allDirs = map DAbsolute Util.listEnums <> map DRelative (DDown : map DPlanar Util.listEnums) diff --git a/src/Swarm/Language/Elaborate.hs b/src/Swarm/Language/Elaborate.hs deleted file mode 100644 --- a/src/Swarm/Language/Elaborate.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Term elaboration which happens after type checking. -module Swarm.Language.Elaborate where - -import Control.Lens (transform, (%~), (^.)) -import Swarm.Language.Syntax -import Swarm.Language.Types - --- | Perform some elaboration / rewriting on a fully type-annotated --- term. This currently performs such operations as rewriting @if@ --- expressions and recursive let expressions to use laziness --- appropriately. In theory it could also perform rewriting for --- overloaded constants depending on the actual type they are used --- at, but currently that sort of thing tends to make type inference --- fall over. -elaborate :: Syntax' Polytype -> Syntax' Polytype -elaborate = - -- Wrap all *free* variables in 'Force'. Free variables must be - -- referring to a previous definition, which are all wrapped in - -- 'TDelay'. - (freeVarsS %~ \s -> Syntax' (s ^. sLoc) (SApp sForce s) (s ^. sType)) - -- Now do additional rewriting on all subterms. - . transform rewrite - where - rewrite :: Syntax' Polytype -> Syntax' Polytype - rewrite (Syntax' l t ty) = Syntax' l (rewriteTerm t) ty - - rewriteTerm :: Term' Polytype -> Term' Polytype - rewriteTerm = \case - -- For recursive let bindings, rewrite any occurrences of x to - -- (force x). When interpreting t1, we will put a binding (x |-> - -- delay t1) in the context. - SLet True x ty t1 t2 -> SLet True x ty (wrapForce (lvVar x) t1) (wrapForce (lvVar x) t2) - -- Rewrite any recursive occurrences of x inside t1 to (force x). - -- When a TDef is encountered at runtime its body will immediately - -- be wrapped in a VDelay. However, to make this work we also need - -- to wrap all free variables in any term with 'force' --- since - -- any such variables must in fact refer to things previously - -- bound by 'def'. - SDef True x ty t1 -> SDef True x ty (wrapForce (lvVar x) t1) - -- Rewrite @f $ x@ to @f x@. - SApp (Syntax' _ (SApp (Syntax' _ (TConst AppF) _) l) _) r -> SApp l r - -- Leave any other subterms alone. - t -> t - -wrapForce :: Var -> Syntax' Polytype -> Syntax' Polytype -wrapForce x = mapFreeS x (\s@(Syntax' l _ ty) -> Syntax' l (SApp sForce s) ty) - --- Note, TyUnit is not the right type, but I don't want to bother - -sForce :: Syntax' Polytype -sForce = Syntax' NoLoc (TConst Force) (Forall ["a"] (TyDelay (TyVar "a") :->: TyVar "a")) diff --git a/src/Swarm/Language/Key.hs b/src/Swarm/Language/Key.hs deleted file mode 100644 --- a/src/Swarm/Language/Key.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Parsing and pretty-printing for keys (as in, keys on a keyboard) --- and key combos. -module Swarm.Language.Key ( - KeyCombo, - mkKeyCombo, - parseKeyComboFull, - parseKeyCombo, - prettyKeyCombo, - specialKeyNames, -) -where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Foldable (asum) -import Data.Kind qualified -import Data.List (sort, (\\)) -import Data.Set (Set) -import Data.Set qualified as S -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics hiding (from) -import Graphics.Vty.Input.Events qualified as V -import Swarm.Language.Parse -import Text.Megaparsec -import Text.Megaparsec.Char (char, string) -import Text.Megaparsec.Char.Lexer (decimal) -import Witch (from) - ------------------------------------------------------------- --- Parsing - --- | 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 instance FromJSON V.Key -deriving instance FromJSON V.Modifier -deriving instance ToJSON V.Key -deriving instance ToJSON V.Modifier - --- | Smart constructor for 'KeyCombo'. -mkKeyCombo :: [V.Modifier] -> V.Key -> KeyCombo -mkKeyCombo mods k = KeyCombo k (sort mods) - --- | Parse a key combo with nothing after it. -parseKeyComboFull :: Parser KeyCombo -parseKeyComboFull = parseKeyCombo <* eof - --- | Parse a key combo like @\"M-C-F5\"@, @\"Down\"@, or @\"C-x\"@. -parseKeyCombo :: Parser KeyCombo -parseKeyCombo = - mkKeyCombo <$> many (try (parseModifier <* char '-')) <*> parseKey - -parseModifier :: Parser V.Modifier -parseModifier = - V.MShift <$ string "S" - <|> V.MCtrl <$ string "C" - <|> V.MMeta <$ string "M" - <|> V.MAlt <$ string "A" - -parseKey :: Parser V.Key -parseKey = - -- For an explanation of the 'reverse', see Note [Key names are not prefix-free] - (asum . map specialKeyParser . reverse . S.toList $ specialKeyNames) - <|> parseFunctionKey - <|> parseCharKey - --- Note [Key names are not prefix-free] --- --- The names of special keys are not prefix-free, and in particular --- include 'Down', 'DownRight', 'DownLeft', and also 'Up', 'UpRight', --- 'UpLeft'. When we try to parse a particular name with 'string' it --- will backtrack as long as the whole string is not consumed, which --- means it's OK if key names share a common prefix, like Enter and --- Esc. However, when one key name is a prefix of another we have to --- be careful of the order in which we try parsing them, and in --- particular we must try parsing the longer one first. If we have --- 'Up' come first and then 'UpLeft', for example, given the input --- "UpLeft" the 'Up' would succeed, but then the entire parse would --- fail since there is input left over. If we simply reverse the list --- of key names (which are sorted alphabetically), it guarantees that --- longer names will come before names which are prefixes of them. - -parseFunctionKey :: Parser V.Key -parseFunctionKey = V.KFun <$> try (char 'F' *> decimal) - -parseCharKey :: Parser V.Key -parseCharKey = V.KChar <$> anySingle - -specialKeyParser :: Text -> Parser V.Key -specialKeyParser t = read . ('K' :) . from @Text <$> string t - --- https://stackoverflow.com/questions/51848587/list-constructor-names-using-generics-in-haskell -specialKeyNames :: Set Text -specialKeyNames = S.fromList . map T.tail $ (names' @(Rep V.Key) \\ ["KChar", "KFun"]) - -class Names' (f :: Data.Kind.Type -> Data.Kind.Type) where - names' :: [Text] -instance (Names' f) => Names' (M1 D t f) where - names' = names' @f -instance (Names' f, Names' g) => Names' (f :+: g) where - names' = names' @f ++ names' @g -instance (Constructor c) => Names' (C1 c f) where - names' = [from @String (conName (undefined :: C1 c f g))] - ------------------------------------------------------------- --- Pretty-printing - --- | Pretty-print a key combo, e.g. @\"C-M-F5\"@. Right inverse to --- 'parseKeyCombo'. Left inverse up to reordering of modifiers. -prettyKeyCombo :: KeyCombo -> Text -prettyKeyCombo (KeyCombo k mods) = T.append (T.concat (map prettyModifier mods)) (prettyKey k) - -prettyModifier :: V.Modifier -> Text -prettyModifier m = from @String [modifierChar m, '-'] - where - modifierChar = \case - V.MAlt -> 'A' - V.MCtrl -> 'C' - V.MMeta -> 'M' - V.MShift -> 'S' - -prettyKey :: V.Key -> Text -prettyKey = - from @String . \case - V.KChar c -> [c] - V.KFun n -> 'F' : show n - k -> drop 1 (show k) diff --git a/src/Swarm/Language/LSP.hs b/src/Swarm/Language/LSP.hs deleted file mode 100644 --- a/src/Swarm/Language/LSP.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Language Server Protocol (LSP) server for the Swarm language. --- See the docs/EDITORS.md to learn how to use it. -module Swarm.Language.LSP where - -import Control.Lens (to, (^.)) -import Control.Monad (void) -import Control.Monad.IO.Class -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) -import Data.Text.IO qualified as Text -import Language.LSP.Diagnostics -import Language.LSP.Server -import Language.LSP.Types (Hover (Hover)) -import Language.LSP.Types qualified as J -import Language.LSP.Types.Lens qualified as J -import Language.LSP.VFS (VirtualFile (..), virtualFileText) -import Swarm.Language.LSP.Hover qualified as H -import Swarm.Language.LSP.VarUsage qualified as VU -import Swarm.Language.Parse -import Swarm.Language.Pipeline -import Swarm.Language.Pretty (prettyText) -import Swarm.Language.Syntax (SrcLoc (..)) -import Swarm.Language.Typecheck (ContextualTypeErr (..)) -import System.IO (stderr) -import Witch - -lspMain :: IO () -lspMain = - void $ - runServer $ - ServerDefinition - { onConfigurationChange = const $ const $ Right () - , defaultConfig = () - , doInitialize = \env _req -> pure $ Right env - , staticHandlers = handlers - , interpretHandler = \env -> Iso (runLspT env) liftIO - , options = - defaultOptions - { -- set sync options to get DidSave event, as well as Open and Close events. - textDocumentSync = - Just - ( J.TextDocumentSyncOptions - (Just True) - (Just syncKind) - (Just False) - (Just False) - (Just . J.InR . J.SaveOptions $ Just True) - ) - } - } - where - -- Using SyncFull seems to handle the debounce for us. - -- The alternative is to use SyncIncremental, but then then - -- handler is called for each key-stroke. - syncKind = J.TdSyncFull - -diagnosticSourcePrefix :: Text -diagnosticSourcePrefix = "swarm-lsp" - -debug :: (MonadIO m) => Text -> m () -debug msg = liftIO $ Text.hPutStrLn stderr $ "[swarm-lsp] " <> msg - -validateSwarmCode :: J.NormalizedUri -> J.TextDocumentVersion -> Text -> LspM () () -validateSwarmCode doc version content = do - -- debug $ "Validating: " <> from (show doc) <> " ( " <> content <> ")" - - -- FIXME: #1040 With this call to flushDiagnosticsBySource in place, the warnings - -- in other buffers (editor tabs) end up getting cleared when switching between - -- (focusing on) other buffers in VS Code. - -- However, getting rid of this seems to break error highlighting. - flushDiagnosticsBySource 0 (Just diagnosticSourcePrefix) - - let (parsingErrs, unusedVarWarnings) = case readTerm' content of - Right Nothing -> ([], []) - Right (Just term) -> (parsingErrors, unusedWarnings) - where - VU.Usage _ problems = VU.getUsage mempty term - unusedWarnings = mapMaybe (VU.toErrPos content) problems - - parsingErrors = case processParsedTerm' mempty mempty term of - Right _ -> [] - Left e -> pure $ showTypeErrorPos content e - Left e -> (pure $ showErrorPos e, []) - -- debug $ "-> " <> from (show err) - - publishDiags $ - map makeUnusedVarDiagnostic unusedVarWarnings - - -- NOTE: "publishDiags" keeps only one diagnostic at a - -- time (the most recent) so we make sure the errors are - -- issued last (after any warnings). - -- Note that it does not achieve the desired effect to simply - -- concatenate the two diagnostic lists into a single - -- publishDiagnostics function call (regardless of the order - -- of the lists). - publishDiags $ - map makeParseErrorDiagnostic parsingErrs - where - publishDiags :: [J.Diagnostic] -> LspM () () - publishDiags = publishDiagnostics 1 doc version . partitionBySource - - makeUnusedVarDiagnostic :: (J.Range, Text) -> J.Diagnostic - makeUnusedVarDiagnostic (range, msg) = - J.Diagnostic - range - (Just J.DsWarning) -- severity - Nothing -- code - (Just diagnosticSourcePrefix) -- source - msg - (Just (J.List [J.DtUnnecessary])) -- tags - Nothing -- related source code info - makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> J.Diagnostic - makeParseErrorDiagnostic ((startLine, startCol), (endLine, endCol), msg) = - J.Diagnostic - ( J.Range - (J.Position (fromIntegral startLine) (fromIntegral startCol)) - (J.Position (fromIntegral endLine) (fromIntegral endCol)) - ) - (Just J.DsError) -- severity - Nothing -- code - (Just diagnosticSourcePrefix) -- source - msg - Nothing -- tags - (Just (J.List [])) - -showTypeErrorPos :: Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text) -showTypeErrorPos code (CTE l _ te) = (minusOne start, minusOne end, msg) - where - minusOne (x, y) = (x - 1, y - 1) - - (start, end) = case l of - SrcLoc s e -> getLocRange code (s, e) - NoLoc -> ((1, 1), (65535, 65535)) -- unknown loc spans the whole document - msg = prettyText te - -handlers :: Handlers (LspM ()) -handlers = - mconcat - [ notificationHandler J.SInitialized $ \_not -> do - debug "Initialized" - , notificationHandler J.STextDocumentDidSave $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - content = fromMaybe "?" $ msg ^. J.params . J.text - validateSwarmCode (J.toNormalizedUri doc) Nothing content - , notificationHandler J.STextDocumentDidOpen $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - content = msg ^. J.params . J.textDocument . J.text - validateSwarmCode (J.toNormalizedUri doc) Nothing content - , notificationHandler J.STextDocumentDidChange $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri - mdoc <- getVirtualFile doc - case mdoc of - Just vf@(VirtualFile _ version _rope) -> do - validateSwarmCode doc (Just $ fromIntegral version) (virtualFileText vf) - _ -> debug $ "No virtual file found for: " <> from (show msg) - , requestHandler J.STextDocumentHover $ \req responder -> do - let doc = req ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri - pos = req ^. J.params . J.position - mdoc <- getVirtualFile doc - let maybeHover = do - vf <- mdoc - (markdownText, maybeRange) <- H.showHoverInfo doc Nothing pos vf - return $ Hover (J.HoverContents $ J.MarkupContent J.MkMarkdown markdownText) maybeRange - responder $ Right maybeHover - ] diff --git a/src/Swarm/Language/LSP/Hover.hs b/src/Swarm/Language/LSP/Hover.hs deleted file mode 100644 --- a/src/Swarm/Language/LSP/Hover.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Language.LSP.Hover ( - showHoverInfo, - - -- * Documentation rendering - renderDoc, - treeToMarkdown, - - -- * Finding source location - narrowToPosition, - - -- * Explaining source position - explain, -) where - -import Control.Applicative ((<|>)) -import Control.Lens ((^.)) -import Control.Monad (guard, void) -import Data.Foldable (asum) -import Data.Graph -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map qualified as M -import Data.Maybe (catMaybes, fromMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Utf16.Rope qualified as R -import Language.LSP.Types qualified as J -import Language.LSP.VFS -import Swarm.Language.Context as Ctx -import Swarm.Language.Module (Module (..)) -import Swarm.Language.Parse (readTerm', unTuple) -import Swarm.Language.Pipeline (ProcessedTerm (..), processParsedTerm) -import Swarm.Language.Pretty (prettyText) -import Swarm.Language.Syntax -import Swarm.Language.Typecheck (inferConst) -import Swarm.Language.Types -import Swarm.Util qualified as U - -withinBound :: Int -> SrcLoc -> Bool -withinBound pos (SrcLoc s e) = pos >= s && pos < e -withinBound _ NoLoc = False - -ropeToLspPosition :: R.Position -> J.Position -ropeToLspPosition (R.Position l c) = - J.Position (fromIntegral l) (fromIntegral c) - -lspToRopePosition :: J.Position -> R.Position -lspToRopePosition (J.Position myLine myCol) = - R.Position (fromIntegral myLine) (fromIntegral myCol) - -showHoverInfo :: - J.NormalizedUri -> - J.TextDocumentVersion -> - J.Position -> - VirtualFile -> - Maybe (Text, Maybe J.Range) -showHoverInfo _ _ p vf@(VirtualFile _ _ myRope) = - case readTerm' content of - Left _ -> Nothing - Right Nothing -> Nothing - Right (Just stx) -> Just $ case processParsedTerm stx of - Left _e -> - let found@(Syntax foundSloc _) = narrowToPosition stx $ fromIntegral absolutePos - finalPos = posToRange myRope foundSloc - in (,finalPos) . treeToMarkdown 0 $ explain found - Right (ProcessedTerm modul _req _reqCtx) -> - let found@(Syntax' foundSloc _ _) = narrowToPosition (moduleAST modul) $ fromIntegral absolutePos - finalPos = posToRange myRope foundSloc - in (,finalPos) . treeToMarkdown 0 $ explain found - where - content = virtualFileText vf - absolutePos = - maybe 0 (R.length . fst) $ - R.splitAtPosition (lspToRopePosition p) myRope - -posToRange :: R.Rope -> SrcLoc -> Maybe J.Range -posToRange myRope foundSloc = do - (s, e) <- case foundSloc of - SrcLoc s e -> Just (s, e) - _ -> Nothing - (startRope, _) <- R.splitAt (fromIntegral s) myRope - (endRope, _) <- R.splitAt (fromIntegral e) myRope - return $ - J.Range - (ropeToLspPosition $ R.lengthAsPosition startRope) - (ropeToLspPosition $ R.lengthAsPosition endRope) - -descend :: - ExplainableType ty => - -- | position - Int -> - -- | next element to inspect - Syntax' ty -> - Maybe (Syntax' ty) -descend pos s1@(Syntax' l1 _ _) = do - guard $ withinBound pos l1 - return $ narrowToPosition s1 pos - --- | Find the most specific term for a given --- position within the code. -narrowToPosition :: - ExplainableType ty => - -- | parent term - Syntax' ty -> - -- | absolute offset within the file - Int -> - Syntax' ty -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 - SDef _ lv _ s@(Syntax' _ _ lty) -> d (locVarToSyntax' lv lty) <|> d s - SBind mlv s1@(Syntax' _ _ lty) s2 -> (mlv >>= d . flip locVarToSyntax' (getInnerType lty)) <|> d s1 <|> d s2 - 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 - -- atoms - return their position and end recursion - TUnit -> Nothing - TConst {} -> Nothing - TDir {} -> Nothing - TInt {} -> Nothing - TText {} -> Nothing - TBool {} -> Nothing - TVar {} -> Nothing - TRequire {} -> Nothing - TRequireDevice {} -> Nothing - -- these should not show up in surface language - TRef {} -> Nothing - TRobot {} -> Nothing - TAntiInt {} -> Nothing - TAntiText {} -> Nothing - where - d = descend pos - -renderDoc :: Int -> Text -> Text -renderDoc d t - | d == 0 = t - | otherwise = T.drop 2 . indent (max 0 (4 * (d - 1)) + 2) $ "* " <> t - where - indent x = T.unlines . map (T.replicate x " " <>) . T.lines - -treeToMarkdown :: Int -> Tree Text -> Text -treeToMarkdown d (Node t children) = - T.unlines $ renderDoc d t : map (treeToMarkdown $ d + 1) children - -class Show t => ExplainableType t where - -- | Pretty print the type. - prettyType :: t -> Text - - -- | Strip the type of its outermost layer. - -- - -- This allows us to strip lambda or command type - -- and get the type of the bound variable. - getInnerType :: t -> t - - -- | Check if this type is same as the given 'Polytype'. - -- - -- We use it to not print same type twice (e.g. inferred and generic). - eq :: t -> Polytype -> Bool - -instance ExplainableType () where - prettyType = const "?" - getInnerType = id - eq _ _ = False - -instance ExplainableType Polytype where - prettyType = prettyText - getInnerType = fmap $ \case - (l :->: _r) -> l - (TyCmd t) -> t - t -> t - eq = (==) - -explain :: ExplainableType ty => Syntax' ty -> Tree Text -explain trm = case trm ^. sTerm of - TUnit -> literal "The unit value." - TConst c -> literal . constGenSig c $ briefDoc (constDoc $ constInfo c) - TDir {} -> literal "A direction literal." - TInt {} -> literal "An integer literal." - TText {} -> literal "A text literal." - TBool {} -> literal "A boolean literal." - TVar v -> pure $ typeSignature v ty "" - SRcd {} -> literal "A record literal." - SProj {} -> literal "A record projection." - -- type ascription - SAnnotate lhs typeAnn -> - Node - (typeSignature "_" typeAnn "A type ascription for") - [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." - SRequirements {} -> pure "Query the requirements of a term." - -- definition or bindings - SLet isRecursive var mTypeAnn rhs _b -> pure $ explainDefinition False isRecursive var (rhs ^. sType) mTypeAnn - SDef isRecursive var mTypeAnn rhs -> pure $ explainDefinition True isRecursive var (rhs ^. sType) mTypeAnn - SLam (LV _s v) _mType _syn -> - pure $ - typeSignature v ty $ - "A lambda expression binding the variable " <> U.bquote v <> "." - SBind mv rhs _cmds -> - pure $ - typeSignature (maybe "__rhs" lvVar mv) (getInnerType $ rhs ^. sType) $ - "A monadic bind for commands" <> maybe "." (\(LV _s v) -> ", that binds variable " <> U.bquote v <> ".") mv - -- composite types - SPair {} -> - Node - (typeSignature "_" ty "A tuple consisting of:") - (explain <$> unTuple trm) - SDelay {} -> - pure . T.unlines $ - [ "Delay evaluation of a term, written `{...}`." - , "" - , "Swarm is an eager language, but in some cases (e.g. for `if` statements and recursive bindings) we need to delay evaluation." - , "" - , "The counterpart to `{...}` is `force`:" - , "```" - , "force {t} = t" - , "```" - ] - -- internal syntax that should not actually show in hover - 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." - TRobot {} -> internal "A robot reference." - where - ty = trm ^. sType - literal = pure . typeSignature (prettyText . void $ trm ^. sTerm) ty - 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 - --- | Helper function to explain function application. --- --- Note that 'Force' is often inserted internally, so --- if it shows up here we drop it. -explainFunction :: ExplainableType ty => Syntax' ty -> Tree Text -explainFunction s = - case unfoldApps s of - (Syntax' _ (TConst Force) _ :| [innerT]) -> explain innerT - (Syntax' _ (TConst Force) _ :| f : params) -> explainF f params - (f :| params) -> explainF f params - where - explainF f params = - Node - "Function application of:" - [ explain f - , Node - "with parameters:" - (map explain params) - ] - -explainDefinition :: ExplainableType ty => Bool -> Bool -> LocVar -> ty -> Maybe Polytype -> Text -explainDefinition isDef isRecursive (LV _s var) ty maybeTypeAnnotation = - typeSignature var ty $ - T.unwords - [ "A" - , (if isRecursive then "" else "non-") <> "recursive" - , if isDef then "definition" else "let" - , "expression" - , if null maybeTypeAnnotation then "without" else "with" - , "a type annotation on the variable." - ] - -typeSignature :: ExplainableType ty => Var -> ty -> Text -> Text -typeSignature v typ body = T.unlines ["```", short, "```", body] - where - short = v <> ": " <> prettyType typ diff --git a/src/Swarm/Language/LSP/VarUsage.hs b/src/Swarm/Language/LSP/VarUsage.hs deleted file mode 100644 --- a/src/Swarm/Language/LSP/VarUsage.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Language.LSP.VarUsage where - -import Control.Monad (guard) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Set (Set) -import Data.Set qualified as S -import Data.Text (Text) -import Data.Text qualified as T -import Language.LSP.Types qualified as J -import Swarm.Language.Parse qualified as P -import Swarm.Language.Syntax -import Swarm.Util qualified as U - -data BindingType - = Lambda - | Let - | Bind - deriving (Eq, Show) - -data VarUsage = VarUsage LocVar BindingType - -type BindingSites = Map Var (NonEmpty SrcLoc) - -data Usage = Usage - { usages :: Set LocVar - -- ^ Variable references - , problems :: [VarUsage] - -- ^ Variable declarations without any references - } - -instance Semigroup Usage where - Usage y1 z1 <> Usage y2 z2 = - Usage - (y1 <> y2) - (z1 <> z2) - -instance Monoid Usage where - mempty = Usage mempty mempty - -toErrPos :: Text -> VarUsage -> Maybe (J.Range, Text) -toErrPos code (VarUsage (LV loc v) scope) = do - -- A leading underscore will suppress the unused variable warning - guard $ not $ "_" `T.isPrefixOf` v - rangePair <- case loc of - SrcLoc s e -> Just (s, e) - _ -> Nothing - let (start, end) = P.getLocRange code rangePair - ((startLine, startCol), (endLine, endCol)) = (minusOne start, minusOne end) - range = - J.Range - (J.Position (fromIntegral startLine) (fromIntegral startCol)) - (J.Position (fromIntegral endLine) (fromIntegral endCol)) - return (range, txt) - where - txt = - T.unwords - [ "Unused variable" - , U.quote v - , "in" - , T.pack $ show scope - , "expression" - ] - minusOne (x, y) = (x - 1, y - 1) - --- | Descends the syntax tree rooted at a variable declaration, --- accumulating variable references. --- Generates a "problem" if an associated variable reference --- is not encountered in the subtree for this declaration. -checkOccurrences :: - BindingSites -> - LocVar -> - BindingType -> - [Syntax] -> - Usage -checkOccurrences bindings lv@(LV loc v) declType childSyntaxes = - Usage childUsages $ missing <> deeperMissing - where - deeperBindings = M.insertWith (<>) v (pure loc) bindings - Usage childUsages deeperMissing = mconcat $ map (getUsage deeperBindings) childSyntaxes - missing = [VarUsage lv declType | lv `S.notMember` childUsages] - --- | Build up the bindings map as a function argument as --- we descend into the syntax tree. --- Aggregates unused bindings as we return from each layer. -getUsage :: - BindingSites -> - Syntax -> - Usage -getUsage bindings (Syntax _pos t) = case t of - TVar v -> Usage myUsages mempty - where - myUsages = case M.lookup v bindings of - Nothing -> mempty - Just (loc :| _) -> S.singleton $ LV loc v - SLam v _ s -> checkOccurrences bindings v Lambda [s] - SApp s1 s2 -> getUsage bindings s1 <> getUsage bindings s2 - SLet _ v _ s1 s2 -> getUsage bindings s1 <> checkOccurrences bindings v Let [s2] - SPair s1 s2 -> getUsage bindings s1 <> getUsage bindings s2 - SDef _ _v _ s -> getUsage bindings s - 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 diff --git a/src/Swarm/Language/Module.hs b/src/Swarm/Language/Module.hs deleted file mode 100644 --- a/src/Swarm/Language/Module.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A 'Module' packages together a type-annotated syntax tree along --- with a context of top-level definitions. -module Swarm.Language.Module ( - -- * Modules - Module (..), - TModule, - UModule, - trivMod, -) where - -import Data.Data (Data) -import Data.Yaml (FromJSON, ToJSON) -import GHC.Generics (Generic) -import Swarm.Language.Context (Ctx, empty) -import Swarm.Language.Syntax (Syntax') -import Swarm.Language.Types (Polytype, UPolytype, UType) - ------------------------------------------------------------- --- Modules ------------------------------------------------------------- - --- | A module generally represents the result of performing type --- inference on a top-level expression, which in particular can --- contain definitions ('Swarm.Language.Syntax.TDef'). A module --- contains the type-annotated AST of the expression itself, as well --- as the context giving the types of any defined variables. -data Module s t = Module {moduleAST :: Syntax' s, moduleCtx :: Ctx t} - deriving (Show, Eq, Functor, Data, Generic, FromJSON, ToJSON) - --- | A 'TModule' is the final result of the type inference process on --- an expression: we get a polytype for the expression, and a --- context of polytypes for the defined variables. -type TModule = Module Polytype Polytype - --- | A 'UModule' represents the type of an expression at some --- intermediate stage during the type inference process. We get a --- 'UType' (/not/ a 'UPolytype') for the expression, which may --- contain some free unification or type variables, as well as a --- context of 'UPolytype's for any defined variables. -type UModule = Module UType UPolytype - --- | The trivial module for a given AST, with the empty context. -trivMod :: Syntax' s -> Module s t -trivMod t = Module t empty diff --git a/src/Swarm/Language/Parse.hs b/src/Swarm/Language/Parse.hs deleted file mode 100644 --- a/src/Swarm/Language/Parse.hs +++ /dev/null @@ -1,585 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Parser for the Swarm language. Note, you probably don't want to --- use this directly, unless there is a good reason to parse a term --- without also type checking it; use --- 'Swarm.Language.Pipeline.processTerm' instead, which parses, --- typechecks, elaborates, and capability checks a term all at once. -module Swarm.Language.Parse ( - -- * Reserved words - reservedWords, - - -- * Parsers - Parser, - parsePolytype, - parseType, - parseTerm, - binOps, - unOps, - - -- * Utility functions - runParser, - runParserTH, - readTerm, - readTerm', - showShortError, - showErrorPos, - getLocRange, - unTuple, -) where - -import Control.Lens (view, (^.)) -import Control.Monad (guard, join) -import Control.Monad.Combinators.Expr -import Control.Monad.Reader ( - MonadReader (ask), - ReaderT (runReaderT), - ) -import Data.Bifunctor -import Data.Foldable (asum) -import Data.List (foldl', nub) -import Data.List.NonEmpty qualified (head) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Set qualified as S -import Data.Set.Lens (setOf) -import Data.Text (Text, index, toLower) -import Data.Text qualified as T -import Data.Void -import Swarm.Language.Syntax -import Swarm.Language.Types -import Swarm.Util (failT, findDup, squote) -import Swarm.Util.Parse (fully, fullyMaybe) -import Text.Megaparsec hiding (runParser) -import Text.Megaparsec.Char -import Text.Megaparsec.Char.Lexer qualified as L -import Text.Megaparsec.Pos qualified as Pos -import Witch - --- Imports for doctests (cabal-docspec needs this) - --- $setup --- >>> import qualified Data.Map.Strict as Map - --- | When parsing a term using a quasiquoter (i.e. something in the --- Swarm source code that will be parsed at compile time), we want --- to allow antiquoting, i.e. writing something like $x to refer to --- an existing Haskell variable. But when parsing a term entered by --- the user at the REPL, we do not want to allow this syntax. -data Antiquoting = AllowAntiquoting | DisallowAntiquoting - deriving (Eq, Ord, Show) - -type Parser = ReaderT Antiquoting (Parsec Void Text) - -type ParserError = ParseErrorBundle Text Void - --------------------------------------------------- --- Lexer - --- | List of reserved words that cannot be used as variable names. -reservedWords :: [Text] -reservedWords = - map (syntax . constInfo) (filter isUserFunc allConst) - ++ map directionSyntax allDirs - ++ [ "void" - , "unit" - , "int" - , "text" - , "dir" - , "bool" - , "actor" - , "key" - , "cmd" - , "delay" - , "let" - , "def" - , "end" - , "in" - , "true" - , "false" - , "forall" - , "require" - , "requirements" - ] - --- | Skip spaces and comments. -sc :: Parser () -sc = - L.space - space1 - (L.skipLineComment "//") - (L.skipBlockComment "/*" "*/") - --- | In general, we follow the convention that every token parser --- assumes no leading whitespace and consumes all trailing --- whitespace. Concretely, we achieve this by wrapping every token --- parser using 'lexeme'. -lexeme :: Parser a -> Parser a -lexeme = L.lexeme sc - --- | A lexeme consisting of a literal string. -symbol :: Text -> Parser Text -symbol = L.symbol sc - --- | Parse a case-insensitive reserved word, making sure it is not a --- prefix of a longer variable name, and allowing the parser to --- backtrack if it fails. -reserved :: Text -> Parser () -reserved w = (lexeme . try) $ string' w *> notFollowedBy (alphaNumChar <|> char '_') - --- | Parse an identifier, i.e. any non-reserved string containing --- alphanumeric characters and underscores and not starting with a --- number. -identifier :: Parser Var -identifier = lvVar <$> locIdentifier - --- | Parse an identifier together with its source location info. -locIdentifier :: Parser LocVar -locIdentifier = uncurry LV <$> parseLocG ((lexeme . try) (p >>= check) "variable name") - where - p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'') - check (into @Text -> t) - | toLower t `elem` reservedWords = - failT ["reserved word", squote t, "cannot be used as variable name"] - | otherwise = return t - --- | Parse a text literal (including escape sequences) in double quotes. -textLiteral :: Parser Text -textLiteral = into <$> lexeme (char '"' >> manyTill L.charLiteral (char '"')) - --- | Parse a positive integer literal token, in decimal, binary, --- octal, or hexadecimal notation. Note that negation is handled as --- a separate operator. -integer :: Parser Integer -integer = - label "integer literal" $ - lexeme $ do - n <- - string "0b" *> L.binary - <|> string "0o" *> L.octal - <|> string "0x" *> L.hexadecimal - <|> L.decimal - notFollowedBy alphaNumChar - return n - -braces :: Parser a -> Parser a -braces = between (symbol "{") (symbol "}") - -parens :: Parser a -> Parser a -parens = between (symbol "(") (symbol ")") - -brackets :: Parser a -> Parser a -brackets = between (symbol "[") (symbol "]") - --------------------------------------------------- --- Parser - --- | 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 = - join $ - quantify - <$> (fromMaybe [] <$> optional (reserved "forall" *> some identifier <* 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 - --- | Parse a Swarm language (mono)type. -parseType :: Parser Type -parseType = makeExprParser parseTypeAtom table - where - table = - [ [InfixR ((:*:) <$ symbol "*")] - , [InfixR ((:+:) <$ symbol "+")] - , [InfixR ((:->:) <$ symbol "->")] - ] - -parseTypeAtom :: Parser Type -parseTypeAtom = - TyVoid <$ reserved "void" - <|> TyUnit <$ reserved "unit" - <|> TyVar <$> identifier - <|> TyInt <$ reserved "int" - <|> TyText <$ reserved "text" - <|> TyDir <$ reserved "dir" - <|> TyBool <$ reserved "bool" - <|> TyActor <$ reserved "actor" - <|> TyKey <$ reserved "key" - <|> TyCmd <$> (reserved "cmd" *> parseTypeAtom) - <|> TyDelay <$> braces parseType - <|> TyRcd <$> brackets (parseRecord (symbol ":" *> parseType)) - <|> parens parseType - -parseRecord :: Parser a -> Parser (Map Var a) -parseRecord p = (parseBinding `sepBy` symbol ",") >>= fromListUnique - where - parseBinding = (,) <$> identifier <*> p - fromListUnique kvs = case findDup (map fst kvs) of - Nothing -> return $ Map.fromList kvs - Just x -> failT ["duplicate field name", squote x, "in record literal"] - -parseDirection :: Parser Direction -parseDirection = asum (map alternative allDirs) "direction constant" - where - alternative d = d <$ (reserved . directionSyntax) d - --- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@) -parseConst :: Parser Const -parseConst = asum (map alternative consts) "built-in user function" - where - consts = filter isUserFunc allConst - alternative c = c <$ reserved (syntax $ constInfo c) - --- | Add 'SrcLoc' to a parser -parseLocG :: Parser a -> Parser (SrcLoc, a) -parseLocG pa = do - start <- getOffset - a <- pa - end <- getOffset - pure (SrcLoc start end, a) - --- | Add 'SrcLoc' to a 'Term' parser -parseLoc :: Parser Term -> Parser Syntax -parseLoc pterm = uncurry Syntax <$> parseLocG pterm - --- | 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 -parseTermAtom = do - s1 <- parseTermAtom2 - ps <- many (symbol "." *> parseLocG identifier) - return $ foldl' (\(Syntax l1 t) (l2, x) -> Syntax (l1 <> l2) (TProj t x)) s1 ps - --- | Parse an atomic term. -parseTermAtom2 :: Parser Syntax -parseTermAtom2 = - parseLoc - ( TUnit <$ symbol "()" - <|> TConst <$> parseConst - <|> TVar <$> identifier - <|> TDir <$> parseDirection - <|> 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") - ) - ) - <|> uncurry SRequirements <$> (reserved "requirements" *> match parseTerm) - <|> SLam - <$> (symbol "\\" *> locIdentifier) - <*> optional (symbol ":" *> parseType) - <*> (symbol "." *> parseTerm) - <|> sLet - <$> (reserved "let" *> locIdentifier) - <*> optional (symbol ":" *> parsePolytype) - <*> (symbol "=" *> parseTerm) - <*> (reserved "in" *> parseTerm) - <|> sDef - <$> (reserved "def" *> locIdentifier) - <*> optional (symbol ":" *> parsePolytype) - <*> (symbol "=" *> parseTerm <* reserved "end") - <|> SRcd <$> brackets (parseRecord (optional (symbol "=" *> parseTerm))) - <|> parens (view sTerm . mkTuple <$> (parseTerm `sepBy` symbol ",")) - ) - -- Potential syntax for explicitly requesting memoized delay. - -- Perhaps we will not need this in the end; see the discussion at - -- https://github.com/swarm-game/swarm/issues/150 . - -- <|> parseLoc (TDelay SimpleDelay (TConst Noop) <$ try (symbol "{{" *> symbol "}}")) - -- <|> parseLoc (SDelay MemoizedDelay <$> dbraces parseTerm) - - <|> parseLoc (TDelay SimpleDelay (TConst Noop) <$ try (symbol "{" *> symbol "}")) - <|> parseLoc (SDelay SimpleDelay <$> braces parseTerm) - <|> parseLoc (ask >>= (guard . (== AllowAntiquoting)) >> parseAntiquotation) - -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) - -unTuple :: Syntax' ty -> [Syntax' ty] -unTuple = \case - Syntax' _ (SPair s1 s2) _ -> s1 : unTuple s2 - s -> [s] - --- | Construct an 'SLet', automatically filling in the Boolean field --- indicating whether it is recursive. -sLet :: LocVar -> Maybe Polytype -> Syntax -> Syntax -> Term -sLet x ty t1 = SLet (lvVar x `S.member` setOf freeVarsV t1) x ty t1 - --- | Construct an 'SDef', automatically filling in the Boolean field --- indicating whether it is recursive. -sDef :: LocVar -> Maybe Polytype -> Syntax -> Term -sDef x ty t = SDef (lvVar x `S.member` setOf freeVarsV t) x ty t - -parseAntiquotation :: Parser Term -parseAntiquotation = - TAntiText <$> (lexeme . try) (symbol "$str:" *> identifier) - <|> TAntiInt <$> (lexeme . try) (symbol "$int:" *> identifier) - --- | Parse a Swarm language term. -parseTerm :: Parser Syntax -parseTerm = sepEndBy1 parseStmt (symbol ";") >>= mkBindChain - -mkBindChain :: [Stmt] -> Parser Syntax -mkBindChain stmts = case last stmts of - Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Return) (TVar (lvVar x)))) stmts - BareTerm t -> return $ foldr mkBind t (init stmts) - where - mkBind (BareTerm t1) t2 = loc Nothing t1 t2 $ SBind Nothing t1 t2 - mkBind (Binder x t1) t2 = loc (Just x) t1 t2 $ SBind (Just x) t1 t2 - loc mx a b = Syntax $ maybe NoLoc lvSrcLoc mx <> (a ^. sLoc) <> (b ^. sLoc) - -data Stmt - = BareTerm Syntax - | Binder LocVar Syntax - deriving (Show) - -parseStmt :: Parser Stmt -parseStmt = - mkStmt <$> optional (try (locIdentifier <* symbol "<-")) <*> parseExpr - -mkStmt :: Maybe LocVar -> Syntax -> Stmt -mkStmt Nothing = BareTerm -mkStmt (Just x) = Binder x - --- | When semicolons are missing between definitions, for example: --- def a = 1 end def b = 2 end def c = 3 end --- The makeExprParser produces: --- App (App (TDef a) (TDef b)) (TDef x) --- This function fix that by converting the Apps into Binds, so that it results in: --- Bind a (Bind b (Bind c)) -fixDefMissingSemis :: Syntax -> Syntax -fixDefMissingSemis term = - case nestedDefs term [] of - [] -> term - defs -> foldr1 mkBind defs - where - mkBind t1 t2 = Syntax ((t1 ^. sLoc) <> (t2 ^. sLoc)) $ SBind Nothing t1 t2 - nestedDefs term' acc = case term' of - def@(Syntax _ SDef {}) -> def : acc - (Syntax _ (SApp nestedTerm def@(Syntax _ SDef {}))) -> nestedDefs nestedTerm (def : acc) - -- Otherwise returns an empty list to keep the term unchanged - _ -> [] - -parseExpr :: Parser Syntax -parseExpr = - parseLoc $ ascribe <$> parseExpr' <*> optional (symbol ":" *> parsePolytype) - where - ascribe :: Syntax -> Maybe Polytype -> Term - ascribe s Nothing = s ^. sTerm - ascribe s (Just ty) = SAnnotate s ty - -parseExpr' :: Parser Syntax -parseExpr' = fixDefMissingSemis <$> makeExprParser parseTermAtom table - where - table = snd <$> Map.toDescList tableMap - tableMap = - Map.unionsWith - (++) - [ Map.singleton 9 [InfixL (exprLoc2 $ SApp <$ string "")] - , binOps - , unOps - ] - - -- add location for ExprParser by combining all - exprLoc2 :: Parser (Syntax -> Syntax -> Term) -> Parser (Syntax -> Syntax -> Syntax) - exprLoc2 p = do - (l, f) <- parseLocG p - pure $ \s1 s2 -> Syntax (l <> (s1 ^. sLoc) <> (s2 ^. sLoc)) $ f s1 s2 - --- | Precedences and parsers of binary operators. --- --- >>> Map.map length binOps --- fromList [(0,1),(2,1),(3,1),(4,6),(6,3),(7,2),(8,1)] -binOps :: Map.Map Int [Operator Parser Syntax] -binOps = Map.unionsWith (++) $ mapMaybe binOpToTuple allConst - where - binOpToTuple c = do - let ci = constInfo c - ConstMBinOp assoc <- pure (constMeta ci) - let assI = case assoc of - L -> InfixL - N -> InfixN - R -> InfixR - pure $ - Map.singleton - (fixity ci) - [assI (mkOp c <$ operatorString (syntax ci))] - --- | Precedences and parsers of unary operators (currently only 'Neg'). --- --- >>> Map.map length unOps --- fromList [(7,1)] -unOps :: Map.Map Int [Operator Parser Syntax] -unOps = Map.unionsWith (++) $ mapMaybe unOpToTuple allConst - where - unOpToTuple c = do - let ci = constInfo c - ConstMUnOp assoc <- pure (constMeta ci) - let assI = case assoc of - P -> Prefix - S -> Postfix - pure $ - Map.singleton - (fixity ci) - [assI (exprLoc1 $ SApp (noLoc $ TConst c) <$ operatorString (syntax ci))] - - -- combine location for ExprParser - exprLoc1 :: Parser (Syntax -> Term) -> Parser (Syntax -> Syntax) - exprLoc1 p = do - (l, f) <- parseLocG p - pure $ \s -> Syntax (l <> s ^. sLoc) $ f s - -operatorString :: Text -> Parser Text -operatorString n = (lexeme . try) (string n <* notFollowedBy operatorSymbol) - -operatorSymbol :: Parser Text -operatorSymbol = T.singleton <$> oneOf opChars - where - isOp = \case { ConstMFunc {} -> False; _ -> True } . constMeta - opChars = nub . concatMap (from . syntax) . filter isOp $ map constInfo allConst - --------------------------------------------------- --- Utilities - --- | Run a parser on some input text, returning either the result or a --- pretty-printed parse error message. -runParser :: Parser a -> Text -> Either Text a -runParser p t = first (from . errorBundlePretty) (parse (runReaderT p DisallowAntiquoting) "" t) - --- | 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.Parse.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 = - case snd (runParser' (runReaderT (fully sc p) AllowAntiquoting) initState) of - Left err -> fail $ errorBundlePretty err - Right e -> return e - where - -- This is annoying --- megaparsec does not export its function to - -- construct an initial parser state, so we can't just use that - -- and then change the one field we need to be different (the - -- 'pstateSourcePos'). We have to copy-paste the whole thing. - initState :: State Text Void - initState = - State - { stateInput = from s - , stateOffset = 0 - , statePosState = - PosState - { pstateInput = from s - , pstateOffset = 0 - , pstateSourcePos = SourcePos file (mkPos line) (mkPos col) - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" - } - , stateParseErrors = [] - } - --- | 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 either the resulting 'Term' (or --- 'Nothing' if the input was only whitespace) or a pretty-printed --- parse error message. -readTerm :: Text -> Either Text (Maybe Syntax) -readTerm = runParser (fullyMaybe sc parseTerm) - --- | A lower-level `readTerm` which returns the megaparsec bundle error --- for precise error reporting. -readTerm' :: Text -> Either ParserError (Maybe Syntax) -readTerm' = parse (runReaderT (fullyMaybe sc parseTerm) DisallowAntiquoting) "" - --- | A utility for converting a ParserError into a one line message: --- @: @ -showShortError :: ParserError -> String -showShortError pe = show (line + 1) <> ": " <> from msg - where - ((line, _), _, msg) = showErrorPos pe - --- | A utility for converting a ParseError into a range and error message. -showErrorPos :: ParserError -> ((Int, Int), (Int, Int), Text) -showErrorPos (ParseErrorBundle errs sourcePS) = (minusOne start, minusOne end, from msg) - where - -- convert megaparsec source pos to starts at 0 - minusOne (x, y) = (x - 1, y - 1) - - -- get the first error position (ps) and line content (str) - err = Data.List.NonEmpty.head errs - offset = case err of - TrivialError x _ _ -> x - FancyError x _ -> x - (str, ps) = reachOffset offset sourcePS - msg = parseErrorTextPretty err - - -- extract the error starting position - start@(line, col) = getLineCol ps - - -- compute the ending position based on the word at starting position - wordlength = case break (== ' ') . drop col <$> str of - Just (word, _) -> length word + 1 - _ -> 0 - end = (line, col + wordlength) - -getLineCol :: PosState a -> (Int, Int) -getLineCol ps = (line, col) - where - line = unPos $ sourceLine $ pstateSourcePos ps - col = unPos $ sourceColumn $ pstateSourcePos ps - --- | A utility for converting a SrcLoc into a range -getLocRange :: Text -> (Int, Int) -> ((Int, Int), (Int, Int)) -getLocRange code (locStart, locEnd) = (start, end) - where - start = getLocPos locStart - end = getLocPos (dropWhiteSpace locEnd) - - -- remove trailing whitespace that got included by the lexer - dropWhiteSpace offset - | isWhiteSpace offset = dropWhiteSpace (offset - 1) - | otherwise = offset - isWhiteSpace offset = - -- Megaparsec offset needs to be (-1) to start at 0 - Data.Text.index code (offset - 1) `elem` [' ', '\n', '\r', '\t'] - - -- using megaparsec offset facility, compute the line/col - getLocPos offset = - let sourcePS = - PosState - { pstateInput = code - , pstateOffset = 0 - , pstateSourcePos = Pos.initialPos "" - , pstateTabWidth = Pos.defaultTabWidth - , pstateLinePrefix = "" - } - (_, ps) = reachOffset offset sourcePS - in getLineCol ps diff --git a/src/Swarm/Language/Parse/QQ.hs b/src/Swarm/Language/Parse/QQ.hs deleted file mode 100644 --- a/src/Swarm/Language/Parse/QQ.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A quasiquoter for Swarm polytypes. -module Swarm.Language.Parse.QQ (tyQ) where - -import Data.Generics -import Language.Haskell.TH qualified as TH -import Language.Haskell.TH.Quote -import Swarm.Language.Parse -import Swarm.Util (liftText) - ------------------------------------------------------------- --- Quasiquoters ------------------------------------------------------------- - --- | A quasiquoter for Swarm polytypes, so we can conveniently write them --- down using concrete syntax and have them parsed into abstract --- syntax at compile time. This is used, for example, in writing down --- the concrete types of constants (see "Swarm.Language.Typecheck"). -tyQ :: QuasiQuoter -tyQ = - QuasiQuoter - { quoteExp = quoteTypeExp - , quotePat = error "quotePat not implemented for polytypes" - , quoteType = error "quoteType not implemented for polytypes" - , quoteDec = error "quoteDec not implemented for polytypes" - } - -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 parsePolytype s - dataToExpQ (fmap liftText . cast) parsed diff --git a/src/Swarm/Language/Pipeline.hs b/src/Swarm/Language/Pipeline.hs deleted file mode 100644 --- a/src/Swarm/Language/Pipeline.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Some convenient functions for putting together the whole Swarm --- language processing pipeline: parsing, type checking, capability --- checking, and elaboration. If you want to simply turn some raw --- text representing a Swarm program into something useful, this is --- probably the module you want. -module Swarm.Language.Pipeline ( - ProcessedTerm (..), - processTerm, - processParsedTerm, - processTerm', - processParsedTerm', - processTermEither, -) where - -import Control.Lens ((^.)) -import Data.Bifunctor (first) -import Data.Data (Data) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Yaml as Y -import GHC.Generics (Generic) -import Swarm.Language.Context -import Swarm.Language.Elaborate -import Swarm.Language.Module -import Swarm.Language.Parse -import Swarm.Language.Pretty -import Swarm.Language.Requirement -import Swarm.Language.Syntax -import Swarm.Language.Typecheck -import Swarm.Language.Types -import Witch (into) - --- | A record containing the results of the language processing --- pipeline. Put a 'Term' in, and get one of these out. A --- 'ProcessedTerm' contains: --- --- * The elaborated + type-annotated term, plus the types of any --- embedded definitions ('TModule') --- --- * The 'Requirements' of the term --- --- * The requirements context for any definitions embedded in the --- term ('ReqCtx') -data ProcessedTerm = ProcessedTerm TModule Requirements ReqCtx - deriving (Data, Show, Eq, Generic) - -processTermEither :: Text -> Either Text ProcessedTerm -processTermEither t = case processTerm t of - Left err -> Left $ T.unwords ["Could not parse term:", err] - Right Nothing -> Left "Term was only whitespace" - Right (Just pt) -> Right pt - -instance FromJSON ProcessedTerm where - parseJSON = withText "Term" $ either (fail . into @String) return . processTermEither - -instance ToJSON ProcessedTerm where - toJSON (ProcessedTerm t _ _) = String $ prettyText (moduleAST t) - --- | Given a 'Text' value representing a Swarm program, --- --- 1. Parse it (see "Swarm.Language.Parse") --- 2. Typecheck it (see "Swarm.Language.Typecheck") --- 3. Elaborate it (see "Swarm.Language.Elaborate") --- 4. Check what capabilities it requires (see "Swarm.Language.Capability") --- --- Return either the end result (or @Nothing@ if the input was only --- whitespace) or a pretty-printed error message. -processTerm :: Text -> Either Text (Maybe ProcessedTerm) -processTerm = processTerm' empty empty - --- | Like 'processTerm', but use a term that has already been parsed. -processParsedTerm :: Syntax -> Either ContextualTypeErr ProcessedTerm -processParsedTerm = processParsedTerm' empty empty - --- | Like 'processTerm', but use explicit starting contexts. -processTerm' :: TCtx -> ReqCtx -> Text -> Either Text (Maybe ProcessedTerm) -processTerm' ctx capCtx txt = do - mt <- readTerm txt - first (prettyTypeErrText txt) $ traverse (processParsedTerm' ctx capCtx) mt - --- | Like 'processTerm'', but use a term that has already been parsed. -processParsedTerm' :: TCtx -> ReqCtx -> Syntax -> Either ContextualTypeErr ProcessedTerm -processParsedTerm' ctx capCtx t = do - m <- inferTop ctx t - let (caps, capCtx') = requirements capCtx (t ^. sTerm) - return $ ProcessedTerm (elaborateModule m) caps capCtx' - -elaborateModule :: TModule -> TModule -elaborateModule (Module ast ctx) = Module (elaborate ast) ctx diff --git a/src/Swarm/Language/Pipeline/QQ.hs b/src/Swarm/Language/Pipeline/QQ.hs deleted file mode 100644 --- a/src/Swarm/Language/Pipeline/QQ.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A quasiquoter for Swarm terms. -module Swarm.Language.Pipeline.QQ (tmQ) where - -import Data.Generics -import Language.Haskell.TH qualified as TH -import Language.Haskell.TH.Quote -import Swarm.Language.Parse -import Swarm.Language.Pipeline -import Swarm.Language.Pretty -import Swarm.Language.Syntax -import Swarm.Language.Types (Polytype) -import Swarm.Util (failT, liftText) -import Witch (from) - --- | A quasiquoter for Swarm language terms, so we can conveniently --- write them down using concrete syntax and have them parsed into --- abstract syntax at compile time. The quasiquoter actually runs --- the entire pipeline on them (parsing, typechecking, elaborating), --- so a quasiquoted Swarm program with a parse error or a type error --- will fail at Haskell compile time. This is useful for creating --- system robot programs (for example, see --- 'Swarm.Game.Step.seedProgram'). -tmQ :: QuasiQuoter -tmQ = - QuasiQuoter - { quoteExp = quoteTermExp - , quotePat = error "quotePat not implemented for terms" - , quoteType = error "quoteType not implemented for terms" - , quoteDec = error "quoteDec not implemented for terms" - } - -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 parseTerm s - case processParsedTerm parsed of - Left err -> failT [prettyTypeErrText (from s) err] - Right ptm -> dataToExpQ ((fmap liftText . cast) `extQ` antiTermExp) ptm - -antiTermExp :: Term' Polytype -> Maybe TH.ExpQ -antiTermExp (TAntiText v) = - Just $ TH.appE (TH.conE (TH.mkName "TText")) (TH.varE (TH.mkName (from v))) -antiTermExp (TAntiInt v) = - Just $ TH.appE (TH.conE (TH.mkName "TInt")) (TH.varE (TH.mkName (from v))) -antiTermExp _ = Nothing - --- At the moment, only antiquotation of literal text and ints are --- supported, because that's what we need for the seedProgram. But --- we can easily add more in the future. diff --git a/src/Swarm/Language/Pretty.hs b/src/Swarm/Language/Pretty.hs deleted file mode 100644 --- a/src/Swarm/Language/Pretty.hs +++ /dev/null @@ -1,447 +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.Unification -import Control.Unification.IntVar -import Data.Bool (bool) -import Data.Functor.Fixedpoint (Fix, unFix) -import Data.List.NonEmpty qualified as NE -import Data.Map.Strict qualified as M -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.Language.Capability -import Swarm.Language.Context -import Swarm.Language.Parse (getLocRange) -import Swarm.Language.Syntax -import Swarm.Language.Typecheck -import Swarm.Language.Types -import Swarm.Util (showEnum, showLowT, unsnocNE) -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 - --- | Pretty-print something and render it as @Text@. -prettyText :: (PrettyPrec a) => a -> Text -prettyText = docToText . 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 - -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 - --------------------------------------------------- --- 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 _ BVoid = "void" - prettyPrec _ BUnit = "unit" - prettyPrec _ BInt = "int" - prettyPrec _ BDir = "dir" - prettyPrec _ BText = "text" - prettyPrec _ BBool = "bool" - prettyPrec _ BActor = "actor" - prettyPrec _ BKey = "key" - -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 _ _ = "_" - --- | 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 -> [t] - -instance UnchainableFun Type where - unchainFun (a :->: ty) = a : unchainFun ty - unchainFun ty = [ty] - -instance UnchainableFun (UTerm TypeF ty) where - unchainFun (UTerm (TyFunF ty1 ty2)) = ty1 : unchainFun ty2 - unchainFun ty = [ty] - -instance (PrettyPrec (t (Fix t))) => PrettyPrec (Fix t) where - prettyPrec p = prettyPrec p . unFix - -instance (PrettyPrec (t (UTerm t v)), PrettyPrec v) => PrettyPrec (UTerm t v) where - prettyPrec p (UTerm t) = prettyPrec p t - prettyPrec p (UVar v) = prettyPrec p v - -instance ((UnchainableFun t), (PrettyPrec t)) => PrettyPrec (TypeF t) where - prettyPrec _ (TyBaseF b) = ppr b - prettyPrec _ (TyVarF v) = pretty v - prettyPrec p (TySumF ty1 ty2) = - pparens (p > 1) $ - prettyPrec 2 ty1 <+> "+" <+> prettyPrec 1 ty2 - prettyPrec p (TyProdF ty1 ty2) = - pparens (p > 2) $ - prettyPrec 3 ty1 <+> "*" <+> prettyPrec 2 ty2 - prettyPrec p (TyCmdF ty) = pparens (p > 9) $ "cmd" <+> prettyPrec 10 ty - prettyPrec _ (TyDelayF ty) = braces $ ppr ty - prettyPrec p (TyFunF ty1 ty2) = - let (iniF, lastF) = unsnocNE $ ty1 NE.:| unchainFun ty2 - funs = (prettyPrec 1 <$> iniF) <> [ppr lastF] - inLine l r = l <+> "->" <+> r - multiLine l r = l <+> "->" <> hardline <> r - in pparens (p > 0) . align $ - flatAlt (concatWith multiLine funs) (concatWith inLine funs) - prettyPrec _ (TyRcdF m) = brackets $ hsep (punctuate "," (map prettyBinding (M.assocs m))) - -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 - -instance PrettyPrec (Syntax' ty) where - prettyPrec p = prettyPrec p . eraseS - -instance PrettyPrec Term where - prettyPrec _ TUnit = "()" - prettyPrec p (TConst c) = prettyPrec p c - prettyPrec _ (TDir d) = ppr d - prettyPrec _ (TInt n) = pretty n - prettyPrec _ (TAntiInt v) = "$int:" <> pretty v - prettyPrec _ (TText s) = fromString (show s) - prettyPrec _ (TAntiText v) = "$str:" <> pretty v - prettyPrec _ (TBool b) = bool "false" "true" b - prettyPrec _ (TRobot r) = " pretty r <> ">" - prettyPrec _ (TRef r) = "@" <> pretty r - prettyPrec p (TRequireDevice d) = pparens (p > 10) $ "require" <+> ppr @Term (TText d) - prettyPrec p (TRequire n e) = pparens (p > 10) $ "require" <+> pretty n <+> ppr @Term (TText e) - prettyPrec p (TRequirements _ e) = pparens (p > 10) $ "requirements" <+> ppr e - prettyPrec _ (TVar s) = pretty s - prettyPrec _ (TDelay _ t) = group . encloseWithIndent 2 lbrace rbrace $ ppr t - prettyPrec _ t@TPair {} = prettyTuple t - prettyPrec p t@(TLam {}) = - pparens (p > 9) $ - prettyLambdas t - -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3 - prettyPrec p (TApp t@(TApp (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 - prettyPrec p (TApp t1 t2) = case t1 of - 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 - prettyPrec _ (TLet _ x mty t1 t2) = - sep - [ prettyDefinition "let" x mty t1 <+> "in" - , ppr t2 - ] - prettyPrec _ (TDef _ x mty t1) = - sep - [ prettyDefinition "def" x mty t1 - , "end" - ] - prettyPrec p (TBind Nothing t1 t2) = - pparens (p > 0) $ - prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2 - prettyPrec p (TBind (Just x) t1 t2) = - pparens (p > 0) $ - pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2 - prettyPrec _ (TRcd m) = brackets $ hsep (punctuate "," (map prettyEquality (M.assocs m))) - prettyPrec _ (TProj t x) = prettyPrec 11 t <> "." <> pretty x - prettyPrec p (TAnnotate t pt) = - pparens (p > 0) $ - prettyPrec 1 t <+> ":" <+> ppr pt - -prettyEquality :: (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann -prettyEquality (x, Nothing) = pretty x -prettyEquality (x, Just t) = pretty x <+> "=" <+> ppr t - -prettyTuple :: Term -> Doc a -prettyTuple = tupled . map ppr . unnestTuple - where - unnestTuple (TPair t1 t2) = t1 : unnestTuple t2 - unnestTuple t = [t] - -prettyDefinition :: Doc ann -> Var -> Maybe Polytype -> Term -> 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 - -prettyPrecApp :: Int -> Term -> Term -> 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 - -prettyLambdas :: Term -> Doc a -prettyLambdas t = hsep (prettyLambda <$> lms) <> softline <> ppr rest - where - (rest, lms) = unchainLambdas t - -unchainLambdas :: Term -> (Term, [(Var, Maybe Type)]) -unchainLambdas = \case - TLam 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 "" tcStack) - ] - where - teLoc = case l of - SrcLoc s e -> (showLoc . fst $ getLocRange code (s, e)) <> ": " - NoLoc -> emptyDoc - showLoc (r, c) = pretty r <> ":" <> pretty c - -instance PrettyPrec TypeErr where - prettyPrec _ = \case - UnifyErr ty1 ty2 -> - "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2 - 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 - Infinite x uty -> - "Infinite type:" <+> ppr x <+> "=" <+> ppr uty - DefNotTopLevel t -> - "Definitions may only be at the top level:" <+> pprCode t - CantInfer t -> - "Couldn't infer the type of term (this shouldn't happen; please report this as a bug!):" <+> pprCode t - 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 - --- | 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 (UTyCmd (UVar {})) = Just $ TyCmdF () -isTopLevelConstructor (UTyDelay (UVar {})) = Just $ TyDelayF () -isTopLevelConstructor (UTySum (UVar {}) (UVar {})) = Just $ TySumF () () -isTopLevelConstructor (UTyProd (UVar {}) (UVar {})) = Just $ TyProdF () () -isTopLevelConstructor (UTyFun (UVar {}) (UVar {})) = Just $ TyFunF () () -isTopLevelConstructor _ = Nothing - --- | Return an English noun phrase describing things with the given --- top-level type constructor. -tyNounPhrase :: TypeF () -> Doc a -tyNounPhrase = \case - TyBaseF b -> baseTyNounPhrase b - TyVarF {} -> "a type variable" - TyCmdF {} -> "a command" - TyDelayF {} -> "a delayed expression" - TySumF {} -> "a sum" - TyProdF {} -> "a pair" - TyFunF {} -> "a function" - TyRcdF {} -> "a record" - --- | 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 _ (TooManyTicks n) = "block could take too many ticks (" <> pretty n <> ")" - prettyPrec _ AtomicDupingThing = "def, let, and lambda are not allowed" - prettyPrec _ (NonSimpleVarType _ ty) = "reference to variable with non-simple type" <+> ppr (prettyTextLine ty) - prettyPrec _ NestedAtomic = "nested atomic block" - prettyPrec _ LongConst = "commands that can take multiple ticks to execute are not allowed" - -instance PrettyPrec LocatedTCFrame where - prettyPrec p (LocatedTCFrame _ f) = prettyPrec p f - -instance PrettyPrec TCFrame where - prettyPrec _ (TCDef x) = "While checking the definition of" <+> pretty x - prettyPrec _ TCBindL = "While checking the left-hand side of a semicolon" - prettyPrec _ TCBindR = "While checking the right-hand side of a semicolon" diff --git a/src/Swarm/Language/Requirement.hs b/src/Swarm/Language/Requirement.hs deleted file mode 100644 --- a/src/Swarm/Language/Requirement.hs +++ /dev/null @@ -1,250 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A requirement is something that is needed in order to successfully --- build a robot running a certain program. -module Swarm.Language.Requirement ( - -- * Requirements - - -- ** The 'Requirement' type - Requirement (..), - - -- ** The 'Requirements' type and utility functions - Requirements (..), - singleton, - singletonCap, - singletonDev, - singletonInv, - insert, - ReqCtx, - - -- * Requirements analysis - requirements, -) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Bifunctor (first) -import Data.Data (Data) -import Data.Hashable (Hashable) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import Data.Set qualified as S -import Data.Text (Text) -import GHC.Generics (Generic) -import Swarm.Language.Capability (Capability (..), constCaps) -import Swarm.Language.Context (Ctx) -import Swarm.Language.Context qualified as Ctx -import Swarm.Language.Syntax - --- | 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. -data Requirement - = -- | Require a specific capability. This must be fulfilled by - -- equipping an appropriate device. Requiring the same - -- capability multiple times is the same as requiring it once. - ReqCap Capability - | -- | Require a specific device to be equipped. Note that at this - -- point it is only a name, and has not been resolved to an actual - -- 'Swarm.Game.Entity.Entity'. That's because programs have to be type- and - -- capability-checked independent of an 'Swarm.Game.Entity.EntityMap'. The name - -- will be looked up at runtime, when actually executing a 'Swarm.Language.Syntax.Build' - -- or 'Swarm.Language.Syntax.Reprogram' command, and an appropriate exception thrown if - -- a device with the given name does not exist. - -- - -- 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 - -- in the inventory. The same comments apply re: resolving the - -- entity name to an actual 'Swarm.Game.Entity.Entity'. - -- - -- Inventory requirements are additive, that is, say, requiring 5 - -- 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) - --- | It is tempting to define @Requirements = Set Requirement@, but --- that would be wrong, since two identical 'ReqInv' should have --- their counts added rather than simply being deduplicated. --- --- Since we will eventually need to deal with the different types of --- requirements separately, it makes sense to store them separately --- anyway. -data Requirements = Requirements - { capReqs :: Set Capability - , devReqs :: Set Text - , invReqs :: Map Text Int - } - deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON) - -instance Semigroup Requirements where - Requirements c1 d1 i1 <> Requirements c2 d2 i2 = - Requirements (c1 <> c2) (d1 <> d2) (M.unionWith (+) i1 i2) - -instance Monoid Requirements where - mempty = Requirements S.empty S.empty M.empty - --- | Create a 'Requirements' set with a single 'Requirement'. -singleton :: Requirement -> Requirements -singleton (ReqCap c) = Requirements (S.singleton c) S.empty M.empty -singleton (ReqDev d) = Requirements S.empty (S.singleton d) M.empty -singleton (ReqInv n e) = Requirements S.empty S.empty (M.singleton e n) - --- | For convenience, create a 'Requirements' set with a single --- 'Capability' requirement. -singletonCap :: Capability -> Requirements -singletonCap = singleton . ReqCap - --- | For convenience, create a 'Requirements' set with a single --- device requirement. -singletonDev :: Text -> Requirements -singletonDev = singleton . ReqDev - --- | For convenience, create a 'Requirements' set with a single --- inventory requirement. -singletonInv :: Int -> Text -> Requirements -singletonInv n e = singleton (ReqInv n e) - -insert :: Requirement -> Requirements -> Requirements -insert = (<>) . singleton - --- | A requirement context records the requirements for the --- definitions bound to variables. -type ReqCtx = Ctx Requirements - --- | Analyze a program to see what capabilities may be needed to --- execute it. Also return a capability context mapping from any --- variables declared via 'TDef' to the capabilities needed by --- their definitions. --- --- Note that this is necessarily a conservative analysis, especially --- if the program contains conditional expressions. Some --- capabilities may end up not being actually needed if certain --- commands end up not being executed. However, the analysis should --- be safe in the sense that a robot with the indicated capabilities --- will always be able to run the given program. -requirements :: ReqCtx -> Term -> (Requirements, ReqCtx) -requirements ctx tm = first (insert (ReqCap CPower)) $ case tm of - -- First, at the top level, we have to keep track of the - -- requirements for variables bound with the 'TDef' command. - - -- To make a definition requires the env capability. Note that the - -- act of MAKING the definition does not require the capabilities of - -- the body of the definition (including the possibility of the - -- recursion capability, if the definition is recursive). However, - -- we also return a map which associates the defined name to the - -- capabilities it requires. - TDef r x _ t -> - let bodyReqs = (if r then insert (ReqCap CRecursion) else id) (requirements' ctx t) - in (singletonCap CEnv, Ctx.singleton x bodyReqs) - TBind _ t1 t2 -> - -- First, see what the requirements are to execute the - -- first command. It may also define some names, so we get a - -- map of those names to their required capabilities. - let (reqs1, ctx1) = requirements ctx t1 - - -- Now see what capabilities are required for the second - -- command; use an extended context since it may refer to - -- things defined in the first command. - ctx' = ctx `Ctx.union` ctx1 - (reqs2, ctx2) = requirements ctx' t2 - in -- Finally return the union of everything. - (reqs1 <> reqs2, ctx' `Ctx.union` ctx2) - -- Any other term can't bind variables with 'TDef', so we no longer - -- need to worry about tracking a returned context. - _ -> (requirements' ctx tm, Ctx.empty) - --- | Infer the requirements to execute/evaluate a term in a --- given context, where the term is guaranteed not to contain any --- 'TDef'. --- --- For function application and let-expressions, we assume that the --- argument (respectively let-bound expression) is used at least --- once in the body. Doing otherwise would require a much more --- fine-grained analysis where we differentiate between the --- capabilities needed to *evaluate* versus *execute* any expression --- (since e.g. an unused let-binding would still incur the --- capabilities to *evaluate* it), which does not seem worth it at --- all. -requirements' :: ReqCtx -> Term -> Requirements -requirements' = go - where - go ctx tm = case tm of - -- Some primitive literals that don't require any special - -- capability. - TUnit -> mempty - TDir d -> if isCardinal d then singletonCap COrient else mempty - TInt _ -> mempty - TAntiInt _ -> mempty - TText _ -> mempty - TAntiText _ -> mempty - TBool _ -> mempty - -- It doesn't require any special capability to *inquire* about - -- the requirements of a term. - TRequirements _ _ -> mempty - -- Look up the capabilities required by a function/command - -- constants using 'constCaps'. - TConst c -> maybe mempty singletonCap (constCaps c) - -- Simply record device or inventory requirements. - TRequireDevice d -> singletonDev d - TRequire n e -> singletonInv n e - -- Note that a variable might not show up in the context, and - -- that's OK. In particular, only variables bound by 'TDef' go - -- in the context; variables bound by a lambda or let will not - -- be there. - TVar x -> fromMaybe mempty (Ctx.lookup x ctx) - -- A lambda expression requires the 'CLambda' capability, and - -- also all the capabilities of the body. We assume that the - -- lambda will eventually get applied, at which point it will - -- indeed require the body's capabilities (this is unnecessarily - -- conservative if the lambda is never applied, but such a - -- program could easily be rewritten without the unused - -- lambda). We also don't do anything with the argument: we - -- assume that it is used at least once within the body, and the - -- capabilities required by any argument will be picked up at - -- the application site. Again, this is overly conservative in - -- the case that the argument is unused, but in that case the - -- unused argument could be removed. - -- - -- Note, however, that we do need to *delete* the argument from - -- the context, in case the context already contains a definition - -- with the same name: inside the lambda that definition will be - -- shadowed, so we do not want the name to be associated to any - -- capabilities. - TLam x _ t -> insert (ReqCap CLambda) $ go (Ctx.delete x ctx) 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. - TApp t1 t2 -> go ctx t1 <> go ctx 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 r x _ t1 t2 -> - (if r then insert (ReqCap CRecursion) else id) $ - insert (ReqCap CEnv) $ - go (Ctx.delete x ctx) t1 <> go (Ctx.delete x ctx) t2 - -- We also delete the name in a TBind, if any, while recursing on - -- the RHS. - TBind mx t1 t2 -> go ctx t1 <> go (maybe id Ctx.delete mx ctx) t2 - -- Everything else is straightforward. - TPair t1 t2 -> insert (ReqCap CProd) $ go ctx t1 <> go ctx t2 - TDelay _ t -> go ctx t - -- This case should never happen if the term has been - -- typechecked; Def commands are only allowed at the top level, - -- so simply returning mempty is safe. - TDef {} -> mempty - TRcd m -> insert (ReqCap CRecord) $ foldMap (go ctx . expandEq) (M.assocs m) - where - expandEq (x, Nothing) = TVar x - expandEq (_, Just t) = t - TProj t _ -> insert (ReqCap CRecord) $ go ctx t - -- A type ascription doesn't change requirements - TAnnotate t _ -> go ctx t diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs deleted file mode 100644 --- a/src/Swarm/Language/Syntax.hs +++ /dev/null @@ -1,1177 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Abstract syntax for terms of the Swarm programming language. -module Swarm.Language.Syntax ( - -- * Directions - Direction (..), - AbsoluteDir (..), - RelativeDir (..), - PlanarRelativeDir (..), - directionSyntax, - isCardinal, - allDirs, - - -- * Constants - Const (..), - allConst, - ConstInfo (..), - ConstDoc (..), - ConstMeta (..), - MBinAssoc (..), - MUnAssoc (..), - constInfo, - arity, - isCmd, - isUserFunc, - isOperator, - isBuiltinFunction, - isTangible, - isLong, - maxSniffRange, - maxScoutRange, - maxStrideRange, - maxPathRange, - - -- * Syntax - Syntax' (..), - sLoc, - sTerm, - sType, - Syntax, - pattern Syntax, - LocVar (..), - SrcLoc (..), - noLoc, - pattern STerm, - pattern TRequirements, - pattern TPair, - pattern TLam, - pattern TApp, - pattern (:$:), - pattern TLet, - pattern TDef, - pattern TBind, - pattern TDelay, - pattern TRcd, - pattern TProj, - pattern TAnnotate, - - -- * Terms - Var, - DelayType (..), - Term' (..), - Term, - mkOp, - mkOp', - unfoldApps, - - -- * Erasure - eraseS, - - -- * Term traversal - freeVarsS, - freeVarsT, - freeVarsV, - mapFreeS, - locVarToSyntax', - asTree, - measureAstSize, -) where - -import Control.Lens (Plated (..), Traversal', makeLenses, para, universe, (%~), (^.)) -import Control.Monad (void) -import Data.Aeson.Types hiding (Key) -import Data.Data (Data) -import Data.Data.Lens (uniplate) -import Data.Int (Int32) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map.Strict (Map) -import Data.Set qualified as S -import Data.String (IsString (fromString)) -import Data.Text hiding (filter, length, map) -import Data.Text qualified as T -import Data.Tree -import GHC.Generics (Generic) -import Swarm.Language.Direction -import Swarm.Language.Types -import Swarm.Util qualified as Util -import Witch.From (from) - --- | Maximum perception distance for --- 'Chirp' and 'Sniff' commands -maxSniffRange :: Int32 -maxSniffRange = 256 - -maxScoutRange :: Int -maxScoutRange = 64 - -maxStrideRange :: Int -maxStrideRange = 64 - -maxPathRange :: Integer -maxPathRange = 128 - ------------------------------------------------------------- --- Constants ------------------------------------------------------------- - --- | Constants, representing various built-in functions and commands. --- --- IF YOU ADD A NEW CONSTANT, be sure to also update: --- 1. the 'constInfo' function (below) --- 2. the capability checker ("Swarm.Language.Capability") --- 3. the type checker ("Swarm.Language.Typecheck") --- 4. the runtime ("Swarm.Game.Step") --- 5. the emacs mode syntax highlighter (@contribs/swarm-mode.el@) --- --- GHC will warn you about incomplete pattern matches for the first --- four, and CI will warn you about the last, so in theory it's not --- really possible to forget. Note you do not need to update the --- parser or pretty-printer, since they are auto-generated from --- 'constInfo'. -data Const - = -- Trivial actions - - -- | Do nothing. This is different than 'Wait' - -- in that it does not take up a time step. - Noop - | -- | Wait for a number of time steps without doing anything. - Wait - | -- | Self-destruct. - Selfdestruct - | -- Basic actions - - -- | Move forward one step. - Move - | -- | Move backward one step. - Backup - | -- | Describe a path to the destination. - Path - | -- | Push an entity forward one step. - Push - | -- | Move forward multiple steps. - Stride - | -- | Turn in some direction. - Turn - | -- | Grab an item from the current location. - Grab - | -- | Harvest an item from the current location. - Harvest - | -- | Ignite a combustible item - Ignite - | -- | Try to place an item at the current location. - Place - | -- | Obtain the relative location of another robot. - Ping - | -- | Give an item to another robot at the current location. - Give - | -- | Equip a device on oneself. - Equip - | -- | Unequip an equipped device, returning to inventory. - Unequip - | -- | Make an item. - Make - | -- | Sense whether we have a certain item. - Has - | -- | Sense whether we have a certain device equipped. - Equipped - | -- | Sense how many of a certain item we have. - Count - | -- | Drill through an entity. - Drill - | -- | Use an entity with another. - Use - | -- | Construct a new robot. - Build - | -- | Deconstruct an old robot. - Salvage - | -- | Reprogram a robot that has executed it's command - -- with a new command - Reprogram - | -- | Emit a message. - Say - | -- | Listen for a message from other robots. - Listen - | -- | Emit a log message. - Log - | -- | View a certain robot. - View - | -- | Set what characters are used for display. - Appear - | -- | Create an entity out of thin air. Only - -- available in creative mode. - Create - | -- | Tell a robot to halt. - Halt - | -- Sensing / generation - - -- | Get current time - Time - | -- Detect whether a robot is within line-of-sight in a direction - Scout - | -- | Get the current x, y coordinates - Whereami - | -- | Get the x, y coordinates of a named waypoint, by index - Waypoint - | -- | Locate the closest instance of a given entity within the rectangle - -- specified by opposite corners, relative to the current location. - Detect - | -- | Count the number of a given entity within the rectangle - -- specified by opposite corners, relative to the current location. - Resonate - | -- | Count the number entities within the rectangle - -- specified by opposite corners, relative to the current location. - Density - | -- | Get the distance to the closest instance of the specified entity. - Sniff - | -- | Get the direction to the closest instance of the specified entity. - Chirp - | -- | Register a location to interrupt a `wait` upon changes - Watch - | -- | Register a (remote) location to interrupt a `wait` upon changes - Surveil - | -- | Get the current heading. - Heading - | -- | See if we can move forward or not. - Blocked - | -- | Scan a nearby cell - Scan - | -- | Upload knowledge to another robot - Upload - | -- | See if a specific entity is here. - Ishere - | -- | Check whether the current cell is empty - Isempty - | -- | Get a reference to oneself - Self - | -- | Get the robot's parent - Parent - | -- | Get a reference to the base - Base - | -- | Meet a nearby robot - Meet - | -- | Meet all nearby robots - MeetAll - | -- | Get the robot's display name - Whoami - | -- | Set the robot's display name - Setname - | -- | Get a uniformly random integer. - Random - | -- Modules - - -- | Run a program loaded from a file. - Run - | -- Language built-ins - - -- | If-expressions. - If - | -- | Left injection. - Inl - | -- | Right injection. - Inr - | -- | Case analysis on a sum type. - Case - | -- | First projection. - Fst - | -- | Second projection. - Snd - | -- | Force a delayed evaluation. - Force - | -- | Return for the cmd monad. - Return - | -- | Try/catch block - Try - | -- | Undefined - Undefined - | -- | User error - Fail - | -- Arithmetic unary operators - - -- | Logical negation. - Not - | -- | Arithmetic negation. - Neg - | -- Comparison operators - - -- | Logical equality comparison - Eq - | -- | Logical unequality comparison - Neq - | -- | Logical lesser-then comparison - Lt - | -- | Logical greater-then comparison - Gt - | -- | Logical lesser-or-equal comparison - Leq - | -- | Logical greater-or-equal comparison - Geq - | -- Arithmetic binary operators - - -- | Logical or. - Or - | -- | Logical and. - And - | -- | Arithmetic addition operator - Add - | -- | Arithmetic subtraction operator - Sub - | -- | Arithmetic multiplication operator - Mul - | -- | Arithmetic division operator - Div - | -- | Arithmetic exponentiation operator - Exp - | -- String operators - - -- | Turn an arbitrary value into a string - Format - | -- | Concatenate string values - Concat - | -- | Count number of characters. - Chars - | -- | Split string into two parts. - Split - | -- | Get the character at an index. - CharAt - | -- | Create a singleton text value with the given character code. - ToChar - | -- Function composition with nice operators - - -- | Application operator - helps to avoid parentheses: - -- @f $ g $ h x = f (g (h x))@ - AppF - | -- Concurrency - - -- | Swap placed entity with one in inventory. Essentially atomic grab and place. - Swap - | -- | When executing @atomic c@, a robot will not be interrupted, - -- that is, no other robots will execute any commands while - -- the robot is executing @c@. - Atomic - | -- | Like @atomic@, but with no restriction on program size. - Instant - | -- Keyboard input - - -- | Create `key` values. - Key - | -- | Install a new keyboard input handler. - InstallKeyHandler - | -- God-like commands that are omnipresent or omniscient. - - -- | Teleport a robot to the given position. - Teleport - | -- | Run a command as if you were another robot. - As - | -- | Find an actor by name. - RobotNamed - | -- | Find an actor by number. - RobotNumbered - | -- | Check if an entity is known. - Knows - deriving (Eq, Ord, Enum, Bounded, Data, Show, Generic, FromJSON, ToJSON, FromJSONKey, ToJSONKey) - -allConst :: [Const] -allConst = Util.listEnums - -data ConstInfo = ConstInfo - { syntax :: Text - , fixity :: Int - , constMeta :: ConstMeta - , constDoc :: ConstDoc - , tangibility :: Tangibility - } - deriving (Eq, Ord, Show) - -data ConstDoc = ConstDoc {briefDoc :: Text, longDoc :: Text} - deriving (Eq, Ord, Show) - -instance IsString ConstDoc where - fromString = flip ConstDoc "" . T.pack - -data ConstMeta - = -- | Function with arity of which some are commands - ConstMFunc Int Bool - | -- | Unary operator with fixity and associativity. - ConstMUnOp MUnAssoc - | -- | Binary operator with fixity and associativity. - ConstMBinOp MBinAssoc - deriving (Eq, Ord, Show) - --- | The meta type representing associativity of binary operator. -data MBinAssoc - = -- | Left associative binary operator (see 'Control.Monad.Combinators.Expr.InfixL') - L - | -- | Non-associative binary operator (see 'Control.Monad.Combinators.Expr.InfixN') - N - | -- | Right associative binary operator (see 'Control.Monad.Combinators.Expr.InfixR') - R - deriving (Eq, Ord, Show) - --- | The meta type representing associativity of unary operator. -data MUnAssoc - = -- | Prefix unary operator (see 'Control.Monad.Combinators.Expr.Prefix') - P - | -- | Suffix unary operator (see 'Control.Monad.Combinators.Expr.Suffix') - S - deriving (Eq, Ord, Show) - --- | Whether a command is tangible or not. Tangible commands have --- some kind of effect on the external world; at most one tangible --- command can be executed per tick. Intangible commands are things --- like sensing commands, or commands that solely modify a robot's --- internal state; multiple intangible commands may be executed per --- tick. In addition, tangible commands can have a 'Length' (either --- 'Short' or 'Long') indicating whether they require only one, or --- possibly more than one, tick to execute. Long commands are --- excluded from @atomic@ blocks to avoid freezing the game. -data Tangibility = Intangible | Tangible Length - deriving (Eq, Ord, Show, Read) - --- | For convenience, @short = Tangible Short@. -short :: Tangibility -short = Tangible Short - --- | For convenience, @long = Tangible Long@. -long :: Tangibility -long = Tangible Long - --- | The length of a tangible command. Short commands take exactly --- one tick to execute. Long commands may require multiple ticks. -data Length = Short | Long - deriving (Eq, Ord, Show, Read, Bounded, Enum) - --- | The arity of a constant, /i.e./ how many arguments it expects. --- The runtime system will collect arguments to a constant (see --- 'Swarm.Language.Value.VCApp') until it has enough, then dispatch --- the constant's behavior. -arity :: Const -> Int -arity c = case constMeta $ constInfo c of - ConstMUnOp {} -> 1 - ConstMBinOp {} -> 2 - ConstMFunc a _ -> a - --- | Whether a constant represents a /command/. Constants which are --- not commands are /functions/ which are interpreted as soon as --- they are evaluated. Commands, on the other hand, are not --- interpreted until being /executed/, that is, when meeting an --- 'FExec' frame. When evaluated, commands simply turn into a --- 'VCApp'. -isCmd :: Const -> Bool -isCmd c = case constMeta $ constInfo c of - ConstMFunc _ cmd -> cmd - _ -> False - --- | Function constants user can call with reserved words ('wait',...). -isUserFunc :: Const -> Bool -isUserFunc c = case constMeta $ constInfo c of - ConstMFunc {} -> True - _ -> False - --- | Whether the constant is an operator. Useful predicate for documentation. -isOperator :: Const -> Bool -isOperator c = case constMeta $ constInfo c of - ConstMUnOp {} -> True - ConstMBinOp {} -> True - ConstMFunc {} -> False - --- | Whether the constant is a /function/ which is interpreted as soon --- as it is evaluated, but *not* including operators. --- --- Note: This is used for documentation purposes and complements 'isCmd' --- and 'isOperator' in that exactly one will accept a given constant. -isBuiltinFunction :: Const -> Bool -isBuiltinFunction c = case constMeta $ constInfo c of - ConstMFunc _ cmd -> not cmd - _ -> False - --- | Whether the constant is a /tangible/ command, that has an --- external effect on the world. At most one tangible command may be --- executed per tick. -isTangible :: Const -> Bool -isTangible c = case tangibility (constInfo c) of - Tangible {} -> True - _ -> False - --- | Whether the constant is a /long/ command, that is, a tangible --- command which could require multiple ticks to execute. Such --- commands cannot be allowed in @atomic@ blocks. -isLong :: Const -> Bool -isLong c = case tangibility (constInfo c) of - Tangible Long -> True - _ -> False - --- | Information about constants used in parsing and pretty printing. --- --- It would be more compact to represent the information by testing --- whether the constants are in certain sets, but using pattern --- matching gives us warning if we add more constants. -constInfo :: Const -> ConstInfo -constInfo c = case c of - Wait -> command 0 long "Wait for a number of time steps." - Noop -> - command 0 Intangible . doc "Do nothing." $ - [ "This is different than `Wait` in that it does not take up a time step." - , "It is useful for commands like if, which requires you to provide both branches." - , "Usually it is automatically inserted where needed, so you do not have to worry about it." - ] - Selfdestruct -> - command 0 short . doc "Self-destruct a robot." $ - [ "Useful to not clutter the world." - , "This destroys the robot's inventory, so consider `salvage` as an alternative." - ] - Move -> command 0 short "Move forward one step." - Backup -> command 0 short "Move backward one step." - Path -> - command 2 short . doc "Obtain shortest path to the destination." $ - [ "Optionally supply a distance limit as the first argument." - , "Supply either a location (`inL`) or an entity (`inR`) as the second argument." - , "If a path exists, returns the direction to proceed along." - ] - Push -> - command 1 short . doc "Push an entity forward one step." $ - [ "Both entity and robot moves forward one step." - , "Destination must not contain an entity." - ] - Stride -> - command 1 short . doc "Move forward multiple steps." $ - [ T.unwords ["Has a max range of", T.pack $ show maxStrideRange, "units."] - ] - Turn -> command 1 short "Turn in some direction." - Grab -> command 0 short "Grab an item from the current location." - Harvest -> - command 0 short . doc "Harvest an item from the current location." $ - [ "Leaves behind a growing seed if the harvested item is growable." - , "Otherwise it works exactly like `grab`." - ] - Ignite -> - command 1 short . doc "Ignite a combustible item in the specified direction." $ - [ "Combustion persists for a random duration and may spread." - ] - Place -> - command 1 short . doc "Place an item at the current location." $ - ["The current location has to be empty for this to work."] - Ping -> - command 1 short . doc "Obtain the relative location of another robot." $ - [ "The other robot must be within transmission range, accounting for antennas installed on either end, and the invoking robot must be oriented in a cardinal direction." - , "The location (x, y) is given relative to one's current orientation:" - , "Positive x value is to the right, negative left. Likewise, positive y value is forward, negative back." - ] - Give -> command 2 short "Give an item to another actor nearby." - Equip -> command 1 short "Equip a device on oneself." - Unequip -> command 1 short "Unequip an equipped device, returning to inventory." - Make -> command 1 long "Make an item using a recipe." - Has -> command 1 Intangible "Sense whether the robot has a given item in its inventory." - Equipped -> command 1 Intangible "Sense whether the robot has a specific device equipped." - Count -> command 1 Intangible "Get the count of a given item in a robot's inventory." - Reprogram -> - command 2 long . doc "Reprogram another robot with a new command." $ - ["The other robot has to be nearby and idle."] - Drill -> - command 1 long . doc "Drill through an entity." $ - [ "Usually you want to `drill forward` when exploring to clear out obstacles." - , "When you have found a source to drill, you can stand on it and `drill down`." - , "See what recipes with drill you have available." - , "The `drill` command may return the name of an entity added to your inventory." - ] - Use -> - command 2 long . doc "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." - ] - Build -> - command 1 long . doc "Construct a new robot." $ - [ "You can specify a command for the robot to execute." - , "If the command requires devices they will be taken from your inventory and " - <> "equipped on the new robot." - ] - Salvage -> - command 0 long . doc "Deconstruct an old robot." $ - ["Salvaging a robot will give you its inventory, equipped devices and log."] - Say -> - command 1 short . doc "Emit a message." $ - [ "The message will be in the robot's log (if it has one) and the global log." - , "You can view the message that would be picked by `listen` from the global log " - <> "in the messages panel, along with your own messages and logs." - , "This means that to see messages from other robots you have to be able to listen for them, " - <> "so once you have a listening device equipped messages will be added to your log." - , "In creative mode, there is of course no such limitation." - ] - Listen -> - command 1 long . doc "Listen for a message from other actors." $ - [ "It will take the first message said by the closest actor." - , "You do not need to actively listen for the message to be logged though, " - <> "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 "Log the string in the robot's logger." - View -> - command 1 short . doc "View the given actor." $ - [ "This will recenter the map on the target robot and allow its inventory and logs to be inspected." - ] - Appear -> - command 1 short . doc "Set how the robot is displayed." $ - [ "You can either specify one character or five (for each direction)." - , "The default is \"X^>v<\"." - ] - Create -> - command 1 short . doc "Create an item out of thin air." $ - ["Only available in creative mode."] - Halt -> command 1 short "Tell a robot to halt." - Time -> command 0 Intangible "Get the current time." - Scout -> - command 1 short . doc "Detect whether a robot is within line-of-sight in a direction." $ - [ "Perception is blocked by 'Opaque' entities." - , T.unwords ["Has a max range of", T.pack $ show maxScoutRange, "units."] - ] - Whereami -> command 0 Intangible "Get the current x and y coordinates." - Waypoint -> - command 2 Intangible . doc "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." - ] - Detect -> - command 2 Intangible . doc "Detect an entity within a rectangle." $ - ["Locate the closest instance of a given entity within the rectangle specified by opposite corners, relative to the current location."] - Resonate -> - command 2 Intangible . doc "Count specific entities within a rectangle." $ - [ "Applies a strong magnetic field over a given area and stimulates the matter within, generating a non-directional radio signal. A receiver tuned to the resonant frequency of the target entity is able to measure its quantity." - , "Counts the entities within the rectangle specified by opposite corners, relative to the current location." - ] - Density -> - command 1 Intangible . doc "Count all entities within a rectangle." $ - [ "Applies a strong magnetic field over a given area and stimulates the matter within, generating a non-directional radio signal. A receiver measured the signal intensity to measure the quantity." - , "Counts the entities within the rectangle specified by opposite corners, relative to the current location." - ] - Sniff -> - command 1 short . doc "Determine distance to entity." $ - [ "Measures concentration of airborne particles to infer distance to a certain kind of entity." - , "If none is detected, returns (-1)." - , T.unwords ["Has a max range of", T.pack $ show maxSniffRange, "units."] - ] - Chirp -> - command 1 short . doc "Determine direction to entity." $ - [ "Uses a directional sonic emitter and microphone tuned to the acoustic signature of a specific entity to determine its direction." - , "Returns 'down' if out of range or the direction is indeterminate." - , "Provides absolute directions if \"compass\" equipped, relative directions otherwise." - , T.unwords ["Has a max range of", T.pack $ show maxSniffRange, "units."] - ] - Watch -> - command 1 short . doc "Interrupt `wait` upon location changes." $ - [ "Place seismic detectors to alert upon entity changes to the specified location." - , "Supply a direction, as with the `scan` command, to specify a nearby location." - , "Can be invoked more than once until the next `wait` command, at which time the only the registered locations that are currently nearby are preserved." - , "Any change to entities at the monitored locations will cause the robot to wake up before the `wait` timeout." - ] - Surveil -> - command 1 short . doc "Interrupt `wait` upon (remote) location changes." $ - [ "Like `watch`, but with no restriction on distance." - ] - Heading -> command 0 Intangible "Get the current heading." - Blocked -> command 0 Intangible "See if the robot can move forward." - Scan -> - command 1 Intangible . doc "Scan a nearby location for entities." $ - [ "Adds the entity (not actor) to your inventory with count 0 if there is any." - , "If you can use sum types, you can also inspect the result directly." - ] - Upload -> command 1 short "Upload a robot's known entities and log to another robot." - Ishere -> command 1 Intangible "See if a specific entity is in the current location." - Isempty -> - command 0 Intangible . doc "Check if the current location is empty." $ - [ "Detects whether or not the current location contains an entity." - , "Does not detect robots or other actors." - ] - Self -> function 0 "Get a reference to the current robot." - Parent -> function 0 "Get a reference to the robot's parent." - Base -> function 0 "Get a reference to the base." - Meet -> command 0 Intangible "Get a reference to a nearby actor, if there is one." - MeetAll -> command 0 long "Run a command for each nearby actor." - Whoami -> command 0 Intangible "Get the robot's display name." - Setname -> command 1 short "Set the robot's display name." - Random -> - command 1 Intangible . doc "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 "Run a program loaded from a file." - Return -> command 1 Intangible "Make the value a result in `cmd`." - Try -> command 2 Intangible "Execute a command, catching errors." - Undefined -> function 0 "A value of any type, that is evaluated as error." - Fail -> function 1 "A value of any type, that is evaluated as error with message." - If -> - function 3 . doc "If-Then-Else function." $ - ["If the bool predicate is true then evaluate the first expression, otherwise the second."] - Inl -> function 1 "Put the value into the left component of a sum type." - Inr -> function 1 "Put the value into the right component of a sum type." - Case -> function 3 "Evaluate one of the given functions on a value of sum type." - Fst -> function 1 "Get the first value of a pair." - Snd -> function 1 "Get the second value of a pair." - Force -> function 1 "Force the evaluation of a delayed value." - Not -> function 1 "Negate the boolean value." - Neg -> unaryOp "-" 7 P "Negate the given integer value." - Add -> binaryOp "+" 6 L "Add the given integer values." - And -> binaryOp "&&" 3 R "Logical and (true if both values are true)." - Or -> binaryOp "||" 2 R "Logical or (true if either value is true)." - Sub -> binaryOp "-" 6 L "Subtract the given integer values." - Mul -> binaryOp "*" 7 L "Multiply the given integer values." - Div -> binaryOp "/" 7 L "Divide the left integer value by the right one, rounding down." - Exp -> binaryOp "^" 8 R "Raise the left integer value to the power of the right one." - Eq -> binaryOp "==" 4 N "Check that the left value is equal to the right one." - Neq -> binaryOp "!=" 4 N "Check that the left value is not equal to the right one." - Lt -> binaryOp "<" 4 N "Check that the left value is lesser than the right one." - Gt -> binaryOp ">" 4 N "Check that the left value is greater than the right one." - Leq -> binaryOp "<=" 4 N "Check that the left value is lesser or equal to the right one." - Geq -> binaryOp ">=" 4 N "Check that the left value is greater or equal to the right one." - Format -> function 1 "Turn an arbitrary value into a string." - Concat -> binaryOp "++" 6 R "Concatenate the given strings." - Chars -> function 1 "Counts the number of characters in the text." - Split -> - function 2 . doc "Split the text into two at given position." $ - [ "To be more specific, the following holds for all `text` values `s1` and `s2`:" - , "`(s1,s2) == split (chars s1) (s1 ++ s2)`" - , "So split can be used to undo concatenation if you know the length of the original string." - ] - CharAt -> - function 2 . doc "Get the character at a given index." $ - [ "Gets the character (as an `int` representing a Unicode codepoint) at a specific index in a `text` value. Valid indices are 0 through `chars t - 1`." - , "Throws an exception if given an out-of-bounds index." - ] - ToChar -> - function 1 . doc "Create a singleton `text` value from the given character code." $ - [ "That is, `chars (toChar c) == 1` and `charAt 0 (toChar c) == c`." - ] - AppF -> - binaryOp "$" 0 R . doc "Apply the function on the left to the value on the right." $ - [ "This operator is useful to avoid nesting parentheses." - , "For exaple:" - , "`f $ g $ h x = f (g (h x))`" - ] - Swap -> - command 1 short . doc "Swap placed entity with one in inventory." $ - [ "This essentially works like atomic grab and place." - , "Use this to avoid race conditions where more robots grab, scan or place in one location." - ] - Atomic -> - command 1 Intangible . doc "Execute a block of commands atomically." $ - [ "When executing `atomic c`, a robot will not be interrupted, that is, no other robots will execute any commands while the robot is executing @c@." - ] - Instant -> - command 1 Intangible . doc "Execute a block of commands instantly." $ - [ "Like `atomic`, but with no restriction on program size." - ] - Key -> - function 1 . doc "Create a key value from a text description." $ - [ "The key description can optionally start with modifiers like 'C-', 'M-', 'A-', or 'S-', followed by either a regular key, or a special key name like 'Down' or 'End'" - , "For example, 'M-C-x', 'Down', or 'S-4'." - , "Which key combinations are actually possible to type may vary by keyboard and terminal program." - ] - InstallKeyHandler -> - command 2 Intangible . doc "Install a keyboard input handler." $ - [ "The first argument is a hint line that will be displayed when the input handler is active." - , "The second argument is a function to handle keyboard inputs." - ] - Teleport -> command 2 short "Teleport a robot to the given location." - As -> command 2 Intangible "Hypothetically run a command as if you were another robot." - RobotNamed -> command 1 Intangible "Find an actor by name." - RobotNumbered -> command 1 Intangible "Find an actor by number." - Knows -> command 1 Intangible "Check if the robot knows about an entity." - where - doc b ls = ConstDoc b (T.unlines ls) - unaryOp s p side d = - ConstInfo - { syntax = s - , fixity = p - , constMeta = ConstMUnOp side - , constDoc = d - , tangibility = Intangible - } - binaryOp s p side d = - ConstInfo - { syntax = s - , fixity = p - , constMeta = ConstMBinOp side - , constDoc = d - , tangibility = Intangible - } - command a f d = - ConstInfo - { syntax = lowShow c - , fixity = 11 - , constMeta = ConstMFunc a True - , constDoc = d - , tangibility = f - } - function a d = - ConstInfo - { syntax = lowShow c - , fixity = 11 - , constMeta = ConstMFunc a False - , constDoc = d - , tangibility = Intangible - } - - lowShow :: Show a => a -> Text - lowShow a = toLower (from (show a)) - ------------------------------------------------------------- --- 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) - --- | 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) - -locVarToSyntax' :: LocVar -> ty -> Syntax' ty -locVarToSyntax' (LV s v) = Syntax' s (TVar v) - --- | Terms of the Swarm language. -data Term' ty - = -- | The unit value. - TUnit - | -- | A constant. - TConst Const - | -- | A direction literal. - TDir Direction - | -- | An integer literal. - TInt Integer - | -- | An antiquoted Haskell variable name of type Integer. - TAntiInt Text - | -- | A text literal. - TText Text - | -- | An antiquoted Haskell variable name of type Text. - TAntiText Text - | -- | A Boolean literal. - TBool Bool - | -- | 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. - TRobot Int - | -- | A memory reference. These likewise never show up in surface syntax, - -- but are here to facilitate pretty-printing. - TRef Int - | -- | Require a specific device to be installed. - TRequireDevice Text - | -- | Require a certain number of an entity. - TRequire 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 - -- original term may have been elaborated, e.g. `force` may have been added - -- around some variables, etc.) - SRequirements Text (Syntax' ty) - | -- | A variable. - TVar Var - | -- | A pair. - SPair (Syntax' ty) (Syntax' ty) - | -- | A lambda expression, with or without a type annotation on the - -- binder. - SLam LocVar (Maybe Type) (Syntax' ty) - | -- | Function application. - SApp (Syntax' ty) (Syntax' ty) - | -- | A (recursive) let expression, with or without a type - -- annotation on the variable. The @Bool@ indicates whether - -- it is known to be recursive. - SLet Bool LocVar (Maybe Polytype) (Syntax' ty) (Syntax' ty) - | -- | A (recursive) definition command, which binds a variable to a - -- value in subsequent commands. The @Bool@ indicates whether the - -- definition is known to be recursive. - SDef Bool LocVar (Maybe Polytype) (Syntax' ty) - | -- | A monadic bind for commands, of the form @c1 ; c2@ or @x <- c1; c2@. - SBind (Maybe LocVar) (Syntax' ty) (Syntax' ty) - | -- | Delay evaluation of a term, written @{...}@. Swarm is an - -- eager language, but in some cases (e.g. for @if@ statements - -- and recursive bindings) we need to delay evaluation. The - -- counterpart to @{...}@ is @force@, where @force {t} = t@. - -- Note that 'Force' is just a constant, whereas 'SDelay' has to - -- be a special syntactic form so its argument can get special - -- treatment during evaluation. - SDelay DelayType (Syntax' ty) - | -- | Record literals @[x1 = e1, x2 = e2, x3, ...]@ Names @x@ - -- without an accompanying definition are sugar for writing - -- @x=x@. - SRcd (Map Var (Maybe (Syntax' ty))) - | -- | Record projection @e.x@ - SProj (Syntax' ty) Var - | -- | Annotate a term with a type - SAnnotate (Syntax' ty) Polytype - deriving - ( Eq - , Show - , Functor - , Foldable - , Data - , Generic - , FromJSON - , ToJSON - , -- | 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 - -- them. Once we have finished solving everything we need to do a - -- final traversal over all the types in the AST to substitute away - -- all the unification variables (and generalize, i.e. stick 'forall' - -- on, as appropriate). See the call to 'mapM' in - -- Swarm.Language.Typecheck.runInfer. - Traversable - ) - -type Term = Term' () - -instance Data ty => Plated (Term' ty) where - plate = uniplate - ------------------------------------------------------------- --- Syntax: annotation on top of Terms with SrcLoc and type ------------------------------------------------------------- - --- | The surface syntax for the language, with location and type annotations. -data Syntax' ty = Syntax' - { _sLoc :: SrcLoc - , _sTerm :: Term' ty - , _sType :: ty - } - deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON) - -instance Data ty => Plated (Syntax' ty) where - plate = uniplate - -data SrcLoc - = NoLoc - | -- | Half-open interval from start (inclusive) to end (exclusive) - SrcLoc Int Int - deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON) - -instance Semigroup SrcLoc where - NoLoc <> l = l - l <> NoLoc = l - SrcLoc s1 e1 <> SrcLoc s2 e2 = SrcLoc (min s1 s2) (max e1 e2) - -instance Monoid SrcLoc where - mempty = NoLoc - ------------------------------------------------------------- --- Pattern synonyms for untyped terms ------------------------------------------------------------- - -type Syntax = Syntax' () - -pattern Syntax :: SrcLoc -> Term -> Syntax -pattern Syntax l t = Syntax' l t () - -{-# COMPLETE Syntax #-} - -makeLenses ''Syntax' - -noLoc :: Term -> Syntax -noLoc = Syntax mempty - --- | Match an untyped term without its 'SrcLoc'. -pattern STerm :: Term -> Syntax -pattern STerm t <- - Syntax _ t - where - STerm t = Syntax mempty t - -pattern TRequirements :: Text -> Term -> Term -pattern TRequirements x t = SRequirements x (STerm t) - --- | Match a TPair without syntax -pattern TPair :: Term -> Term -> Term -pattern TPair t1 t2 = SPair (STerm t1) (STerm t2) - --- | Match a TLam without syntax -pattern TLam :: Var -> Maybe Type -> Term -> Term -pattern TLam v ty t <- SLam (lvVar -> v) ty (STerm t) - where - TLam v ty t = SLam (LV NoLoc v) ty (STerm t) - --- | Match a TApp without syntax -pattern TApp :: Term -> Term -> Term -pattern TApp t1 t2 = SApp (STerm t1) (STerm t2) - -infixl 0 :$: - --- | Convenient infix pattern synonym for application. -pattern (:$:) :: Term -> Syntax -> Term -pattern (:$:) t1 s2 = SApp (STerm t1) s2 - --- | Match a TLet without syntax -pattern TLet :: Bool -> Var -> Maybe Polytype -> Term -> Term -> Term -pattern TLet r v pt t1 t2 <- SLet r (lvVar -> v) pt (STerm t1) (STerm t2) - where - TLet r v pt t1 t2 = SLet r (LV NoLoc v) pt (STerm t1) (STerm t2) - --- | Match a TDef without syntax -pattern TDef :: Bool -> Var -> Maybe Polytype -> Term -> Term -pattern TDef r v pt t <- SDef r (lvVar -> v) pt (STerm t) - where - TDef r v pt t = SDef r (LV NoLoc v) pt (STerm t) - --- | Match a TBind without syntax -pattern TBind :: Maybe Var -> Term -> Term -> Term -pattern TBind mv t1 t2 <- SBind (fmap lvVar -> mv) (STerm t1) (STerm t2) - where - TBind mv t1 t2 = SBind (LV NoLoc <$> mv) (STerm t1) (STerm t2) - --- | Match a TDelay without syntax -pattern TDelay :: DelayType -> Term -> Term -pattern TDelay m t = SDelay m (STerm t) - --- | Match a TRcd without syntax -pattern TRcd :: Map Var (Maybe Term) -> Term -pattern TRcd m <- SRcd ((fmap . fmap) _sTerm -> m) - where - TRcd m = SRcd ((fmap . fmap) STerm m) - -pattern TProj :: Term -> Var -> Term -pattern TProj t x = SProj (STerm t) x - --- | Match a TAnnotate without syntax -pattern TAnnotate :: Term -> Polytype -> Term -pattern TAnnotate t pt = SAnnotate (STerm t) pt - --- | COMPLETE pragma tells GHC using this set of pattern is complete for Term -{-# COMPLETE TUnit, TConst, TDir, TInt, TAntiInt, TText, TAntiText, TBool, TRequireDevice, TRequire, TRequirements, TVar, TPair, TLam, TApp, TLet, TDef, TBind, TDelay, TRcd, TProj, TAnnotate #-} - --- | Make infix operation (e.g. @2 + 3@) a curried function --- application (@((+) 2) 3@). -mkOp :: Const -> Syntax -> Syntax -> Syntax -mkOp c 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 - --- | Make infix operation, discarding any syntax related location -mkOp' :: Const -> Term -> Term -> Term -mkOp' c t1 = TApp (TApp (TConst c) t1) - --- $setup --- >>> import Control.Lens ((^.)) - --- | Turn function application chain into a list. --- --- >>> syntaxWrap f = fmap (^. sTerm) . f . Syntax NoLoc --- >>> syntaxWrap unfoldApps (mkOp' Mul (TInt 1) (TInt 2)) -- 1 * 2 --- TConst Mul :| [TInt 1,TInt 2] -unfoldApps :: Syntax' ty -> NonEmpty (Syntax' ty) -unfoldApps trm = NonEmpty.reverse . flip NonEmpty.unfoldr trm $ \case - Syntax' _ (SApp s1 s2) _ -> (s2, Just s1) - s -> (s, Nothing) - --------------------------------------------------- --- Erasure - --- | Erase a 'Syntax' tree annotated with type --- information to a bare unannotated 'Term'. -eraseS :: Syntax' ty -> Term -eraseS (Syntax' _ t _) = void t - ------------------------------------------------------------- --- Free variable traversals ------------------------------------------------------------- - --- | Traversal over those subterms of a term which represent free --- variables. The S suffix indicates that it is a `Traversal' over --- the `Syntax` nodes (which contain type and source location info) --- containing free variables inside a larger `Syntax` value. Note --- that if you want to get the list of all `Syntax` nodes --- representing free variables, you can do so via @'toListOf' --- 'freeVarsS'@. -freeVarsS :: forall ty. Traversal' (Syntax' ty) (Syntax' ty) -freeVarsS f = go S.empty - where - -- go :: Applicative f => Set Var -> Syntax' ty -> f (Syntax' ty) - go bound s@(Syntax' l t ty) = case t of - TUnit -> pure s - TConst {} -> pure s - TDir {} -> pure s - TInt {} -> pure s - TAntiInt {} -> pure s - TText {} -> pure s - TAntiText {} -> pure s - TBool {} -> pure s - TRobot {} -> pure s - TRef {} -> pure s - TRequireDevice {} -> pure s - TRequire {} -> 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 r x xty s1 s2 -> - let bound' = S.insert (lvVar x) bound - in rewrap $ SLet r x xty <$> go bound' s1 <*> go bound' s2 - SPair s1 s2 -> rewrap $ SPair <$> go bound s1 <*> go bound s2 - SDef r x xty s1 -> rewrap $ SDef r x xty <$> go (S.insert (lvVar x) bound) s1 - SBind mx s1 s2 -> rewrap $ SBind mx <$> go bound s1 <*> go (maybe id (S.insert . lvVar) mx bound) s2 - SDelay m s1 -> rewrap $ SDelay m <$> go bound s1 - SRcd m -> rewrap $ SRcd <$> (traverse . traverse) (go bound) m - SProj s1 x -> rewrap $ SProj <$> go bound s1 <*> pure x - SAnnotate s1 pty -> rewrap $ SAnnotate <$> go bound s1 <*> pure pty - where - rewrap s' = Syntax' l <$> s' <*> pure ty - --- | Like 'freeVarsS', but traverse over the 'Term's containing free --- variables. More direct if you don't need to know the types or --- source locations of the variables. Note that if you want to get --- the list of all `Term`s representing free variables, you can do so via --- @'toListOf' 'freeVarsT'@. -freeVarsT :: forall ty. Traversal' (Syntax' ty) (Term' ty) -freeVarsT = freeVarsS . sTerm - --- | Traversal over the free variables of a term. Like 'freeVarsS' --- and 'freeVarsT', but traverse over the variable names --- themselves. Note that if you want to get the set of all free --- variable names, you can do so via @'Data.Set.Lens.setOf' --- 'freeVarsV'@. -freeVarsV :: Traversal' (Syntax' ty) Var -freeVarsV = freeVarsT . (\f -> \case TVar x -> TVar <$> f x; t -> pure t) - --- | Apply a function to all free occurrences of a particular variable. -mapFreeS :: Var -> (Syntax' ty -> Syntax' ty) -> Syntax' ty -> Syntax' ty -mapFreeS x f = freeVarsS %~ (\t -> case t ^. sTerm of TVar y | y == x -> f t; _ -> t) - --- | Transform the AST into a Tree datatype. --- Useful for pretty-printing (e.g. via "Data.Tree.drawTree"). -asTree :: Data a => Syntax' a -> Tree (Syntax' a) -asTree = para Node - --- | Each constructor is a assigned a value of 1, plus --- any recursive syntax it entails. -measureAstSize :: Data a => Syntax' a -> Int -measureAstSize = length . universe diff --git a/src/Swarm/Language/Text/Markdown.hs b/src/Swarm/Language/Text/Markdown.hs deleted file mode 100644 --- a/src/Swarm/Language/Text/Markdown.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Simple Markdown AST and related utilities. --- --- Parametrising 'Document' with the type of --- inline code and code blocks allows us to --- inspect and validate Swarm code in descriptions. --- --- See 'Swarm.TUI.View.Util.drawMarkdown' for --- rendering the descriptions as brick widgets. -module Swarm.Language.Text.Markdown ( - -- ** Markdown document - Document (..), - Paragraph (..), - Node (..), - TxtAttr (..), - fromTextM, - fromText, - docToText, - docToMark, - - -- ** Token stream - StreamNode' (..), - StreamNode, - ToStream (..), - toText, - - -- ** Utilities - findCode, - chunksOf, -) where - -import Commonmark qualified as Mark -import Commonmark.Extensions qualified as Mark (rawAttributeSpec) -import Control.Applicative ((<|>)) -import Control.Arrow (left) -import Control.Lens ((%~), (&), _head, _last) -import Data.Char (isSpace) -import Data.Functor.Identity (Identity (..)) -import Data.List.Split (chop) -import Data.Maybe (catMaybes) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Text (Text) -import Data.Text qualified as T -import Data.Tuple.Extra (both, first) -import Data.Vector (toList) -import Data.Yaml -import GHC.Exts qualified (IsList (..), IsString (..)) -import Swarm.Language.Parse (readTerm) -import Swarm.Language.Pipeline (processParsedTerm) -import Swarm.Language.Pretty (PrettyPrec (..), prettyText, prettyTextLine, prettyTypeErrText) -import Swarm.Language.Syntax (Syntax) - --- | The top-level markdown document. -newtype Document c = Document {paragraphs :: [Paragraph c]} - deriving (Eq, Show, Functor, Foldable, Traversable) - deriving (Semigroup, Monoid) via [Paragraph c] - --- | Markdown paragraphs that contain inline leaf nodes. --- --- The idea is that paragraphs do not have line breaks, --- and so the inline elements follow each other. --- In particular inline code can be followed by text without --- space between them (e.g. @\`logger\`s@). -newtype Paragraph c = Paragraph {nodes :: [Node c]} - deriving (Eq, Show, Functor, Foldable, Traversable) - deriving (Semigroup, Monoid) via [Node c] - -mapP :: (Node c -> Node c) -> Paragraph c -> Paragraph c -mapP f (Paragraph ns) = Paragraph (map f ns) - -pureP :: Node c -> Paragraph c -pureP = Paragraph . (: []) - --- | Inline leaf nodes. --- --- The raw node is from the raw_annotation extension, --- and can be used for types/entities/invalid code. -data Node c - = LeafText (Set TxtAttr) Text - | LeafRaw String Text - | LeafCode c - | LeafCodeBlock String c - deriving (Eq, Show, Functor, Foldable, Traversable) - -txt :: Text -> Node c -txt = LeafText mempty - -addTextAttribute :: TxtAttr -> Node c -> Node c -addTextAttribute a (LeafText as t) = LeafText (Set.insert a as) t -addTextAttribute _ n = n - -normalise :: (Eq c, Semigroup c) => Paragraph c -> Paragraph c -normalise (Paragraph a) = Paragraph $ go a - where - go = \case - [] -> [] - (n : ns) -> let (n', ns') = mergeSame n ns in n' : go ns' - mergeSame = \case - l@(LeafText attrs1 t1) -> \case - (LeafText attrs2 t2 : rss) | attrs1 == attrs2 -> mergeSame (LeafText attrs1 $ t1 <> t2) rss - rs -> (l, rs) - l -> (l,) - --- | Simple text attributes that make it easier to find key info in descriptions. -data TxtAttr = Strong | Emphasis - deriving (Eq, Show, Ord) - -instance Mark.Rangeable (Paragraph c) where - ranged _ = id - -instance Mark.HasAttributes (Paragraph c) where - addAttributes _ = id - -instance Mark.Rangeable (Document c) where - ranged _ = id - -instance Mark.HasAttributes (Document c) where - addAttributes _ = id - -instance GHC.Exts.IsList (Document a) where - type Item (Document a) = Paragraph a - toList = paragraphs - fromList = Document - -instance GHC.Exts.IsString (Document Syntax) where - fromString = fromText . T.pack - -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) - --- | Surround some text in double quotes if it is not empty. -quoteMaybe :: Text -> Text -quoteMaybe t = if T.null t then t else T.concat ["\"", t, "\""] - -instance Mark.IsInline (Paragraph Text) where - lineBreak = pureP $ txt "\n" - softBreak = pureP $ txt " " - str = pureP . txt - entity = Mark.str - escapedChar c = Mark.str $ T.pack ['\\', c] - emph = mapP $ addTextAttribute Emphasis - strong = mapP $ addTextAttribute Strong - link dest title desc = pureP (txt "[") <> desc <> pureP (txt $ "](" <> dest <> quoteMaybe title <> ")") - image dest title desc = pureP (txt "!") <> Mark.link dest title desc - code = pureP . LeafCode - rawInline (Mark.Format f) = pureP . LeafRaw (T.unpack f) - -instance Mark.IsBlock (Paragraph Text) (Document Text) where - paragraph = Document . (: []) - plain = Mark.paragraph - thematicBreak = mempty - 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 - referenceLinkDefinition = mempty - list _type _spacing = mconcat - -parseSyntax :: Text -> Either String Syntax -parseSyntax t = case readTerm t of - Left e -> Left (T.unpack e) - Right Nothing -> Left "empty code" - Right (Just s) -> case processParsedTerm s of - -- Just run the typechecker etc. to make sure the term typechecks - Left e -> Left (T.unpack $ prettyTypeErrText t e) - -- ...but if it does, we just go back to using the original parsed - -- (*unelaborated*) AST. See #1496. - Right _ -> Right s - -findCode :: Document Syntax -> [Syntax] -findCode = catMaybes . concatMap (map codeOnly . nodes) . paragraphs - where - codeOnly = \case - LeafCode s -> Just s - LeafCodeBlock _i s -> Just s - _l -> Nothing - -instance ToJSON (Paragraph Syntax) where - toJSON = String . toText - -instance ToJSON (Document Syntax) where - toJSON = String . docToMark - -instance FromJSON (Document Syntax) where - parseJSON v = parseDoc v <|> parsePars v - where - parseDoc = withText "markdown" fromTextM - parsePars = withArray "markdown paragraphs" $ \a -> do - (ts :: [Text]) <- mapM parseJSON $ toList a - fromTextM $ T.intercalate "\n\n" ts - --- | Parse Markdown document, but throw on invalid code. -fromText :: Text -> Document Syntax -fromText = either error id . fromTextE - --- | Read Markdown document and parse&validate the code. --- --- If you want only the document with code as `Text`, --- use the 'fromTextPure' function. -fromTextM :: MonadFail m => Text -> m (Document Syntax) -fromTextM = either fail pure . fromTextE - -fromTextE :: Text -> Either String (Document Syntax) -fromTextE t = fromTextPure t >>= traverse parseSyntax - --- | Read Markdown document without code validation. -fromTextPure :: Text -> Either String (Document Text) -fromTextPure t = do - let spec = Mark.rawAttributeSpec <> Mark.defaultSyntaxSpec <> Mark.rawAttributeSpec - let runSimple = left show . runIdentity - Document tokenizedDoc <- runSimple $ Mark.commonmarkWith spec "markdown" t - return . Document $ normalise <$> tokenizedDoc - --------------------------------------------------------------- --- DIY STREAM --------------------------------------------------------------- - --- | Convert 'Document' to 'Text'. --- --- Note that this will strip some markdown, emphasis and bold marks. --- If you want to get markdown again, use 'docToMark'. -docToText :: PrettyPrec a => Document a -> Text -docToText = T.intercalate "\n\n" . map toText . paragraphs - --- | This is the naive and easy way to get text from markdown document. -toText :: ToStream a => a -> Text -toText = streamToText . toStream - --- | Token stream that can be easily converted to text or brick widgets. --- --- TODO: #574 Code blocks should probably be handled separately. -data StreamNode' t - = TextNode (Set TxtAttr) t - | CodeNode t - | RawNode String t - deriving (Eq, Show, Functor) - -type StreamNode = StreamNode' Text - -unStream :: StreamNode' t -> (t -> StreamNode' t, t) -unStream = \case - TextNode a t -> (TextNode a, t) - CodeNode t -> (CodeNode, t) - RawNode a t -> (RawNode a, t) - --- | Get chunks of nodes not exceeding length and broken at word boundary. -chunksOf :: Int -> [StreamNode] -> [[StreamNode]] -chunksOf n = chop (splitter True n) - where - nodeLength :: StreamNode -> Int - nodeLength = T.length . snd . unStream - splitter :: Bool -> Int -> [StreamNode] -> ([StreamNode], [StreamNode]) - splitter start i = \case - [] -> ([], []) - (tn : ss) -> - let l = nodeLength tn - in if l <= i - then first (tn :) $ splitter False (i - l) ss - else let (tn1, tn2) = cut start i tn in ([tn1], tn2 : ss) - cut :: Bool -> Int -> StreamNode -> (StreamNode, StreamNode) - cut start i tn = - let (con, t) = unStream tn - endSpace = T.takeWhileEnd isSpace t - startSpace = T.takeWhile isSpace t - twords = T.words t & _head %~ (startSpace <>) & _last %~ (<> endSpace) - in case splitWordsAt i twords of - ([], []) -> (con "", con "") - ([], ws@(ww : wws)) -> - both (con . T.unwords) $ - -- In case single word (e.g. web link) does not fit on line we must put - -- it there and guarantee progress (otherwise chop will cycle) - if start then ([T.take i ww], T.drop i ww : wws) else ([], ws) - splitted -> both (con . T.unwords) splitted - -splitWordsAt :: Int -> [Text] -> ([Text], [Text]) -splitWordsAt i = \case - [] -> ([], []) - (w : ws) -> - let l = T.length w - in if l < i - then first (w :) $ splitWordsAt (i - l - 1) ws - else ([], w : ws) - -streamToText :: [StreamNode] -> Text -streamToText = T.concat . map nodeToText - where - nodeToText = \case - TextNode _a t -> t - RawNode _s t -> t - CodeNode stx -> stx - --- | Convert elements to one dimensional stream of nodes, --- that is easy to format and layout. --- --- If you want to split the stream at line length, use --- the 'chunksOf' function afterward. -class ToStream a where - toStream :: a -> [StreamNode] - -instance PrettyPrec a => ToStream (Node a) where - toStream = \case - LeafText a t -> [TextNode a t] - LeafCode t -> [CodeNode (prettyTextLine t)] - LeafRaw s t -> [RawNode s t] - LeafCodeBlock _i t -> [CodeNode (prettyText t)] - -instance PrettyPrec a => ToStream (Paragraph a) where - toStream = concatMap toStream . nodes - --------------------------------------------------------------- --- Markdown --------------------------------------------------------------- - -nodeToMark :: PrettyPrec a => Node a -> Text -nodeToMark = \case - LeafText a t -> foldl attr t a - LeafRaw _ c -> wrap "`" c - LeafCode c -> wrap "`" (prettyText c) - LeafCodeBlock f c -> codeBlock f $ prettyText c - where - codeBlock f t = wrap "```" $ T.pack f <> "\n" <> t <> "\n" - wrap c t = c <> t <> c - attr t a = case a of - Emphasis -> wrap "_" t - Strong -> wrap "**" t - -paragraphToMark :: PrettyPrec a => Paragraph a -> Text -paragraphToMark = foldMap nodeToMark . nodes - --- | Convert 'Document' to markdown text. -docToMark :: PrettyPrec a => Document a -> Text -docToMark = T.intercalate "\n\n" . map paragraphToMark . paragraphs diff --git a/src/Swarm/Language/Typecheck.hs b/src/Swarm/Language/Typecheck.hs deleted file mode 100644 --- a/src/Swarm/Language/Typecheck.hs +++ /dev/null @@ -1,1122 +0,0 @@ -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- For 'Ord IntVar' instance - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Type inference for the Swarm language. For the approach used here, --- see --- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/ . -module Swarm.Language.Typecheck ( - -- * Type errors - ContextualTypeErr (..), - TypeErr (..), - InvalidAtomicReason (..), - - -- * Type provenance - Source (..), - withSource, - Join, - getJoin, - - -- * Typechecking stack - TCFrame (..), - LocatedTCFrame (..), - TCStack, - withFrame, - getTCStack, - - -- * Typechecking monad - TC, - runTC, - fresh, - - -- * Unification - substU, - unify, - HasBindings (..), - instantiate, - skolemize, - generalize, - - -- * Type inference - inferTop, - inferModule, - infer, - inferConst, - check, - isSimpleUType, -) where - -import Control.Arrow ((***)) -import Control.Category ((>>>)) -import Control.Lens ((^.)) -import Control.Lens.Indexed (itraverse) -import Control.Monad (forM_, void, when, (<=<)) -import Control.Monad.Except ( - ExceptT, - MonadError (catchError, throwError), - runExceptT, - ) -import Control.Monad.Reader ( - MonadReader (ask, local), - ReaderT (runReaderT), - mapReaderT, - ) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Unification hiding (applyBindings, unify, (=:=)) -import Control.Unification qualified as U -import Control.Unification.IntVar -import Data.Data (Data, gmapM) -import Data.Foldable (fold) -import Data.Functor.Identity -import Data.Generics (mkM) -import Data.Map (Map, (!)) -import Data.Map qualified as M -import Data.Maybe -import Data.Set (Set, (\\)) -import Data.Set qualified as S -import Data.Text qualified as T -import Swarm.Language.Context hiding (lookup) -import Swarm.Language.Context qualified as Ctx -import Swarm.Language.Module -import Swarm.Language.Parse.QQ (tyQ) -import Swarm.Language.Syntax -import Swarm.Language.Typecheck.Unify -import Swarm.Language.Types -import Prelude hiding (lookup) - ------------------------------------------------------------- --- Typechecking stack - --- | A frame to keep track of something we were in the middle of doing --- during typechecking. -data TCFrame where - -- | Checking a definition. - TCDef :: Var -> TCFrame - -- | Inferring the LHS of a bind. - TCBindL :: TCFrame - -- | Inferring the RHS of a bind. - TCBindR :: TCFrame - deriving (Show) - --- | A typechecking stack frame together with the relevant @SrcLoc@. -data LocatedTCFrame = LocatedTCFrame SrcLoc TCFrame - deriving (Show) - --- | A typechecking stack keeps track of what we are currently in the --- middle of doing during typechecking. -type TCStack = [LocatedTCFrame] - ------------------------------------------------------------- --- Type source - --- | The source of a type during typechecking. -data Source - = -- | An expected type that was "pushed down" from the context. - Expected - | -- | An actual/inferred type that was "pulled up" from a term. - Actual - deriving (Show, Eq, Ord, Bounded, Enum) - --- | Generic eliminator for 'Source'. Choose the first argument if --- the 'Source' is 'Expected', and the second argument if 'Actual'. -withSource :: Source -> a -> a -> a -withSource Expected e _ = e -withSource Actual _ a = a - --- | A value along with its source (expected vs actual). -type Sourced a = (Source, a) - --- | A "join" where an expected thing meets an actual thing. -newtype Join a = Join (Source -> a) - -instance (Show a) => Show (Join a) where - show (getJoin -> (e, a)) = "(expected: " <> show e <> ", actual: " <> show a <> ")" - -type TypeJoin = Join UType - --- | Create a 'Join' from an expected thing and an actual thing (in that order). -joined :: a -> a -> Join a -joined expect actual = Join (\case Expected -> expect; Actual -> actual) - --- | Create a 'Join' from a 'Sourced' thing together with another --- thing (which is assumed to have the opposite 'Source'). -mkJoin :: Sourced a -> a -> Join a -mkJoin (src, a1) a2 = Join $ \s -> if s == src then a1 else a2 - --- | Convert a 'Join' into a pair of (expected, actual). -getJoin :: Join a -> (a, a) -getJoin (Join j) = (j Expected, j Actual) - ------------------------------------------------------------- --- Type checking monad - --- | The concrete monad used for type checking. 'IntBindingT' is a --- monad transformer provided by the @unification-fd@ library which --- supports various operations such as generating fresh variables --- and unifying things. --- --- Note that we are sort of constrained to use a concrete monad stack by --- @unification-fd@, which has some strange types on some of its exported --- functions that actually require various monad transformers to be stacked --- in certain ways. For example, see . I don't really see a way --- to use "capability style" like we do elsewhere in the codebase. -type TC = ReaderT UCtx (ReaderT TCStack (ExceptT ContextualTypeErr (IntBindingT TypeF Identity))) - --- | Push a frame on the typechecking stack within a local 'TC' --- computation. -withFrame :: SrcLoc -> TCFrame -> TC a -> TC a -withFrame l f = mapReaderT (local (LocatedTCFrame l f :)) - --- | Get the current typechecking stack. -getTCStack :: TC TCStack -getTCStack = lift ask - ------------------------------------------------------------- - --- | Run a top-level inference computation, returning either a --- 'TypeErr' or a fully resolved 'TModule'. -runTC :: TCtx -> TC UModule -> Either ContextualTypeErr TModule -runTC ctx = - (>>= applyBindings) - >>> ( >>= - \(Module u uctx) -> - Module - <$> mapM (checkPredicative <=< (fmap fromU . generalize)) u - <*> checkPredicative (fromU uctx) - ) - >>> flip runReaderT (toU ctx) - >>> flip runReaderT [] - >>> runExceptT - >>> evalIntBindingT - >>> runIdentity - -checkPredicative :: Maybe a -> TC a -checkPredicative = maybe (throwError (mkRawTypeErr Impredicative)) pure - --- | Look up a variable in the ambient type context, either throwing --- an 'UnboundVar' error if it is not found, or opening its --- associated 'UPolytype' with fresh unification variables via --- 'instantiate'. -lookup :: SrcLoc -> Var -> TC UType -lookup loc x = do - ctx <- getCtx - maybe (throwTypeErr loc $ UnboundVar x) instantiate (Ctx.lookup x ctx) - --- | Get the current type context. -getCtx :: TC UCtx -getCtx = ask - --- | Catch any thrown type errors and re-throw them with an added source --- location. -addLocToTypeErr :: SrcLoc -> TC a -> TC a -addLocToTypeErr l m = - m `catchError` \case - CTE NoLoc _ te -> throwTypeErr l te - te -> throwError te - ------------------------------------------------------------- --- Dealing with variables: free variables, fresh variables, --- substitution - --- | @unification-fd@ does not provide an 'Ord' instance for 'IntVar', --- so we must provide our own, in order to be able to store --- 'IntVar's in a 'Set'. -deriving instance Ord IntVar - --- | A class for getting the free unification variables of a thing. -class FreeVars a where - freeVars :: a -> TC (Set IntVar) - --- | We can get the free unification variables of a 'UType'. -instance FreeVars UType where - freeVars ut = fmap S.fromList . lift . lift . lift $ getFreeVars ut - --- | We can also get the free variables of a polytype. -instance (FreeVars t) => FreeVars (Poly t) where - freeVars (Forall _ t) = freeVars t - --- | We can get the free variables in any polytype in a context. -instance FreeVars UCtx where - freeVars = fmap S.unions . mapM freeVars . M.elems . unCtx - --- | Generate a fresh unification variable. -fresh :: TC UType -fresh = UVar <$> (lift . lift . lift $ freeVar) - --- | Perform a substitution over a 'UType', substituting for both type --- and unification variables. Note that since 'UType's do not have --- any binding constructs, we don't have to worry about ignoring --- bound variables; all variables in a 'UType' are free. -substU :: Map (Either Var IntVar) UType -> UType -> UType -substU m = - ucata - (\v -> fromMaybe (UVar v) (M.lookup (Right v) m)) - ( \case - TyVarF v -> fromMaybe (UTyVar v) (M.lookup (Left v) m) - f -> UTerm f - ) - --- | Make sure no skolem variables escape. -noSkolems :: SrcLoc -> UPolytype -> TC () -noSkolems l (Forall xs upty) = do - upty' <- applyBindings upty - let tyvs = - ucata - (const S.empty) - (\case TyVarF v -> S.singleton v; f -> fold f) - upty' - ftyvs = tyvs `S.difference` S.fromList xs - forM_ (S.lookupMin ftyvs) $ throwTypeErr l . EscapedSkolem - --- ~~~~ Note [lookupMin to get an arbitrary element] --- --- `S.lookupMin :: Set a -> Maybe a` returns the smallest --- element of a set, or Nothing if the set is empty. We don't --- actually care about getting the *smallest* type variable, but --- lookupMin is a convenient way to say "just get one element if --- any exist". The forM_ is actually over the Maybe so it represents --- doing the throwTypeErr either zero or one time, depending on --- whether lookupMin returns Nothing or Just. - ------------------------------------------------------------- --- Lifted stuff from unification-fd - -infix 4 =:= - --- | @unify t expTy actTy@ ensures that the given two types are equal. --- If we know the actual term @t@ which is supposed to have these --- types, we can use it to generate better error messages. --- --- We first do a quick-and-dirty check to see whether we know for --- sure the types either are or cannot be equal, generating an --- equality constraint for the unifier as a last resort. -unify :: Maybe Syntax -> TypeJoin -> TC UType -unify ms j = case unifyCheck expected actual of - Apart -> throwTypeErr NoLoc $ Mismatch ms j - Equal -> return expected - MightUnify -> lift . lift $ expected U.=:= actual - where - (expected, actual) = getJoin j - --- | Ensure two types are the same. -(=:=) :: UType -> UType -> TC UType -ty1 =:= ty2 = unify Nothing (joined ty1 ty2) - --- | @unification-fd@ provides a function 'U.applyBindings' which --- fully substitutes for any bound unification variables (for --- efficiency, it does not perform such substitution as it goes --- along). The 'HasBindings' class is for anything which has --- unification variables in it and to which we can usefully apply --- 'U.applyBindings'. -class HasBindings u where - applyBindings :: u -> TC u - -instance HasBindings UType where - applyBindings = lift . lift . U.applyBindings - -instance HasBindings UPolytype where - applyBindings (Forall xs u) = Forall xs <$> applyBindings u - -instance HasBindings UCtx where - applyBindings = mapM applyBindings - -instance (HasBindings u, Data u) => HasBindings (Term' u) where - applyBindings = gmapM (mkM (applyBindings @(Syntax' u))) - -instance (HasBindings u, Data u) => HasBindings (Syntax' u) where - applyBindings (Syntax' l t u) = Syntax' l <$> applyBindings t <*> applyBindings u - -instance HasBindings UModule where - applyBindings (Module u uctx) = Module <$> applyBindings u <*> applyBindings uctx - ------------------------------------------------------------- --- Converting between mono- and polytypes - --- | 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 :: UPolytype -> TC UType -instantiate (Forall xs uty) = do - xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) xs')) 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 :: UPolytype -> TC 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 (UVar v) = UTyVar (mkVarName "s" v) - toSkolem x = error $ "Impossible! Non-UVar in skolemize.toSkolem: " ++ show x - --- | 'generalize' is the opposite of 'instantiate': add a 'Forall' --- which closes over all free type and unification variables. --- --- Pick nice type variable names instead of reusing whatever fresh --- names happened to be used for the free variables. -generalize :: UType -> TC UPolytype -generalize uty = do - uty' <- applyBindings uty - ctx <- getCtx - tmfvs <- freeVars uty' - ctxfvs <- freeVars ctx - let fvs = S.toList $ tmfvs \\ ctxfvs - alphabet = ['a' .. 'z'] - -- Infinite supply of pretty names a, b, ..., z, a0, ... z0, a1, ... z1, ... - 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 - (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 :: SrcLoc -> TypeErr -> TC a -throwTypeErr l te = do - stk <- getTCStack - throwError $ mkTypeErr l stk te - --- | Errors that can occur during type checking. The idea is that --- each error carries information that can be used to help explain --- what went wrong (though the amount of information carried can and --- should be very much improved in the future); errors can then --- separately be pretty-printed to display them to the user. -data TypeErr - = -- | An undefined variable was encountered. - UnboundVar Var - | -- | A Skolem variable escaped its local context. - EscapedSkolem Var - | -- | Occurs check failure, i.e. infinite type. - Infinite IntVar UType - | -- | Error generated by the unifier. - UnifyErr (TypeF UType) (TypeF UType) - | -- | Type mismatch caught by 'unifyCheck'. The given term was - -- expected to have a certain type, but has a different type - -- instead. - Mismatch (Maybe Syntax) TypeJoin - | -- | Lambda argument type mismatch. - LambdaArgMismatch TypeJoin - | -- | Record field mismatch, i.e. based on the expected type we - -- were expecting a record with certain fields, but found one with - -- a different field set. - FieldsMismatch (Join (Set Var)) - | -- | A definition was encountered not at the top level. - DefNotTopLevel Term - | -- | A term was encountered which we cannot infer the type of. - -- This should never happen. - CantInfer Term - | -- | We can't infer the type of a record projection @r.x@ if we - -- don't concretely know the type of the record @r@. - CantInferProj Term - | -- | An attempt to project out a nonexistent field - UnknownProj Var Term - | -- | An invalid argument was provided to @atomic@. - InvalidAtomic InvalidAtomicReason Term - | -- | Some unification variables ended up in a type, probably due to - -- impredicativity. See https://github.com/swarm-game/swarm/issues/351 . - Impredicative - deriving (Show) - --- | Various reasons the body of an @atomic@ might be invalid. -data InvalidAtomicReason - = -- | The argument has too many tangible commands. - TooManyTicks Int - | -- | The argument uses some way to duplicate code: @def@, @let@, or lambda. - AtomicDupingThing - | -- | The argument referred to a variable with a non-simple type. - NonSimpleVarType Var UPolytype - | -- | The argument had a nested @atomic@ - NestedAtomic - | -- | The argument contained a long command - LongConst - deriving (Show) - -instance Fallible TypeF IntVar ContextualTypeErr where - occursFailure v t = mkRawTypeErr (Infinite v t) - mismatchFailure t1 t2 = mkRawTypeErr (UnifyErr t1 t2) - ------------------------------------------------------------- --- Type decomposition - --- | Decompose a type that is supposed to be a delay type. Also take --- the term which is supposed to have that type, for use in error --- messages. -decomposeDelayTy :: Syntax -> Sourced UType -> TC UType -decomposeDelayTy _ (_, UTyDelay a) = return a -decomposeDelayTy t ty = do - a <- fresh - _ <- unify (Just t) (mkJoin ty (UTyDelay a)) - return a - --- | Decompose a type that is supposed to be a command type. Also take --- the term which is supposed to have that type, for use in error --- messages. -decomposeCmdTy :: Syntax -> Sourced UType -> TC UType -decomposeCmdTy _ (_, UTyCmd a) = return a -decomposeCmdTy t ty = do - a <- fresh - _ <- unify (Just t) (mkJoin ty (UTyCmd a)) - return a - --- | Decompose a type that is supposed to be a function type. Also take --- the term which is supposed to have that type, for use in error --- messages. -decomposeFunTy :: Syntax -> Sourced UType -> TC (UType, UType) -decomposeFunTy _ (_, UTyFun ty1 ty2) = return (ty1, ty2) -decomposeFunTy t ty = do - ty1 <- fresh - ty2 <- fresh - _ <- unify (Just t) (mkJoin ty (UTyFun ty1 ty2)) - return (ty1, ty2) - --- | Decompose a type that is supposed to be a product type. Also take --- the term which is supposed to have that type, for use in error --- messages. -decomposeProdTy :: Syntax -> Sourced UType -> TC (UType, UType) -decomposeProdTy _ (_, UTyProd ty1 ty2) = return (ty1, ty2) -decomposeProdTy t ty = do - ty1 <- fresh - ty2 <- fresh - _ <- unify (Just t) (mkJoin ty (UTyProd ty1 ty2)) - return (ty1, ty2) - ------------------------------------------------------------- --- Type inference / checking - --- | Top-level type inference function: given a context of definition --- types and a top-level term, either return a type error or its --- type as a 'TModule'. -inferTop :: TCtx -> Syntax -> Either ContextualTypeErr TModule -inferTop ctx = runTC ctx . inferModule - --- | Infer the signature of a top-level expression which might --- contain definitions. -inferModule :: Syntax -> TC UModule -inferModule s@(Syntax l t) = addLocToTypeErr l $ case t of - -- For definitions with no type signature, make up a fresh type - -- variable for the body, infer the body under an extended context, - -- and unify the two. Then generalize the type and return an - -- appropriate context. - SDef r x Nothing t1 -> withFrame l (TCDef (lvVar x)) $ do - xTy <- fresh - t1' <- withBinding (lvVar x) (Forall [] xTy) $ infer t1 - _ <- unify (Just t1) (joined xTy (t1' ^. sType)) - pty <- generalize (t1' ^. sType) - return $ Module (Syntax' l (SDef r x Nothing t1') (UTyCmd UTyUnit)) (singleton (lvVar x) pty) - - -- If a (poly)type signature has been provided, skolemize it and - -- check the definition. - SDef r x (Just pty) t1 -> withFrame l (TCDef (lvVar x)) $ do - let upty = toU pty - uty <- skolemize upty - t1' <- withBinding (lvVar x) upty $ check t1 uty - return $ Module (Syntax' l (SDef r x (Just pty) t1') (UTyCmd UTyUnit)) (singleton (lvVar x) upty) - - -- To handle a 'TBind', infer the types of both sides, combining the - -- returned modules appropriately. Have to be careful to use the - -- correct context when checking the right-hand side in particular. - SBind mx c1 c2 -> do - -- First, infer the left side. - Module c1' ctx1 <- withFrame l TCBindL $ inferModule c1 - a <- decomposeCmdTy c1 (Actual, c1' ^. sType) - - -- Note we generalize here, similar to how we generalize at let - -- bindings, since the result type of the LHS will be the type of - -- the variable (if there is one). In many cases this doesn't - -- matter, but variables bound by top-level bind expressions can - -- end up in the top-level context (e.g. if someone writes `x <- - -- blah` at the REPL). We must generalize here, before adding the - -- variable to the context, since afterwards it will be too late: - -- we cannot generalize over any unification variables occurring - -- in the context. - -- - -- This is safe since it is always safe to generalize at any point. - -- - -- See #351, #1501. - genA <- generalize a - - -- Now infer the right side under an extended context: things in - -- scope on the right-hand side include both any definitions - -- created by the left-hand side, as well as a variable as in @x - -- <- c1; c2@. The order of extensions here matters: in theory, - -- c1 could define something with the same name as x, in which - -- case the bound x should shadow the defined one; hence, we apply - -- that binding /after/ (i.e. /within/) the application of @ctx1@. - withBindings ctx1 $ - maybe id ((`withBinding` genA) . lvVar) mx $ do - Module c2' ctx2 <- withFrame l TCBindR $ inferModule c2 - - -- We don't actually need the result type since we're just - -- going to return the entire type, but it's important to - -- ensure it's a command type anyway. Otherwise something - -- like 'move; 3' would be accepted with type int. - _ <- decomposeCmdTy c2 (Actual, c2' ^. sType) - - -- Ctx.union is right-biased, so ctx1 `union` ctx2 means later - -- definitions will shadow previous ones. Include the binder - -- (if any) as well, since binders are made available at the top - -- level, just like definitions. e.g. if the user writes `r <- build {move}`, - -- then they will be able to refer to r again later. - let ctxX = maybe Ctx.empty ((`Ctx.singleton` genA) . lvVar) mx - return $ - Module - (Syntax' l (SBind mx c1' c2') (c2' ^. sType)) - (ctx1 `Ctx.union` ctxX `Ctx.union` ctx2) - - -- In all other cases, there can no longer be any definitions in the - -- term, so delegate to 'infer'. - _anyOtherTerm -> trivMod <$> infer s - --- | Infer the type of a term which does not contain definitions, --- returning a type-annotated term. --- --- The only cases explicitly handled in 'infer' are those where --- pushing an expected type down into the term can't possibly help, --- e.g. most primitives, function application, and binds. --- --- For most everything else we prefer 'check' because it can often --- result in better and more localized type error messages. -infer :: Syntax -> TC (Syntax' UType) -infer s@(Syntax l t) = addLocToTypeErr l $ case t of - -- Primitives, i.e. things for which we immediately know the only - -- possible correct type, and knowing an expected type would provide - -- no extra information. - TUnit -> return $ Syntax' l TUnit UTyUnit - TConst c -> Syntax' l (TConst c) <$> (instantiate . toU $ inferConst c) - TDir d -> return $ Syntax' l (TDir d) UTyDir - TInt n -> return $ Syntax' l (TInt n) UTyInt - TAntiInt x -> return $ Syntax' l (TAntiInt x) UTyInt - TText x -> return $ Syntax' l (TText x) UTyText - TAntiText x -> return $ Syntax' l (TAntiText x) UTyText - TBool b -> return $ Syntax' l (TBool b) UTyBool - TRobot r -> return $ Syntax' l (TRobot r) UTyActor - TRequireDevice d -> return $ Syntax' l (TRequireDevice d) (UTyCmd UTyUnit) - TRequire n d -> return $ Syntax' l (TRequire n d) (UTyCmd UTyUnit) - SRequirements x t1 -> do - t1' <- infer t1 - return $ Syntax' l (SRequirements x t1') (UTyCmd UTyUnit) - - -- We should never encounter a TRef since they do not show up in - -- surface syntax, only as values while evaluating (*after* - -- typechecking). - TRef _ -> throwTypeErr l $ CantInfer t - -- Just look up variables in the context. - TVar x -> Syntax' l (TVar x) <$> lookup l x - -- It is helpful to handle lambdas in inference mode as well as - -- checking mode; in particular, we can handle lambdas with an - -- explicit type annotation on the argument. Just infer the body - -- under an extended context and return the appropriate function - -- type. - SLam x (Just argTy) body -> do - let uargTy = toU argTy - body' <- withBinding (lvVar x) (Forall [] uargTy) $ infer body - return $ Syntax' l (SLam x (Just argTy) body') (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 - -- 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 - -- applied is either (1) a primitive or variable whose type we can - -- easily infer, or (2) a nested application; in the second case in - -- particular, handling applications in inference mode means we can - -- stay in inference mode the whole way down the left-hand side of - -- the chain of applications. If we handled applications in - -- checking mode, we would constantly flip back and forth between - -- inference & checking and generate a fresh unification variable - -- 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) - - -- Then check that the argument has the right type. - x' <- check x argTy - - -- Call applyBindings explicitly, so that anything we learned - -- about unification variables while checking the type of the - -- argument can flow to later steps. This is especially helpful - -- while checking applications of polymorphic multi-argument - -- functions such as 'if'. Without this call to 'applyBindings', - -- type mismatches between the branches of an 'if' tend to get - -- caught in the unifier, resulting in vague "can't unify" - -- messages (for example, "if true {3} {move}" yields "can't - -- unify int and cmd unit"). With this 'applyBindings' call, we - -- get more specific errors about how the second branch was - -- expected to have the same type as the first (e.g. "expected - -- `move` to have type `int`, but it actually has type `cmd - -- unit`). - resTy' <- applyBindings resTy - - return $ Syntax' l (SApp f' x') resTy' - - -- We handle binds in inference mode for a similar reason to - -- application. - SBind mx c1 c2 -> do - c1' <- withFrame l TCBindL $ infer c1 - a <- decomposeCmdTy c1 (Actual, c1' ^. sType) - genA <- generalize a - c2' <- - maybe id ((`withBinding` genA) . lvVar) mx - . withFrame l TCBindR - $ infer c2 - _ <- decomposeCmdTy c2 (Actual, c2' ^. sType) - return $ Syntax' l (SBind mx c1' c2') (c2' ^. sType) - - -- Handle record projection in inference mode. Knowing the expected - -- type of r.x doesn't really help since we must infer the type of r - -- first anyway. - SProj t1 x -> do - t1' <- infer t1 - case t1' ^. sType of - UTyRcd m -> case M.lookup x m of - Just xTy -> return $ Syntax' l (SProj t1' x) xTy - Nothing -> throwTypeErr l $ UnknownProj x (SProj t1 x) - _ -> 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')) (UTyRcd (fmap (^. sType) m')) - - -- 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 - let upty = toU pty - -- Typecheck against skolemized polytype. - uty <- skolemize upty - _ <- check c uty - -- Make sure no skolem variables have escaped. - getCtx >>= mapM_ (noSkolems l) - -- 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) (c' ^. sType) - - -- Fallback: to infer the type of anything else, make up a fresh unification - -- variable for its type and check against it. - _ -> do - sTy <- fresh - check s sTy - --- | Infer the type of a constant. -inferConst :: Const -> Polytype -inferConst c = case c of - Wait -> [tyQ| int -> cmd unit |] - Noop -> [tyQ| cmd unit |] - Selfdestruct -> [tyQ| cmd unit |] - Move -> [tyQ| cmd unit |] - Backup -> [tyQ| cmd unit |] - Path -> [tyQ| (unit + int) -> ((int * int) + text) -> cmd (unit + dir) |] - Push -> [tyQ| cmd unit |] - Stride -> [tyQ| int -> cmd unit |] - Turn -> [tyQ| dir -> cmd unit |] - Grab -> [tyQ| cmd text |] - Harvest -> [tyQ| cmd text |] - Ignite -> [tyQ| dir -> cmd unit |] - Place -> [tyQ| text -> cmd unit |] - Ping -> [tyQ| actor -> cmd (unit + (int * int)) |] - Give -> [tyQ| actor -> text -> cmd unit |] - Equip -> [tyQ| text -> cmd unit |] - Unequip -> [tyQ| text -> cmd unit |] - Make -> [tyQ| text -> cmd unit |] - Has -> [tyQ| text -> cmd bool |] - Equipped -> [tyQ| text -> cmd bool |] - Count -> [tyQ| text -> cmd int |] - Reprogram -> [tyQ| actor -> {cmd a} -> cmd unit |] - Build -> [tyQ| {cmd a} -> cmd actor |] - Drill -> [tyQ| dir -> cmd (unit + text) |] - Use -> [tyQ| text -> dir -> cmd (unit + text) |] - Salvage -> [tyQ| cmd unit |] - Say -> [tyQ| text -> cmd unit |] - Listen -> [tyQ| cmd text |] - Log -> [tyQ| text -> cmd unit |] - View -> [tyQ| actor -> cmd unit |] - Appear -> [tyQ| text -> cmd unit |] - Create -> [tyQ| text -> cmd unit |] - Halt -> [tyQ| actor -> cmd unit |] - Time -> [tyQ| cmd int |] - Scout -> [tyQ| dir -> cmd bool |] - Whereami -> [tyQ| cmd (int * int) |] - Waypoint -> [tyQ| text -> int -> cmd (int * (int * int)) |] - 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 |] - Sniff -> [tyQ| text -> cmd int |] - Chirp -> [tyQ| text -> cmd dir |] - Watch -> [tyQ| dir -> cmd unit |] - Surveil -> [tyQ| (int * int) -> cmd unit |] - Heading -> [tyQ| cmd dir |] - Blocked -> [tyQ| cmd bool |] - Scan -> [tyQ| dir -> cmd (unit + text) |] - Upload -> [tyQ| actor -> cmd unit |] - Ishere -> [tyQ| text -> cmd bool |] - Isempty -> [tyQ| cmd bool |] - Self -> [tyQ| actor |] - Parent -> [tyQ| actor |] - Base -> [tyQ| actor |] - Meet -> [tyQ| cmd (unit + actor) |] - MeetAll -> [tyQ| (b -> actor -> cmd b) -> b -> cmd b |] - Whoami -> [tyQ| cmd text |] - Setname -> [tyQ| text -> cmd unit |] - Random -> [tyQ| int -> cmd int |] - Run -> [tyQ| text -> cmd unit |] - 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 |] - Force -> [tyQ| {a} -> a |] - Return -> [tyQ| a -> cmd a |] - Try -> [tyQ| {cmd a} -> {cmd a} -> cmd a |] - Undefined -> [tyQ| a |] - Fail -> [tyQ| text -> a |] - Not -> [tyQ| bool -> bool |] - Neg -> [tyQ| int -> int |] - Eq -> cmpBinT - Neq -> cmpBinT - Lt -> cmpBinT - Gt -> cmpBinT - Leq -> cmpBinT - Geq -> cmpBinT - And -> [tyQ| bool -> bool -> bool|] - Or -> [tyQ| bool -> bool -> bool|] - Add -> arithBinT - Sub -> arithBinT - Mul -> arithBinT - Div -> arithBinT - Exp -> arithBinT - Format -> [tyQ| a -> text |] - Concat -> [tyQ| text -> text -> text |] - Chars -> [tyQ| text -> int |] - Split -> [tyQ| int -> text -> (text * text) |] - CharAt -> [tyQ| int -> text -> int |] - ToChar -> [tyQ| int -> text |] - AppF -> [tyQ| (a -> b) -> a -> b |] - Swap -> [tyQ| text -> cmd text |] - Atomic -> [tyQ| cmd a -> cmd a |] - Instant -> [tyQ| cmd a -> cmd a |] - Key -> [tyQ| text -> key |] - InstallKeyHandler -> [tyQ| text -> (key -> cmd unit) -> cmd unit |] - Teleport -> [tyQ| actor -> (int * int) -> cmd unit |] - As -> [tyQ| actor -> {cmd a} -> cmd a |] - RobotNamed -> [tyQ| text -> cmd actor |] - RobotNumbered -> [tyQ| int -> cmd actor |] - Knows -> [tyQ| text -> cmd bool |] - where - cmpBinT = [tyQ| a -> a -> bool |] - arithBinT = [tyQ| int -> int -> int |] - --- | @check t ty@ checks that @t@ has type @ty@, returning a --- type-annotated AST if so. --- --- We try to stay in checking mode as far as possible, decomposing --- the expected type as we go and pushing it through the recursion. -check :: Syntax -> UType -> TC (Syntax' UType) -check s@(Syntax l t) expected = addLocToTypeErr l $ case t of - -- if t : ty, then {t} : {ty}. - -- Note that in theory, if the @Maybe Var@ component of the @SDelay@ - -- is @Just@, we should typecheck the body under a context extended - -- with a type binding for the variable, and ensure that the type of - -- the variable is the same as the type inferred for the overall - -- @SDelay@. However, we rely on the invariant that such recursive - -- @SDelay@ nodes are never generated from the surface syntax, only - -- dynamically at runtime when evaluating recursive let or def expressions, - -- so we don't have to worry about typechecking them here. - SDelay d s1 -> do - ty1 <- decomposeDelayTy s (Expected, expected) - s1' <- check s1 ty1 - return $ Syntax' l (SDelay d s1') (UTyDelay ty1) - - -- To check the type of a pair, make sure the expected type is a - -- product type, and push the two types down into the left and right. - SPair s1 s2 -> do - (ty1, ty2) <- decomposeProdTy s (Expected, expected) - s1' <- check s1 ty1 - s2' <- check s2 ty2 - return $ Syntax' l (SPair s1' s2') (UTyProd ty1 ty2) - - -- To check a lambda, make sure the expected type is a function type. - SLam x mxTy body -> do - (argTy, resTy) <- decomposeFunTy s (Expected, expected) - case toU mxTy of - Just xTy -> case unifyCheck argTy xTy 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. - Apart -> throwTypeErr l $ LambdaArgMismatch (joined argTy xTy) - -- Otherwise, make sure to unify the annotation with the - -- expected argument type. - _ -> void $ argTy =:= xTy - Nothing -> return () - body' <- withBinding (lvVar x) (Forall [] argTy) $ check body resTy - return $ Syntax' l (SLam x mxTy body') (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'. - - TConst c :$: at - | c `elem` [Atomic, Instant] -> do - argTy <- decomposeCmdTy s (Expected, expected) - at' <- check at (UTyCmd argTy) - atomic' <- infer (Syntax l (TConst c)) - -- It's important that we typecheck the subterm @at@ *before* we - -- check that it is a valid argument to @atomic@: this way we can - -- ensure that we have already inferred the types of any variables - -- referenced. - -- - -- When c is Atomic we validate that the argument to atomic is - -- guaranteed to operate within a single tick. When c is Instant - -- we skip this check. - when (c == Atomic) $ validAtomic at - return $ Syntax' l (SApp atomic' at') (UTyCmd argTy) - -- Checking the type of a let-expression. - SLet r x mxTy t1 t2 -> do - (upty, t1') <- case mxTy 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 - 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. - Just pty -> do - let upty = toU pty - uty <- skolemize upty - t1' <- withBinding (lvVar x) upty $ check t1 uty - return (upty, t1') - - -- Now check the type of the body. - t2' <- withBinding (lvVar x) upty $ check t2 expected - - -- Make sure no skolem variables have escaped. - getCtx >>= mapM_ (noSkolems l) - - -- Return the annotated let. - return $ Syntax' l (SLet r x mxTy t1' t2') expected - - -- Definitions can only occur at the top level. - SDef {} -> throwTypeErr l $ DefNotTopLevel t - -- To check a record, ensure the expected type is a record type, - -- ensure all the right fields are present, and push the expected - -- types of all the fields down into recursive checks. - -- - -- We have to be careful here --- if the expected type is not - -- manifestly a record type but might unify with one (i.e. if the - -- expected type is a variable) then we can't generate type - -- variables for its subparts and push them, we have to switch - -- completely into inference mode. See Note [Checking and inference - -- for record literals]. - SRcd fields - | UTyRcd tyMap <- expected -> do - let expectedFields = M.keysSet tyMap - actualFields = M.keysSet fields - when (actualFields /= expectedFields) $ - throwTypeErr l $ - FieldsMismatch (joined expectedFields actualFields) - m' <- itraverse (\x ms -> check (fromMaybe (STerm (TVar x)) ms) (tyMap ! x)) fields - return $ Syntax' l (SRcd (Just <$> m')) expected - - -- Fallback: switch into inference mode, and check that the type we - -- get is what we expected. - _ -> do - Syntax' l' t' actual <- infer s - Syntax' l' t' <$> unify (Just s) (joined expected actual) - --- ~~~~ Note [Checking and inference for record literals] --- --- We need to handle record literals in both inference and checking --- mode. By way of contrast, with a pair, if we are in checking --- mode and the expected type is not manifestly a product type, we --- can just generate fresh unification variables for the types of --- the two components, generate a constraint that the expected type --- is equal to a product type of these two fresh types, and continue --- in checking mode on both sides. With records, however, we cannot --- do that; if we are checking a record and the expected type is not --- manifestly a record type, we must simply switch into inference --- mode. However, it is still helpful to be able to handle records --- in checking mode too, since if we know a record type it is --- helpful to be able to push the field types down into the fields. - ------------------------------------------------------------- --- Special atomic checking - --- | Ensure a term is a valid argument to @atomic@. Valid arguments --- may not contain @def@, @let@, or lambda. Any variables which are --- referenced must have a primitive, first-order type such as --- @text@ or @int@ (in particular, no functions, @cmd@, or --- @delay@). We simply assume that any locally bound variables are --- OK without checking their type: the only way to bind a variable --- locally is with a binder of the form @x <- c1; c2@, where @c1@ is --- some primitive command (since we can't refer to external --- variables of type @cmd a@). If we wanted to do something more --- sophisticated with locally bound variables we would have to --- inline this analysis into typechecking proper, instead of having --- it be a separate, out-of-band check. --- --- The goal is to ensure that any argument to @atomic@ is guaranteed --- to evaluate and execute in some small, finite amount of time, so --- that it's impossible to write a term which runs atomically for an --- indefinite amount of time and freezes the rest of the game. Of --- course, nothing prevents one from writing a large amount of code --- inside an @atomic@ block; but we want the execution time to be --- linear in the size of the code. --- --- We also ensure that the atomic block takes at most one tick, --- i.e. contains at most one tangible command. For example, @atomic --- (move; move)@ is invalid, since that would allow robots to move --- twice as fast as usual by doing both actions in one tick. -validAtomic :: Syntax -> TC () -validAtomic s@(Syntax l t) = do - n <- analyzeAtomic S.empty s - when (n > 1) $ throwTypeErr l $ InvalidAtomic (TooManyTicks n) t - --- | Analyze an argument to @atomic@: ensure it contains no nested --- atomic blocks and no references to external variables, and count --- how many tangible commands it will execute. -analyzeAtomic :: Set Var -> Syntax -> TC Int -analyzeAtomic locals (Syntax l t) = case t of - -- Literals, primitives, etc. that are fine and don't require a tick - -- to evaluate - TUnit {} -> return 0 - TDir {} -> return 0 - TInt {} -> return 0 - TAntiInt {} -> return 0 - TText {} -> return 0 - TAntiText {} -> return 0 - TBool {} -> return 0 - TRobot {} -> return 0 - TRequireDevice {} -> return 0 - TRequire {} -> return 0 - SRequirements {} -> return 0 - -- Constants. - TConst c - -- Nested 'atomic' is not allowed. - | c == Atomic -> throwTypeErr l $ InvalidAtomic NestedAtomic t - -- We cannot allow long commands (commands that may require more - -- than one tick to execute) since that could freeze the game. - | isLong c -> throwTypeErr l $ InvalidAtomic LongConst t - -- Otherwise, return 1 or 0 depending on whether the command is - -- tangible. - | otherwise -> return $ if isTangible c then 1 else 0 - -- Special case for if: number of tangible commands is the *max* of - -- the branches instead of the sum, since exactly one of them will be - -- 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. - SPair s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2 - SApp s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2 - SDelay _ 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 - SRcd m -> sum <$> mapM analyzeField (M.assocs m) - where - analyzeField :: (Var, Maybe Syntax) -> TC Int - analyzeField (x, Nothing) = analyzeAtomic locals (STerm (TVar x)) - analyzeField (_, Just s) = analyzeAtomic locals s - SProj {} -> return 0 - -- Variables are allowed if bound locally, or if they have a simple type. - TVar x - | x `S.member` locals -> return 0 - | otherwise -> do - mxTy <- Ctx.lookup x <$> getCtx - case mxTy of - -- If the variable is undefined, return 0 to indicate the - -- atomic block is valid, because we'd rather have the error - -- caught by the real name+type checking. - Nothing -> return 0 - Just xTy -> do - -- Use applyBindings to make sure that we apply as much - -- information as unification has learned at this point. In - -- theory, continuing to typecheck other terms elsewhere in - -- the program could give us further information about xTy, - -- so we might have incomplete information at this point. - -- However, since variables referenced in an atomic block - -- must necessarily have simple types, it's unlikely this - -- will really make a difference. The alternative, more - -- "correct" way to do this would be to simply emit some - -- constraints at this point saying that xTy must be a - -- simple type, and check later that the constraint holds, - -- after performing complete type inference. However, since - -- the current approach is much simpler, we'll stick with - -- this until such time as we have concrete examples showing - -- that the more correct, complex way is necessary. - xTy' <- applyBindings xTy - if isSimpleUPolytype xTy' - then return 0 - else throwTypeErr l $ InvalidAtomic (NonSimpleVarType x xTy') t - -- No lambda, `let` or `def` allowed! - SLam {} -> throwTypeErr l $ InvalidAtomic AtomicDupingThing t - SLet {} -> throwTypeErr l $ InvalidAtomic AtomicDupingThing t - SDef {} -> throwTypeErr l $ InvalidAtomic AtomicDupingThing t - -- We should never encounter a TRef since they do not show up in - -- surface syntax, only as values while evaluating (*after* - -- typechecking). - TRef {} -> throwTypeErr l $ CantInfer t - -- An explicit type annotation doesn't change atomicity - SAnnotate s _ -> analyzeAtomic locals s - --- | A simple polytype is a simple type with no quantifiers. -isSimpleUPolytype :: UPolytype -> Bool -isSimpleUPolytype (Forall [] ty) = isSimpleUType ty -isSimpleUPolytype _ = False - --- | A simple type is a sum or product of base types. -isSimpleUType :: UType -> Bool -isSimpleUType = \case - UTyBase {} -> True - UTyVar {} -> False - UTySum ty1 ty2 -> isSimpleUType ty1 && isSimpleUType ty2 - UTyProd ty1 ty2 -> isSimpleUType ty1 && isSimpleUType ty2 - UTyFun {} -> False - UTyCmd {} -> False - UTyDelay {} -> False - -- Make the pattern-match coverage checker happy - UVar {} -> False - UTerm {} -> False diff --git a/src/Swarm/Language/Typecheck/Unify.hs b/src/Swarm/Language/Typecheck/Unify.hs deleted file mode 100644 --- a/src/Swarm/Language/Typecheck/Unify.hs +++ /dev/null @@ -1,90 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Utilities related to type unification. -module Swarm.Language.Typecheck.Unify ( - UnifyStatus (..), - unifyCheck, -) where - -import Control.Unification -import Data.Foldable qualified as F -import Data.Function (on) -import Data.Map qualified as M -import Data.Map.Merge.Lazy qualified as M -import Swarm.Language.Types - --- | The result of doing a unification check on two types. -data UnifyStatus - = -- | The two types are definitely not equal; they will never unify - -- no matter how any unification variables get filled in. For - -- example, (int * u0) and (u1 -> u2) are apart: the first is a - -- product type and the second is a function type. - Apart - | -- | The two types might unify, depending on how unification - -- variables get filled in, but we're not sure. For example, - -- (int * u0) and (u1 * bool). - MightUnify - | -- | The two types are most definitely equal, and we don't need to - -- bother generating a constraint to make them so. For example, - -- (int * text) and (int * text). - Equal - deriving (Eq, Ord, Read, Show) - --- | The @Semigroup@ instance for @UnifyStatus@ is used to combine --- results for compound types. -instance Semigroup UnifyStatus where - -- If either part of a compound type is apart, then the whole thing is. - Apart <> _ = Apart - _ <> Apart = Apart - -- Otherwise, if we're unsure about either part of a compound type, - -- then we're unsure about the whole thing. - MightUnify <> _ = MightUnify - _ <> MightUnify = MightUnify - -- Finally, if both parts are definitely equal then the whole thing is. - Equal <> Equal = Equal - -instance Monoid UnifyStatus where - mempty = Equal - --- | Given two types, try hard to prove either that (1) they are --- 'Apart', i.e. cannot possibly unify, or (2) they are definitely --- 'Equal'. In case (1), we can generate a much better error --- message at the instant the two types come together than we could --- if we threw a constraint into the unifier. In case (2), we don't --- have to bother with generating a trivial constraint. If we don't --- know for sure whether they will unify, return 'MightUnify'. -unifyCheck :: UType -> UType -> UnifyStatus -unifyCheck ty1 ty2 = case (ty1, ty2) of - (UVar x, UVar y) - | x == y -> Equal - | otherwise -> MightUnify - (UVar _, _) -> MightUnify - (_, UVar _) -> MightUnify - (UTerm t1, UTerm t2) -> unifyCheckF t1 t2 - -unifyCheckF :: TypeF UType -> TypeF UType -> UnifyStatus -unifyCheckF t1 t2 = case (t1, t2) of - (TyBaseF b1, TyBaseF b2) -> case b1 == b2 of - True -> Equal - False -> Apart - (TyBaseF {}, _) -> Apart - (TyVarF v1, TyVarF v2) -> case v1 == v2 of - True -> Equal - False -> Apart - (TyVarF {}, _) -> Apart - (TySumF t11 t12, TySumF t21 t22) -> unifyCheck t11 t21 <> unifyCheck t12 t22 - (TySumF {}, _) -> Apart - (TyProdF t11 t12, TyProdF t21 t22) -> unifyCheck t11 t21 <> unifyCheck t12 t22 - (TyProdF {}, _) -> Apart - (TyRcdF m1, TyRcdF m2) -> - case ((==) `on` M.keysSet) m1 m2 of - False -> Apart - _ -> F.fold (M.merge M.dropMissing M.dropMissing (M.zipWithMatched (const unifyCheck)) m1 m2) - (TyRcdF {}, _) -> Apart - (TyCmdF c1, TyCmdF c2) -> unifyCheck c1 c2 - (TyCmdF {}, _) -> Apart - (TyDelayF c1, TyDelayF c2) -> unifyCheck c1 c2 - (TyDelayF {}, _) -> Apart - (TyFunF t11 t12, TyFunF t21 t22) -> unifyCheck t11 t21 <> unifyCheck t12 t22 - (TyFunF {}, _) -> Apart diff --git a/src/Swarm/Language/Typed.hs b/src/Swarm/Language/Typed.hs deleted file mode 100644 --- a/src/Swarm/Language/Typed.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.Language.Typed (Typed (..), value, polytype, requires) where - -import Control.Lens (makeLenses) -import Data.Aeson (ToJSON) -import Data.Aeson.Types (FromJSON) -import GHC.Generics (Generic) -import Swarm.Language.Requirement (Requirements) -import Swarm.Language.Types (Polytype) - --- | A value, or a hole, or something else that has its type & requirements fixed -data Typed v = Typed - { _value :: v - , _polytype :: Polytype - , _requires :: Requirements - } - deriving (Show, Eq, Generic, FromJSON, ToJSON) - -makeLenses ''Typed diff --git a/src/Swarm/Language/Types.hs b/src/Swarm/Language/Types.hs deleted file mode 100644 --- a/src/Swarm/Language/Types.hs +++ /dev/null @@ -1,389 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- for the Data IntVar instance - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Types for the Swarm programming language and related utilities. -module Swarm.Language.Types ( - -- * Basic definitions - BaseTy (..), - Var, - TypeF (..), - - -- * @Type@ - Type, - tyVars, - pattern TyBase, - pattern TyVar, - pattern TyVoid, - pattern TyUnit, - pattern TyInt, - pattern TyText, - pattern TyDir, - pattern TyBool, - pattern TyActor, - pattern TyKey, - pattern (:+:), - pattern (:*:), - pattern (:->:), - pattern TyRcd, - pattern TyCmd, - pattern TyDelay, - - -- * @UType@ - UType, - pattern UTyBase, - pattern UTyVar, - pattern UTyVoid, - pattern UTyUnit, - pattern UTyInt, - pattern UTyText, - pattern UTyDir, - pattern UTyBool, - pattern UTyActor, - pattern UTyKey, - pattern UTySum, - pattern UTyProd, - pattern UTyFun, - pattern UTyRcd, - pattern UTyCmd, - pattern UTyDelay, - - -- ** Utilities - ucata, - mkVarName, - - -- * Polytypes - Poly (..), - Polytype, - pattern PolyUnit, - UPolytype, - - -- * Contexts - TCtx, - UCtx, - - -- * The 'WithU' class - WithU (..), -) where - -import Control.Monad (guard) -import Control.Unification -import Control.Unification.IntVar -import Data.Aeson (FromJSON, ToJSON) -import Data.Data (Data) -import Data.Foldable (fold) -import Data.Function (on) -import Data.Functor.Fixedpoint -import Data.Kind qualified -import Data.Map.Merge.Strict qualified as M -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as M -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 -import Witch - ------------------------------------------------------------- --- Types ------------------------------------------------------------- - --- | Base types. -data BaseTy - = -- | The void type, with no inhabitants. - BVoid - | -- | The unit type, with a single inhabitant. - BUnit - | -- | Signed, arbitrary-size integers. - BInt - | -- | Unicode strings. - BText - | -- | Directions. - BDir - | -- | Booleans. - BBool - | -- | "Actors", i.e. anything that can do stuff. Internally, these - -- are all just "robots", but we give them a more generic - -- in-game name because they could represent other things like - -- aliens, animals, seeds, ... - BActor - | -- | Keys, i.e. things that can be pressed on the keyboard - BKey - deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON) - --- | A "structure functor" encoding the shape of type expressions. --- Actual types are then represented by taking a fixed point of this --- functor. We represent types in this way, via a "two-level type", --- so that we can work with the @unification-fd@ package (see --- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/). -data TypeF t - = -- | A base type. - TyBaseF BaseTy - | -- | A type variable. - TyVarF Var - | -- | Commands, with return type. Note that - -- commands form a monad. - TyCmdF t - | -- | Type of delayed computations. - TyDelayF t - | -- | Sum type. - TySumF t t - | -- | Product type. - TyProdF t t - | -- | Function type. - TyFunF t t - | -- | Record type. - TyRcdF (Map Var t) - deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Generic1, Unifiable, Data, FromJSON, ToJSON) - --- | Unify two Maps by insisting they must have exactly the same keys, --- and if so, simply matching up corresponding values to be --- recursively unified. There could be other reasonable --- implementations, but in our case we will use this for unifying --- record types, and we do not have any subtyping, so record types --- will only unify if they have exactly the same keys. -instance Ord k => Unifiable (Map k) where - zipMatch m1 m2 = do - guard $ ((==) `on` M.keysSet) m1 m2 - pure $ M.merge M.dropMissing M.dropMissing (M.zipWithMatched (\_ a1 a2 -> Right (a1, a2))) m1 m2 - --- | @Type@ is now defined as the fixed point of 'TypeF'. It would be --- annoying to manually apply and match against 'Fix' constructors --- everywhere, so we provide pattern synonyms that allow us to work --- 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 = cata (\case TyVarF x -> S.singleton x; f -> fold f) - --- The derived Data instance is so we can make a quasiquoter for types. -deriving instance Data Type - --- | 'UType's are like 'Type's, but also contain unification --- variables. 'UType' is defined via 'UTerm', which is also a kind --- of fixed point (in fact, 'UType' is the /free monad/ over 'TypeF'). --- --- Just as with 'Type', we provide a bunch of pattern synonyms for --- working with 'UType' as if it were defined directly. -type UType = UTerm TypeF IntVar - --- The derived Data instances are so we can make a quasiquoter for --- types. -deriving instance Data UType -deriving instance Data IntVar - --- | A generic /fold/ for things defined via 'UTerm' (including, in --- particular, 'UType'). This probably belongs in the --- @unification-fd@ package, but since it doesn't provide one, we --- define it here. -ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a -ucata f _ (UVar v) = f v -ucata f g (UTerm t) = g (fmap (ucata f g) t) - --- | A quick-and-dirty method for turning an 'IntVar' (used internally --- 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 + (maxBound :: Int) + 1))) - --- | For convenience, so we can write /e.g./ @"a"@ instead of @TyVar "a"@. -instance IsString Type where - fromString x = TyVar (from @String x) - -instance IsString UType where - fromString x = UTyVar (from @String x) - ------------------------------------------------------------- --- Contexts ------------------------------------------------------------- - --- | 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 - --- | 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 - ------------------------------------------------------------- --- 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 [Var] t - deriving (Show, Eq, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON) - --- | A polytype without unification variables. -type Polytype = Poly Type - --- | A polytype with unification variables. -type UPolytype = Poly UType - ------------------------------------------------------------- --- WithU ------------------------------------------------------------- - --- | In several cases we have two versions of something: a "normal" --- version, and a @U@ version with unification variables in it --- (/e.g./ 'Type' vs 'UType', 'Polytype' vs 'UPolytype', 'TCtx' vs --- 'UCtx'). This class abstracts over the process of converting back --- and forth between them. --- --- In particular, @'WithU' t@ represents the fact that the type @t@ --- also has a @U@ counterpart, with a way to convert back and forth. --- Note, however, that converting back may be "unsafe" in the sense --- that it requires an extra burden of proof to guarantee that it is --- used only on inputs that are safe. -class WithU t where - -- | The associated "@U@-version" of the type @t@. - type U t :: Data.Kind.Type - - -- | Convert from @t@ to its associated "@U@-version". This - -- direction is always safe (we simply have no unification - -- variables even though the type allows it). - toU :: t -> U t - - -- | Convert from the associated "@U@-version" back to @t@. - -- Generally, this direction requires somehow knowing that there - -- are no longer any unification variables in the value being - -- converted. - fromU :: U t -> Maybe t - --- | 'Type' is an instance of 'WithU', with associated type 'UType'. -instance WithU Type where - type U Type = UType - toU = unfreeze - fromU = freeze - --- | A 'WithU' instance can be lifted through any functor (including, --- in particular, 'Ctx' and 'Poly'). -instance (WithU t, Traversable f) => WithU (f t) where - type U (f t) = f (U t) - toU = fmap toU - fromU = traverse fromU - ------------------------------------------------------------- --- Pattern synonyms ------------------------------------------------------------- - -pattern TyBase :: BaseTy -> Type -pattern TyBase b = Fix (TyBaseF b) - -pattern TyVar :: Var -> Type -pattern TyVar v = Fix (TyVarF v) - -pattern TyVoid :: Type -pattern TyVoid = Fix (TyBaseF BVoid) - -pattern TyUnit :: Type -pattern TyUnit = Fix (TyBaseF BUnit) - -pattern TyInt :: Type -pattern TyInt = Fix (TyBaseF BInt) - -pattern TyText :: Type -pattern TyText = Fix (TyBaseF BText) - -pattern TyDir :: Type -pattern TyDir = Fix (TyBaseF BDir) - -pattern TyBool :: Type -pattern TyBool = Fix (TyBaseF BBool) - -pattern TyActor :: Type -pattern TyActor = Fix (TyBaseF BActor) - -pattern TyKey :: Type -pattern TyKey = Fix (TyBaseF BKey) - -infixr 5 :+: - -pattern (:+:) :: Type -> Type -> Type -pattern ty1 :+: ty2 = Fix (TySumF ty1 ty2) - -infixr 6 :*: - -pattern (:*:) :: Type -> Type -> Type -pattern ty1 :*: ty2 = Fix (TyProdF ty1 ty2) - -infixr 1 :->: - -pattern (:->:) :: Type -> Type -> Type -pattern ty1 :->: ty2 = Fix (TyFunF ty1 ty2) - -pattern TyRcd :: Map Var Type -> Type -pattern TyRcd m = Fix (TyRcdF m) - -pattern TyCmd :: Type -> Type -pattern TyCmd ty1 = Fix (TyCmdF ty1) - -pattern TyDelay :: Type -> Type -pattern TyDelay ty1 = Fix (TyDelayF ty1) - -pattern UTyBase :: BaseTy -> UType -pattern UTyBase b = UTerm (TyBaseF b) - -pattern UTyVar :: Var -> UType -pattern UTyVar v = UTerm (TyVarF v) - -pattern UTyVoid :: UType -pattern UTyVoid = UTerm (TyBaseF BVoid) - -pattern UTyUnit :: UType -pattern UTyUnit = UTerm (TyBaseF BUnit) - -pattern UTyInt :: UType -pattern UTyInt = UTerm (TyBaseF BInt) - -pattern UTyText :: UType -pattern UTyText = UTerm (TyBaseF BText) - -pattern UTyDir :: UType -pattern UTyDir = UTerm (TyBaseF BDir) - -pattern UTyBool :: UType -pattern UTyBool = UTerm (TyBaseF BBool) - -pattern UTyActor :: UType -pattern UTyActor = UTerm (TyBaseF BActor) - -pattern UTyKey :: UType -pattern UTyKey = UTerm (TyBaseF BKey) - -pattern UTySum :: UType -> UType -> UType -pattern UTySum ty1 ty2 = UTerm (TySumF ty1 ty2) - -pattern UTyProd :: UType -> UType -> UType -pattern UTyProd ty1 ty2 = UTerm (TyProdF ty1 ty2) - -pattern UTyFun :: UType -> UType -> UType -pattern UTyFun ty1 ty2 = UTerm (TyFunF ty1 ty2) - -pattern UTyRcd :: Map Var UType -> UType -pattern UTyRcd m = UTerm (TyRcdF m) - -pattern UTyCmd :: UType -> UType -pattern UTyCmd ty1 = UTerm (TyCmdF ty1) - -pattern UTyDelay :: UType -> UType -pattern UTyDelay ty1 = UTerm (TyDelayF ty1) - -pattern PolyUnit :: Polytype -pattern PolyUnit = Forall [] (TyCmd TyUnit) - --- Derive aeson instances for type serialization -deriving instance Generic Type -deriving instance ToJSON Type -deriving instance FromJSON Type diff --git a/src/Swarm/Language/Value.hs b/src/Swarm/Language/Value.hs deleted file mode 100644 --- a/src/Swarm/Language/Value.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Values and environments used for interpreting the Swarm language. -module Swarm.Language.Value ( - -- * Values - Value (..), - stripVResult, - prettyValue, - valueToTerm, - - -- * Environments - Env, -) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Bool (bool) -import Data.List (foldl') -import Data.Map (Map) -import Data.Map qualified as M -import Data.Set qualified as S -import Data.Set.Lens (setOf) -import Data.Text (Text) -import GHC.Generics (Generic) -import Swarm.Language.Context -import Swarm.Language.Key (KeyCombo, prettyKeyCombo) -import Swarm.Language.Pretty (prettyText) -import Swarm.Language.Syntax - --- | A /value/ is a term that cannot (or does not) take any more --- evaluation steps on its own. -data Value where - -- | The unit value. - VUnit :: Value - -- | An integer. - VInt :: Integer -> Value - -- | Literal text. - VText :: Text -> Value - -- | A direction. - VDir :: Direction -> Value - -- | A boolean. - VBool :: Bool -> Value - -- | A reference to a robot. - VRobot :: Int -> Value - -- | An injection into a sum type. False = left, True = right. - VInj :: Bool -> Value -> Value - -- | A pair. - VPair :: Value -> Value -> Value - -- | A /closure/, representing a lambda term along with an - -- environment containing bindings for any free variables in the - -- body of the lambda. - VClo :: Var -> Term -> Env -> Value - -- | An application of a constant to some value arguments, - -- potentially waiting for more arguments. If a constant - -- application is fully saturated (as defined by its 'arity'), - -- whether it is a value or not depends on whether or not it - -- represents a command (as defined by 'isCmd'). If a command - -- (e.g. 'Build'), it is a value, and awaits an 'Swarm.Game.CESK.FExec' frame - -- which will cause it to execute. Otherwise (e.g. 'If'), it is - -- not a value, and will immediately reduce. - VCApp :: Const -> [Value] -> Value - -- | A definition, which does not take effect until executed. - -- The @Bool@ indicates whether the definition is recursive. - VDef :: Bool -> Var -> Term -> Env -> Value - -- | The result of a command, consisting of the result of the - -- command as well as an environment of bindings from 'TDef' - -- commands. - VResult :: Value -> Env -> Value - -- | An unevaluated bind expression, waiting to be executed, of the - -- form /i.e./ @c1 ; c2@ or @x <- c1; c2@. We also store an 'Env' - -- in which to interpret the commands. - VBind :: Maybe Var -> Term -> Term -> Env -> Value - -- | A (non-recursive) delayed term, along with its environment. If - -- a term would otherwise be evaluated but we don't want it to be - -- (/e.g./ as in the case of arguments to an 'if', or a recursive - -- binding), we can stick a 'TDelay' on it, which turns it into a - -- value. Delayed terms won't be evaluated until 'Force' is - -- applied to them. - VDelay :: Term -> Env -> Value - -- | A reference to a memory cell in the store. - VRef :: Int -> Value - -- | A record value. - VRcd :: Map Var Value -> Value - -- | A keyboard input. - VKey :: KeyCombo -> Value - -- | A 'requirements' command awaiting execution. - VRequirements :: Text -> Term -> Env -> Value - deriving (Eq, Show, Generic, FromJSON, ToJSON) - --- | Ensure that a value is not wrapped in 'VResult'. -stripVResult :: Value -> Value -stripVResult (VResult v _) = stripVResult v -stripVResult v = v - --- | Pretty-print a value. -prettyValue :: Value -> Text -prettyValue = prettyText . valueToTerm - --- | Inject a value back into a term. -valueToTerm :: Value -> Term -valueToTerm VUnit = TUnit -valueToTerm (VInt n) = TInt n -valueToTerm (VText s) = TText s -valueToTerm (VDir d) = TDir d -valueToTerm (VBool b) = TBool b -valueToTerm (VRobot r) = TRobot r -valueToTerm (VInj s v) = TApp (TConst (bool Inl Inr s)) (valueToTerm v) -valueToTerm (VPair v1 v2) = TPair (valueToTerm v1) (valueToTerm v2) -valueToTerm (VClo x t e) = - M.foldrWithKey - (\y v -> TLet False y Nothing (valueToTerm v)) - (TLam x Nothing t) - (M.restrictKeys (unCtx e) (S.delete x (setOf freeVarsV (Syntax' NoLoc t ())))) -valueToTerm (VCApp c vs) = foldl' TApp (TConst c) (reverse (map valueToTerm vs)) -valueToTerm (VDef r x t _) = TDef r x Nothing t -valueToTerm (VResult v _) = valueToTerm v -valueToTerm (VBind mx c1 c2 _) = TBind mx c1 c2 -valueToTerm (VDelay t _) = TDelay SimpleDelay t -valueToTerm (VRef n) = TRef n -valueToTerm (VRcd m) = TRcd (Just . valueToTerm <$> m) -valueToTerm (VKey kc) = TApp (TConst Key) (TText (prettyKeyCombo kc)) -valueToTerm (VRequirements x t _) = TRequirements x t - --- | An environment is a mapping from variable names to values. -type Env = Ctx Value diff --git a/src/Swarm/Log.hs b/src/Swarm/Log.hs deleted file mode 100644 --- a/src/Swarm/Log.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A data type to represent log messages, both for robot logs and --- the system log. -module Swarm.Log ( - Severity (..), - RobotLogSource (..), - LogSource (..), - LogEntry (..), - leTime, - leSource, - leSeverity, - leName, - leText, -) where - -import Control.Lens (makeLenses) -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) -import Swarm.Game.CESK (TickNumber) -import Swarm.Game.Location (Location) -import Swarm.Game.Universe (Cosmic) - --- | Severity of the error - critical errors are bugs --- and should be reported as Issues. -data Severity = Info | Debug | Warning | Error | Critical - deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) - --- | How a robot log entry was produced. -data RobotLogSource - = -- | Produced by 'Swarm.Language.Syntax.Say' - Said - | -- | Produced by 'Swarm.Language.Syntax.Log' - Logged - | -- | Produced as the result of an error. - RobotError - deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) - --- | Source of a log entry. -data LogSource - = -- | Log produced by a robot. Stores information about which - -- command was used and the ID and location of the producing - -- robot. - RobotLog RobotLogSource Int (Cosmic Location) - | -- | Log produced by an exception or system. - SystemLog - deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) - --- | A log entry. -data LogEntry = LogEntry - { _leTime :: TickNumber - -- ^ The time at which the entry was created. - -- Note that this is the first field we sort on. - , _leSource :: LogSource - -- ^ Where this log message came from. - , _leSeverity :: Severity - -- ^ Severity level of this log message. - , _leName :: Text - -- ^ Name of the robot or subsystem that generated this log entry. - , _leText :: Text - -- ^ The text of the log entry. - } - deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) - -makeLenses ''LogEntry diff --git a/src/Swarm/ReadableIORef.hs b/src/Swarm/ReadableIORef.hs deleted file mode 100644 --- a/src/Swarm/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.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/TUI/Border.hs b/src/Swarm/TUI/Border.hs deleted file mode 100644 --- a/src/Swarm/TUI/Border.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Special border drawing functions that can include labels in more --- places than just the top center. -module Swarm.TUI.Border ( - -- * Horizontal border labels - HBorderLabels, - plainHBorder, - leftLabel, - centerLabel, - rightLabel, - - -- * Rectangular border labels - BorderLabels, - plainBorder, - topLabels, - bottomLabels, - - -- * Border-drawing functions - hBorderWithLabels, - borderWithLabels, -) where - -import Brick -import Brick.Widgets.Border -import Control.Lens (makeLenses, to, (^.)) -import Data.Function ((&)) -import Graphics.Vty qualified as V - --- | Labels for a horizontal border, with optional left, middle, and --- right labels. -data HBorderLabels n = HBorderLabels - { _leftLabel :: Maybe (Widget n) - , _centerLabel :: Maybe (Widget n) - , _rightLabel :: Maybe (Widget n) - } - --- | A plain horizontal border with no labels. -plainHBorder :: HBorderLabels n -plainHBorder = HBorderLabels Nothing Nothing Nothing - --- | Labels for a rectangular border, with optional left, middle, and --- right labels on the top and bottom. -data BorderLabels n = BorderLabels - { _topLabels :: HBorderLabels n - , _bottomLabels :: HBorderLabels n - } - --- | A plain rectangular border with no labels. -plainBorder :: BorderLabels n -plainBorder = BorderLabels plainHBorder plainHBorder - -makeLenses ''HBorderLabels -makeLenses ''BorderLabels - --- | Draw a horizontal border with three optional labels. The left --- label (if present) will be placed two units away from the left --- end of the border, and the right label will be placed two units --- away from the right end. The center label, if present, will --- always be centered in the border overall, regardless of the width --- of the left and right labels. This ensures that when the labels --- change width, they do not cause the other labels to wiggle. -hBorderWithLabels :: - HBorderLabels n -> Widget n -hBorderWithLabels (HBorderLabels l c r) = - Widget Greedy Fixed $ do - let renderLabel = render . maybe emptyWidget (vLimit 1) - rl <- renderLabel l - rc <- renderLabel c - rr <- renderLabel r - - -- Figure out how wide the whole border is supposed to be - ctx <- getContext - let w = ctx ^. availWidthL - - -- Get the widths of the labels - lw = V.imageWidth (image rl) - cw = V.imageWidth (image rc) - - -- Now render the border with labels. - render $ - hBox - [ hLimit 2 hBorder - , Widget Fixed Fixed (return rl) - , -- We calculate the specific width of border between the left - -- and center labels needed to ensure that the center label is - -- in the right place. Note, using (cw + 1) `div` 2, as - -- opposed to cw `div` 2, means that the placement of the - -- center label will be left-biased: if it does not fit - -- exactly at the center it will be placed just to the left of - -- center. - hLimit (w `div` 2 - 2 - lw - (cw + 1) `div` 2) hBorder - , Widget Fixed Fixed (return rc) - , -- The border between center and right greedily fills up any - -- remaining width. - hBorder - , Widget Fixed Fixed (return rr) - , hLimit 2 hBorder - ] - --- | Put a rectangular border around the specified widget with the --- specified label widgets placed around the border. -borderWithLabels :: BorderLabels n -> Widget n -> Widget n -borderWithLabels labels wrapped = - Widget (hSize wrapped) (vSize wrapped) $ do - c <- getContext - - middleResult <- - wrapped - & vLimit (c ^. availHeightL - 2) - & hLimit (c ^. availWidthL - 2) - & render - - let tl = joinableBorder (Edges False True False True) - tr = joinableBorder (Edges False True True False) - bl = joinableBorder (Edges True False False True) - br = joinableBorder (Edges True False True False) - top = tl <+> hBorderWithLabels (labels ^. topLabels) <+> tr - bottom = bl <+> hBorderWithLabels (labels ^. bottomLabels) <+> br - middle = vBorder <+> Widget Fixed Fixed (return middleResult) <+> vBorder - total = top <=> middle <=> bottom - - total - & vLimit (middleResult ^. imageL . to V.imageHeight + 2) - & hLimit (middleResult ^. imageL . to V.imageWidth + 2) - & render diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs deleted file mode 100644 --- a/src/Swarm/TUI/Controller.hs +++ /dev/null @@ -1,1477 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Event handlers for the TUI. -module Swarm.TUI.Controller ( - -- * Event handling - handleEvent, - quitGame, - - -- ** Handling 'Swarm.TUI.Model.Frame' events - runFrameUI, - runFrame, - ticksPerFrameCap, - runFrameTicks, - runGameTickUI, - runGameTick, - updateUI, - - -- ** REPL panel - runBaseWebCode, - handleREPLEvent, - validateREPLForm, - adjReplHistIndex, - TimeDir (..), - - -- ** World panel - handleWorldEvent, - keyToDir, - scrollView, - adjustTPS, - - -- ** Info panel - handleInfoPanelEvent, - - -- ** Utils - getTutorials, -) where - -import Brick hiding (Direction, Location) -import Brick.Focus -import Brick.Widgets.Dialog -import Brick.Widgets.Edit (handleEditorEvent) -import Brick.Widgets.List (handleListEvent) -import Brick.Widgets.List qualified as BL -import Control.Applicative (liftA2, pure) -import Control.Carrier.Lift qualified as Fused -import Control.Carrier.State.Lazy qualified as Fused -import Control.Lens as Lens -import Control.Lens.Extras as Lens (is) -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.Bits -import Data.Either (isRight) -import Data.Foldable (toList) -import Data.Int (Int32) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M -import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) -import Data.String (fromString) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import Data.Time (getZonedTime) -import Data.Vector qualified as V -import Graphics.Vty qualified as V -import Linear -import Swarm.Game.Achievement.Definitions -import Swarm.Game.Achievement.Persistence -import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec), cancel, emptyStore, initMachine) -import Swarm.Game.Entity hiding (empty) -import Swarm.Game.Location -import Swarm.Game.ResourceLoading (getSwarmHistoryPath) -import Swarm.Game.Robot -import Swarm.Game.ScenarioInfo -import Swarm.Game.State -import Swarm.Game.Step (finishGameTick, gameTick) -import Swarm.Language.Capability (Capability (CDebug, CMake)) -import Swarm.Language.Context -import Swarm.Language.Key (KeyCombo, mkKeyCombo) -import Swarm.Language.Module -import Swarm.Language.Parse (reservedWords) -import Swarm.Language.Pipeline -import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Pretty -import Swarm.Language.Requirement qualified as R -import Swarm.Language.Syntax hiding (Key) -import Swarm.Language.Typed (Typed (..)) -import Swarm.Language.Types -import Swarm.Language.Value (Value (VKey, VUnit), prettyValue, stripVResult) -import Swarm.Log -import Swarm.TUI.Controller.Util -import Swarm.TUI.Editor.Controller qualified as EC -import Swarm.TUI.Editor.Model -import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) -import Swarm.TUI.Launch.Controller -import Swarm.TUI.Launch.Model -import Swarm.TUI.Launch.Prep (prepareLaunchDialog) -import Swarm.TUI.List -import Swarm.TUI.Model -import Swarm.TUI.Model.Goal -import Swarm.TUI.Model.Name -import Swarm.TUI.Model.Repl -import Swarm.TUI.Model.StateUpdate -import Swarm.TUI.Model.UI -import Swarm.TUI.View.Objective qualified as GR -import Swarm.TUI.View.Util (generateModal) -import Swarm.Util hiding (both, (<<.=)) -import Swarm.Version (NewReleaseFailure (..)) -import System.Clock -import System.FilePath (splitDirectories) -import Witch (into) -import Prelude hiding (Applicative (..)) -- See Note [liftA2 re-export from Prelude] - --- ~~~~ Note [liftA2 re-export from Prelude] --- --- 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. - -tutorialsDirname :: FilePath -tutorialsDirname = "Tutorials" - --- | 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 - s <- get - if s ^. uiState . uiPlaying - then handleMainEvent e - else - 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)) - --- | The event handler for the main menu. -handleMainMenuEvent :: - BL.List Name MainMenuEntry -> BrickEvent Name AppEvent -> EventM Name AppState () -handleMainMenuEvent menu = \case - Key V.KEnter -> - case snd <$> BL.listSelectedElement menu of - Nothing -> continueWithoutRedraw - 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 - - -- 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 - VtyEvent ev -> do - menu' <- nestEventM' menu (handleListEvent ev) - uiState . uiMenu .= MainMenu menu' - _ -> continueWithoutRedraw - -getTutorials :: ScenarioCollection -> ScenarioCollection -getTutorials sc = case M.lookup tutorialsDirname (scMap sc) of - Just (SICollection _ c) -> c - _ -> error $ "No tutorials exist: " ++ show sc - --- | If we are in a New Game menu, advance the menu to the next item in order. --- --- NOTE: be careful to maintain the invariant that the currently selected --- menu item is always the same as the currently played scenario! `quitGame` --- is the only place this function should be called. -advanceMenu :: Menu -> Menu -advanceMenu = _NewGameMenu . ix 0 %~ BL.listMoveDown - -handleMainAchievementsEvent :: - BL.List Name CategorizedAchievement -> - BrickEvent Name AppEvent -> - EventM Name AppState () -handleMainAchievementsEvent l e = case e of - Key V.KEsc -> returnToMainMenu - CharKey 'q' -> returnToMainMenu - ControlChar 'q' -> returnToMainMenu - VtyEvent ev -> do - l' <- nestEventM' l (handleListEvent ev) - uiState . uiMenu .= AchievementsMenu l' - _ -> continueWithoutRedraw - where - returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages) - -handleMainMessagesEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleMainMessagesEvent = \case - Key V.KEsc -> returnToMainMenu - CharKey 'q' -> returnToMainMenu - ControlChar 'q' -> returnToMainMenu - _ -> return () - where - returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages) - -handleNewGameMenuEvent :: - NonEmpty (BL.List Name ScenarioItem) -> - BrickEvent Name AppEvent -> - EventM Name AppState () -handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case - Key V.KEnter -> - case snd <$> BL.listSelectedElement curMenu of - Nothing -> continueWithoutRedraw - Just (SISingle siPair) -> invalidateCache >> startGame siPair Nothing - Just (SICollection _ c) -> do - cheat <- use $ uiState . uiCheatMode - uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList cheat c) scenarioStack) - CharKey 'o' -> showLaunchDialog - CharKey 'O' -> showLaunchDialog - Key V.KEsc -> exitNewGameMenu scenarioStack - CharKey 'q' -> exitNewGameMenu scenarioStack - ControlChar 'q' -> halt - VtyEvent ev -> do - menu' <- nestEventM' curMenu (handleListEvent ev) - uiState . uiMenu .= NewGameMenu (menu' :| rest) - _ -> continueWithoutRedraw - where - showLaunchDialog = case snd <$> BL.listSelectedElement curMenu of - Just (SISingle siPair) -> Brick.zoom (uiState . uiLaunchConfig) $ prepareLaunchDialog siPair - _ -> continueWithoutRedraw - -exitNewGameMenu :: NonEmpty (BL.List Name ScenarioItem) -> EventM Name AppState () -exitNewGameMenu stk = do - uiState - . uiMenu - .= case snd (NE.uncons stk) of - Nothing -> MainMenu (mainMenu NewGame) - Just stk' -> NewGameMenu stk' - -pressAnyKey :: Menu -> BrickEvent Name AppEvent -> EventM Name AppState () -pressAnyKey m (VtyEvent (V.EvKey _ _)) = uiState . uiMenu .= m -pressAnyKey _ _ = continueWithoutRedraw - --- | The top-level event handler while we are running the game itself. -handleMainEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleMainEvent ev = do - s <- get - mt <- preuse $ uiState . uiModal . _Just . modalType - let isRunning = maybe True isRunningModal mt - let isPaused = s ^. gameState . temporal . paused - let isCreative = s ^. gameState . creativeMode - let hasDebug = fromMaybe isCreative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug - case ev of - AppEvent ae -> case ae of - Frame - | s ^. gameState . temporal . paused -> continueWithoutRedraw - | otherwise -> runFrameUI - Web (RunWebCode c) -> runBaseWebCode c - _ -> continueWithoutRedraw - -- ctrl-q works everywhere - ControlChar 'q' -> - case s ^. gameState . winCondition of - WinConditions (Won _) _ -> toggleModal $ ScenarioEndModal WinModal - WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal - _ -> toggleModal QuitModal - VtyEvent (V.EvResize _ _) -> invalidateCache - Key V.KEsc - | Just m <- s ^. uiState . uiModal -> do - safeAutoUnpause - uiState . uiModal .= Nothing - -- message modal is not autopaused, so update notifications when leaving it - case m ^. modalType of - MessagesModal -> do - gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks - _ -> return () - FKey 1 -> toggleModal HelpModal - FKey 2 -> toggleModal RobotsModal - FKey 3 | not (null (s ^. gameState . discovery . availableRecipes . notificationsContent)) -> do - toggleModal RecipesModal - gameState . discovery . availableRecipes . notificationsCount .= 0 - FKey 4 | not (null (s ^. gameState . discovery . availableCommands . notificationsContent)) -> do - toggleModal CommandsModal - gameState . discovery . availableCommands . notificationsCount .= 0 - FKey 5 | not (null (s ^. gameState . messageNotifications . notificationsContent)) -> do - toggleModal MessagesModal - gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks - -- show goal - ControlChar 'g' -> - if hasAnythingToShow $ s ^. uiState . uiGoal . goalsContent - then toggleModal GoalModal - else continueWithoutRedraw - -- hide robots - MetaChar 'h' -> do - t <- liftIO $ getTime Monotonic - h <- use $ uiState . uiHideRobotsUntil - if h >= t - then -- ignore repeated keypresses - continueWithoutRedraw - else -- hide for two seconds - do - uiState . uiHideRobotsUntil .= t + TimeSpec 2 0 - invalidateCacheEntry WorldCache - -- debug focused robot - MetaChar 'd' | isPaused && hasDebug -> do - debug <- uiState . uiShowDebug Lens.<%= not - if debug - then gameState . temporal . gameStep .= RobotStep SBefore - else zoomGameState finishGameTick >> void updateUI - -- pausing and stepping - ControlChar 'p' | isRunning -> safeTogglePause - ControlChar 'o' | isRunning -> do - gameState . temporal . runStatus .= ManualPause - runGameTickUI - -- speed controls - ControlChar 'x' | isRunning -> modify $ adjustTPS (+) - ControlChar 'z' | isRunning -> modify $ adjustTPS (-) - -- special keys that work on all panels - MetaChar 'w' -> setFocus WorldPanel - MetaChar 'e' -> setFocus RobotPanel - MetaChar 'r' -> setFocus REPLPanel - MetaChar 't' -> setFocus InfoPanel - -- pass keys on to modal event handler if a modal is open - VtyEvent vev - | isJust (s ^. uiState . uiModal) -> handleModalEvent vev - -- toggle creative mode if in "cheat mode" - - MouseDown (TerrainListItem pos) V.BLeft _ _ -> - uiState . uiWorldEditor . terrainList %= BL.listMoveTo pos - MouseDown (EntityPaintListItem pos) V.BLeft _ _ -> - uiState . uiWorldEditor . entityPaintList %= BL.listMoveTo pos - ControlChar 'v' - | s ^. uiState . uiCheatMode -> gameState . creativeMode %= not - -- toggle world editor mode if in "cheat mode" - ControlChar 'e' - | s ^. uiState . uiCheatMode -> do - uiState . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not - setFocus WorldEditorPanel - MouseDown WorldPositionIndicator _ _ _ -> uiState . uiWorldCursor .= Nothing - MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc -> - -- Eye Dropper tool - EC.handleMiddleClick mouseLoc - MouseDown (FocusablePanel WorldPanel) V.BRight _ mouseLoc -> - -- Eraser tool - EC.handleRightClick mouseLoc - MouseDown (FocusablePanel WorldPanel) V.BLeft [V.MCtrl] mouseLoc -> - -- Paint with the World Editor - EC.handleCtrlLeftClick mouseLoc - -- toggle collapse/expand REPL - MetaChar ',' -> do - invalidateCacheEntry WorldCache - uiState . uiShowREPL %= not - MouseDown n _ _ mouseLoc -> - case n of - FocusablePanel WorldPanel -> do - mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - shouldUpdateCursor <- EC.updateAreaBounds mouseCoordsM - when shouldUpdateCursor $ - uiState . uiWorldCursor .= mouseCoordsM - REPLInput -> handleREPLEvent ev - _ -> continueWithoutRedraw - MouseUp n _ _mouseLoc -> do - case n of - InventoryListItem pos -> uiState . uiInventory . traverse . _2 %= BL.listMoveTo pos - x@(WorldEditorPanelControl y) -> do - uiState . uiWorldEditor . editorFocusRing %= focusSetCurrent x - EC.activateWorldEditorFunction y - _ -> return () - flip whenJust setFocus $ case n of - -- Adapt click event origin to their right panel. - -- For the REPL and the World view, using 'Brick.Widgets.Core.clickable' correctly set the origin. - -- However this does not seems to work for the robot and info panel. - -- Thus we force the destination focus here. - InventoryList -> Just RobotPanel - InventoryListItem _ -> Just RobotPanel - InfoViewport -> Just InfoPanel - 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 . uiFocusRing - case focusGetCurrent fring of - Just (FocusablePanel x) -> ($ ev) $ case x of - REPLPanel -> handleREPLEvent - WorldPanel -> handleWorldEvent - WorldEditorPanel -> EC.handleWorldEditorPanelEvent - RobotPanel -> handleRobotPanelEvent - InfoPanel -> handleInfoPanelEvent infoScroll - _ -> continueWithoutRedraw - --- | Set the game to Running if it was (auto) paused otherwise to paused. --- --- Also resets the last frame time to now. If we are pausing, it --- doesn't matter; if we are unpausing, this is critical to --- ensure the next frame doesn't think it has to catch up from --- whenever the game was paused! -safeTogglePause :: EventM Name AppState () -safeTogglePause = do - curTime <- liftIO $ getTime Monotonic - uiState . lastFrameTime .= curTime - uiState . uiShowDebug .= False - p <- gameState . temporal . runStatus Lens.<%= toggleRunStatus - when (p == Running) $ zoomGameState finishGameTick - --- | Only unpause the game if leaving autopaused modal. --- --- Note that the game could have been paused before opening --- the modal, in that case, leave the game paused. -safeAutoUnpause :: EventM Name AppState () -safeAutoUnpause = do - runs <- use $ gameState . temporal . runStatus - when (runs == AutoPause) safeTogglePause - -toggleModal :: ModalType -> EventM Name AppState () -toggleModal mt = do - modal <- use $ uiState . uiModal - case modal of - Nothing -> openModal mt - Just _ -> uiState . uiModal .= Nothing >> safeAutoUnpause - -handleModalEvent :: V.Event -> EventM Name AppState () -handleModalEvent = \case - V.EvKey V.KEnter [] -> do - mdialog <- preuse $ uiState . 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 . uiModal . _Just . modalDialog) (handleDialogEvent ev) - modal <- preuse $ uiState . uiModal . _Just . modalType - case modal of - Just TerrainPaletteModal -> - refreshList $ uiState . uiWorldEditor . terrainList - Just EntityPaletteModal -> do - refreshList $ uiState . uiWorldEditor . entityPaintList - Just GoalModal -> case ev of - V.EvKey (V.KChar '\t') [] -> uiState . uiGoal . focus %= focusNext - _ -> do - focused <- use $ uiState . uiGoal . focus - case focusGetCurrent focused of - Just (GoalWidgets w) -> case w of - ObjectivesList -> do - lw <- use $ uiState . uiGoal . listWidget - newList <- refreshGoalList lw - uiState . uiGoal . listWidget .= newList - GoalSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev) - _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) - _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) - where - refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection - refreshList z = Brick.zoom z $ BL.handleListEvent ev - -getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) -getNormalizedCurrentScenarioPath = - -- the path should be normalized and good to search in scenario collection - use (gameState . currentScenarioPath) >>= \case - Nothing -> return Nothing - Just p' -> do - gs <- use $ runtimeState . scenarios - Just <$> liftIO (normalizeScenarioPath gs p') - -saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo) -saveScenarioInfoOnFinish p = do - initialRunCode <- use $ gameState . gameControls . initiallyRunCode - t <- liftIO getZonedTime - wc <- use $ gameState . winCondition - let won = case wc of - WinConditions (Won _) _ -> True - _ -> False - ts <- use $ gameState . temporal . ticks - - -- NOTE: This traversal is apparently not the same one as used by - -- the scenario selection menu, so the menu needs to be updated separately. - -- See Note [scenario menu update] - let currentScenarioInfo :: Traversal' AppState ScenarioInfo - currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2 - - replHist <- use $ uiState . uiREPL . replHistory - let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput - currentScenarioInfo - %= updateScenarioInfoOnFinish determinator t ts won - status <- preuse currentScenarioInfo - case status of - Nothing -> return () - Just si -> do - let segments = splitDirectories p - case segments of - firstDir : _ -> do - when (won && firstDir == tutorialsDirname) $ - attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial) - _ -> return () - liftIO $ saveScenarioInfo p si - return status - --- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit). -saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m () -saveScenarioInfoOnFinishNocheat = do - -- Don't save progress if we are in cheat mode - cheat <- use $ uiState . uiCheatMode - unless cheat $ do - -- the path should be normalized and good to search in scenario collection - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> void $ saveScenarioInfoOnFinish p - --- | Write the @ScenarioInfo@ out to disk when exiting a game. -saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () -saveScenarioInfoOnQuit = do - -- Don't save progress if we are in cheat mode - -- NOTE This check is duplicated in "saveScenarioInfoOnFinishNocheat" - cheat <- use $ uiState . uiCheatMode - unless cheat $ do - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> do - maybeSi <- saveScenarioInfoOnFinish p - -- Note [scenario menu update] - -- Ensures that the scenario selection menu gets updated - -- with the high score/completion status - forM_ - maybeSi - ( uiState - . uiMenu - . _NewGameMenu - . ix 0 - . BL.listSelectedElementL - . _SISingle - . _2 - .= - ) - - -- See what scenario is currently focused in the menu. Depending on how the - -- previous scenario ended (via quit vs. via win), it might be the same as - -- currentScenarioPath or it might be different. - curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath - -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, - -- being sure to preserve the same focused scenario. - sc <- use $ runtimeState . scenarios - forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=) - --- | Quit a game. --- --- * writes out the updated REPL history to a @.swarm_history@ file --- * 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 - -- Write out REPL history. - history <- use $ uiState . uiREPL . replHistory - let hist = mapMaybe getREPLEntry $ getLatestREPLHistoryItems maxBound history - liftIO $ (`T.appendFile` T.unlines hist) =<< getSwarmHistoryPath True - - -- Save scenario status info. - saveScenarioInfoOnQuit - - -- Automatically advance the menu to the next scenario iff the - -- player has won the current one. - wc <- use $ gameState . winCondition - case wc of - WinConditions (Won _) _ -> uiState . uiMenu %= advanceMenu - _ -> return () - - -- 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 - ------------------------------------------------------------- --- Handling Frame events ------------------------------------------------------------- - --- | Run the game for a single /frame/ (/i.e./ screen redraw), then --- update the UI. Depending on how long it is taking to draw each --- frame, and how many ticks per second we are trying to achieve, --- this may involve stepping the game any number of ticks (including --- zero). -runFrameUI :: EventM Name AppState () -runFrameUI = do - runFrame - redraw <- updateUI - unless redraw continueWithoutRedraw - --- | Run the game for a single frame, without updating the UI. -runFrame :: EventM Name AppState () -runFrame = do - -- Reset the needsRedraw flag. While processing the frame and stepping the robots, - -- the flag will get set to true if anything changes that requires redrawing the - -- world (e.g. a robot moving or disappearing). - gameState . needsRedraw .= False - - -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ . - - -- Find out how long the previous frame took, by subtracting the - -- previous time from the current time. - prevTime <- use (uiState . lastFrameTime) - curTime <- liftIO $ getTime Monotonic - let frameTime = diffTimeSpec curTime prevTime - - -- Remember now as the new previous time. - uiState . lastFrameTime .= curTime - - -- We now have some additional accumulated time to play with. The - -- idea is to now "catch up" by doing as many ticks as are supposed - -- to fit in the accumulated time. Some accumulated time may be - -- left over, but it will roll over to the next frame. This way we - -- deal smoothly with things like a variable frame rate, the frame - -- rate not being a nice multiple of the desired ticks per second, - -- etc. - uiState . accumulatedTime += frameTime - - -- Figure out how many ticks per second we're supposed to do, - -- and compute the timestep `dt` for a single tick. - lgTPS <- use (uiState . lgTicksPerSecond) - let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds - dt - | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS) - | otherwise = oneSecond * (1 `shiftL` abs lgTPS) - - -- Update TPS/FPS counters every second - infoUpdateTime <- use (uiState . 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 . frameCount) - uiState . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime - - -- set how much ticks got processed per frame - uiTicks <- use (uiState . tickCount) - uiState . 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 . tickCount .= 0 - uiState . frameCount .= 0 - uiState . lastInfoTime .= curTime - - -- Increment the frame count - uiState . frameCount += 1 - - -- Now do as many ticks as we need to catch up. - uiState . frameTickCount .= 0 - runFrameTicks (fromNanoSecs dt) - -ticksPerFrameCap :: Int -ticksPerFrameCap = 30 - --- | Do zero or more ticks, with each tick notionally taking the given --- timestep, until we have used up all available accumulated time, --- OR until we have hit the cap on ticks per frame, whichever comes --- first. -runFrameTicks :: TimeSpec -> EventM Name AppState () -runFrameTicks dt = do - a <- use (uiState . accumulatedTime) - t <- use (uiState . frameTickCount) - - -- Ensure there is still enough time left, and we haven't hit the - -- tick limit for this frame. - when (a >= dt && t < ticksPerFrameCap) $ do - -- If so, do a tick, count it, subtract dt from the accumulated time, - -- and loop! - runGameTick - uiState . tickCount += 1 - uiState . frameTickCount += 1 - uiState . accumulatedTime -= dt - runFrameTicks dt - --- | Run the game for a single tick, and update the UI. -runGameTickUI :: EventM Name AppState () -runGameTickUI = runGameTick >> void updateUI - --- | Modifies the game state using a fused-effect state action. -zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (Fused.LiftC IO) a -> m a -zoomGameState f = do - gs <- use gameState - (gs', a) <- liftIO (Fused.runM (Fused.runState gs f)) - gameState .= gs' - return a - -updateAchievements :: EventM Name AppState () -updateAchievements = do - -- Merge the in-game achievements with the master list in UIState - achievementsFromGame <- use $ gameState . discovery . gameAchievements - let wrappedGameAchievements = M.mapKeys GameplayAchievement achievementsFromGame - - oldMasterAchievementsList <- use $ uiState . uiAchievements - uiState . uiAchievements %= M.unionWith (<>) wrappedGameAchievements - - -- Don't save to disk unless there was a change in the attainment list. - let incrementalAchievements = wrappedGameAchievements `M.difference` oldMasterAchievementsList - unless (null incrementalAchievements) $ do - -- TODO: #916 This is where new achievements would be displayed in a popup - newAchievements <- use $ uiState . uiAchievements - liftIO $ saveAchievementsInfo $ M.elems newAchievements - --- | Run the game for a single tick (/without/ updating the UI). --- Every robot is given a certain amount of maximum computation to --- perform a single world action (like moving, turning, grabbing, --- etc.). -runGameTick :: EventM Name AppState () -runGameTick = do - ticked <- zoomGameState gameTick - when ticked updateAchievements - --- | Update the UI. This function is used after running the --- game for some number of ticks. -updateUI :: EventM Name AppState Bool -updateUI = do - loadVisibleRegion - - -- If the game state indicates a redraw is needed, invalidate the - -- world cache so it will be redrawn. - g <- use gameState - when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache - - -- The hash of the robot whose inventory is currently displayed (if any) - listRobotHash <- fmap fst <$> use (uiState . uiInventory) - - -- 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 . uiInventoryShouldUpdate) - - -- Whether the focused robot is too far away to sense, & whether - -- that has recently changed - dist <- use (gameState . to focusedRange) - farOK <- liftA2 (||) (use (gameState . creativeMode)) (use (gameState . landscape . worldScrollable)) - let tooFar = not farOK && dist == Just Far - farChanged = tooFar /= isNothing listRobotHash - - -- If the robot moved in or out of range, or hashes don't match - -- (either because which robot (or whether any robot) is focused - -- changed, or the focused robot's inventory changed), or the - -- inventory was flagged to be updated, regenerate the inventory list. - inventoryUpdated <- - if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate - then do - Brick.zoom uiState $ populateInventoryList (if tooFar then Nothing else fr) - (uiState . uiInventoryShouldUpdate) .= False - pure True - else pure False - - -- Now check if the base finished running a program entered at the REPL. - replUpdated <- case g ^. gameControls . replStatus of - -- It did, and the result was the unit value. Just reset replStatus. - REPLWorking (Typed (Just VUnit) typ reqs) -> do - gameState . gameControls . replStatus .= REPLDone (Just $ Typed VUnit typ reqs) - pure True - - -- It did, and returned some other value. Pretty-print the - -- result as a REPL output, with its type, and reset the replStatus. - REPLWorking (Typed (Just v) pty reqs) -> do - let finalType = stripCmd pty - let val = Typed (stripVResult v) finalType reqs - itIx <- use (gameState . gameControls . replNextValueIndex) - let itName = fromString $ "it" ++ show itIx - let out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] - uiState . uiREPL . replHistory %= addREPLItem (REPLOutput out) - invalidateCacheEntry REPLHistoryCache - vScrollToEnd replScroll - gameState . gameControls . replStatus .= REPLDone (Just val) - gameState . baseRobot . robotContext . at itName .= Just val - gameState . gameControls . replNextValueIndex %= (+ 1) - pure True - - -- Otherwise, do nothing. - _ -> pure False - - -- If the focused robot's log has been updated and the UI focus - -- isn't currently on the inventory or info panels, attempt to - -- automatically switch to the logger and scroll all the way down so - -- the new message can be seen. - uiState . 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 . 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 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 . uiInventory . _Just . _2 %= focusLogger - - -- Now inform the UI that it should scroll the info panel to - -- the very end. - uiState . uiScrollToEnd .= True - pure True - - goalOrWinUpdated <- doGoalUpdates - - let redraw = - g ^. needsRedraw - || inventoryUpdated - || replUpdated - || logUpdated - || goalOrWinUpdated - pure redraw - --- | Either pops up the updated Goals modal --- or pops up the Congratulations (Win) modal, or pops --- up the Condolences (Lose) modal. --- The Win modal will take precedence if the player --- has met the necessary conditions to win the game. --- --- If the player chooses to "Keep Playing" from the Win modal, the --- updated Goals will then immediately appear. --- This is desirable for: --- * feedback as to the final goal the player accomplished, --- * as a summary of all of the goals of the game --- * shows the player more "optional" goals they can continue to pursue -doGoalUpdates :: EventM Name AppState Bool -doGoalUpdates = do - curGoal <- use (uiState . uiGoal . goalsContent) - isCheating <- use (uiState . uiCheatMode) - curWinCondition <- use (gameState . winCondition) - announcementsSeq <- use (gameState . messageInfo . announcementQueue) - let announcementsList = toList announcementsSeq - - -- Decide whether we need to update the current goal text and pop - -- up a modal dialog. - case curWinCondition of - NoWinCondition -> return False - WinConditions (Unwinnable False) x -> do - -- This clears the "flag" that the Lose dialog needs to pop up - gameState . winCondition .= WinConditions (Unwinnable True) x - openModal $ ScenarioEndModal LoseModal - saveScenarioInfoOnFinishNocheat - return True - WinConditions (Won False) x -> do - -- This clears the "flag" that the Win dialog needs to pop up - gameState . winCondition .= WinConditions (Won True) x - openModal $ ScenarioEndModal WinModal - saveScenarioInfoOnFinishNocheat - -- We do NOT advance the New Game menu to the next item here (we - -- used to!), because we do not know if the user is going to - -- select 'keep playing' or 'next challenge'. We maintain the - -- invariant that the current menu item is always the same as - -- the scenario currently being played. If the user either (1) - -- quits to the menu or (2) selects 'next challenge' we will - -- advance the menu at that point. - return True - WinConditions _ oc -> do - let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc - -- The "uiGoal" field is initialized with empty members, so we know that - -- this will be the first time showing it if it will be nonempty after previously - -- being empty. - isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal) - goalWasUpdated = isFirstGoalDisplay || not (null announcementsList) - - -- Decide whether to show a pop-up modal congratulating the user on - -- successfully completing the current challenge. - when goalWasUpdated $ do - let hasMultiple = hasMultipleGoals newGoalTracking - defaultFocus = - if hasMultiple - then ObjectivesList - else GoalSummary - - ring = - focusRing $ - map GoalWidgets $ - if hasMultiple - then listEnums - else [GoalSummary] - - -- The "uiGoal" field is necessary at least to "persist" the data that is needed - -- if the player chooses to later "recall" the goals dialog with CTRL+g. - uiState - . uiGoal - .= GoalDisplay - newGoalTracking - (GR.makeListWidget newGoalTracking) - (focusSetCurrent (GoalWidgets defaultFocus) ring) - - -- This clears the "flag" that indicate that the goals dialog needs to be - -- automatically popped up. - gameState . messageInfo . announcementQueue .= mempty - - hideGoals <- use $ uiState . uiHideGoals - unless hideGoals $ - openModal GoalModal - - return goalWasUpdated - --- | Strips top-level `cmd` from type (in case of REPL evaluation), --- and returns a boolean to indicate if it happened -stripCmd :: Polytype -> Polytype -stripCmd (Forall xs (TyCmd ty)) = Forall xs ty -stripCmd pty = pty - ------------------------------------------------------------- --- REPL events ------------------------------------------------------------- - --- | Set the REPL to the given text and REPL prompt type. -resetREPL :: T.Text -> REPLPrompt -> UIState -> UIState -resetREPL t r ui = - ui - & uiREPL . replPromptText .~ t - & uiREPL . replPromptType .~ r - --- | Handle a user input event for the REPL. -handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleREPLEvent x = do - s <- get - let theRepl = s ^. uiState . uiREPL - controlMode = theRepl ^. replControlMode - uinput = theRepl ^. replPromptText - case x of - -- Handle Ctrl-c here so we can always cancel the currently running - -- base program no matter what REPL control mode we are in. - ControlChar 'c' -> do - gameState . baseRobot . machine %= cancel - uiState . uiREPL . replPromptType .= CmdPrompt [] - uiState . uiREPL . replPromptText .= "" - - -- Handle M-p and M-k, shortcuts for toggling pilot + key handler modes. - MetaChar 'p' -> - onlyCreative $ do - curMode <- use $ uiState . uiREPL . replControlMode - case curMode of - Piloting -> uiState . uiREPL . replControlMode .= Typing - _ -> - if T.null uinput - then uiState . uiREPL . replControlMode .= Piloting - else do - let err = REPLError "Please clear the REPL before engaging pilot mode." - uiState . uiREPL . replHistory %= addREPLItem err - invalidateCacheEntry REPLHistoryCache - MetaChar 'k' -> do - when (isJust (s ^. gameState . gameControls . inputHandler)) $ do - curMode <- use $ uiState . uiREPL . replControlMode - (uiState . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling - - -- Handle other events in a way appropriate to the current REPL - -- control mode. - _ -> case controlMode of - Typing -> handleREPLEventTyping x - Piloting -> handleREPLEventPiloting x - Handling -> case x of - -- Handle keypresses using the custom installed handler - VtyEvent (V.EvKey k mods) -> runInputHandler (mkKeyCombo mods k) - -- Handle all other events normally - _ -> handleREPLEventTyping x - --- | Run the installed input handler on a key combo entered by the user. -runInputHandler :: KeyCombo -> EventM Name AppState () -runInputHandler kc = do - mhandler <- use $ gameState . gameControls . inputHandler - case mhandler of - -- 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 topCtx = topContext s - handlerCESK = Out (VKey kc) (topCtx ^. defStore) [FApp handler, FExec] - gameState . baseRobot . machine .= handlerCESK - gameState %= execState (activateRobot 0) - --- | Handle a user "piloting" input event for the REPL. -handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState () -handleREPLEventPiloting x = case x of - Key V.KUp -> inputCmd "move" - Key V.KDown -> inputCmd "turn back" - Key V.KLeft -> inputCmd "turn left" - Key V.KRight -> inputCmd "turn right" - ShiftKey V.KUp -> inputCmd "turn north" - ShiftKey V.KDown -> inputCmd "turn south" - ShiftKey V.KLeft -> inputCmd "turn west" - ShiftKey V.KRight -> inputCmd "turn east" - Key V.KDel -> inputCmd "selfdestruct" - CharKey 'g' -> inputCmd "grab" - CharKey 'h' -> inputCmd "harvest" - CharKey 'd' -> inputCmd "drill forward" - CharKey 'x' -> inputCmd "drill down" - CharKey 's' -> inputCmd "scan forward" - CharKey 'b' -> inputCmd "blocked" - CharKey 'u' -> inputCmd "upload base" - CharKey 'p' -> inputCmd "push" - _ -> inputCmd "noop" - where - inputCmd cmdText = do - uiState . uiREPL %= setCmd (cmdText <> ";") - modify validateREPLForm - handleREPLEventTyping $ Key V.KEnter - - setCmd nt theRepl = - theRepl - & replPromptText .~ nt - & replPromptType .~ CmdPrompt [] - -runBaseWebCode :: (MonadState AppState m) => T.Text -> m () -runBaseWebCode uinput = do - s <- get - let topCtx = topContext s - unless (s ^. gameState . gameControls . replWorking) $ - runBaseCode topCtx uinput - -runBaseCode :: (MonadState AppState m) => RobotContext -> T.Text -> m () -runBaseCode topCtx uinput = do - uiState . uiREPL . replHistory %= addREPLItem (REPLEntry uinput) - uiState %= resetREPL "" (CmdPrompt []) - case processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput of - Right mt -> do - uiState . uiREPL . replHistory . replHasExecutedManualInput .= True - runBaseTerm topCtx mt - Left err -> do - uiState . uiREPL . replHistory %= addREPLItem (REPLError err) - -runBaseTerm :: (MonadState AppState m) => RobotContext -> Maybe ProcessedTerm -> m () -runBaseTerm topCtx = - modify . maybe id startBaseProgram - where - -- The player typed something at the REPL and hit Enter; this - -- function takes the resulting ProcessedTerm (if the REPL - -- input is valid) and sets up the base robot to run it. - startBaseProgram t@(ProcessedTerm (Module tm _) reqs reqCtx) = - -- Set the REPL status to Working - (gameState . gameControls . replStatus .~ REPLWorking (Typed Nothing (tm ^. sType) reqs)) - -- The `reqCtx` maps names of variables defined in the - -- term (by `def` statements) to their requirements. - -- E.g. if we had `def m = move end`, the reqCtx would - -- record the fact that `m` needs the `move` capability. - -- We simply add the entire `reqCtx` to the robot's - -- context, so we can look up requirements if we later - -- need to requirements-check an argument to `build` or - -- `reprogram` at runtime. See the discussion at - -- https://github.com/swarm-game/swarm/pull/827 for more - -- details. - . (gameState . baseRobot . robotContext . defReqs <>~ reqCtx) - -- Set up the robot's CESK machine to evaluate/execute the - -- given term, being sure to initialize the CESK machine - -- environment and store from the top-level context. - . (gameState . baseRobot . machine .~ initMachine t (topCtx ^. defVals) (topCtx ^. defStore)) - -- Finally, be sure to activate the base robot. - . (gameState %~ execState (activateRobot 0)) - --- | Handle a user input event for the REPL. -handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState () -handleREPLEventTyping = \case - -- Scroll the REPL on PageUp or PageDown - Key V.KPageUp -> vScrollPage replScroll Brick.Up - Key V.KPageDown -> vScrollPage replScroll Brick.Down - k -> do - -- 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 - s <- get - let topCtx = topContext s - theRepl = s ^. uiState . uiREPL - uinput = theRepl ^. replPromptText - - if not $ s ^. gameState . gameControls . replWorking - then case theRepl ^. replPromptType of - CmdPrompt _ -> do - runBaseCode topCtx uinput - invalidateCacheEntry REPLHistoryCache - SearchPrompt hist -> - case lastEntry uinput hist of - Nothing -> uiState %= resetREPL "" (CmdPrompt []) - Just found - | T.null uinput -> uiState %= resetREPL "" (CmdPrompt []) - | otherwise -> do - uiState %= resetREPL found (CmdPrompt []) - modify validateREPLForm - else continueWithoutRedraw - Key V.KUp -> modify $ adjReplHistIndex Older - Key V.KDown -> modify $ adjReplHistIndex Newer - ControlChar 'r' -> do - s <- get - let uinput = s ^. uiState . uiREPL . replPromptText - case s ^. uiState . uiREPL . replPromptType of - CmdPrompt _ -> uiState . uiREPL . replPromptType .= SearchPrompt (s ^. uiState . uiREPL . replHistory) - SearchPrompt rh -> case lastEntry uinput rh of - Nothing -> pure () - Just found -> uiState . uiREPL . replPromptType .= SearchPrompt (removeEntry found rh) - CharKey '\t' -> do - s <- get - let names = s ^.. gameState . baseRobot . robotContext . defTypes . to assocs . traverse . _1 - uiState . uiREPL %= tabComplete names (s ^. gameState . landscape . entityMap) - modify validateREPLForm - EscapeKey -> do - formSt <- use $ uiState . uiREPL . replPromptType - case formSt of - CmdPrompt {} -> continueWithoutRedraw - SearchPrompt _ -> - uiState %= resetREPL "" (CmdPrompt []) - ControlChar 'd' -> do - text <- use $ uiState . uiREPL . replPromptText - if text == T.empty - then toggleModal QuitModal - else continueWithoutRedraw - -- finally if none match pass the event to the editor - ev -> do - Brick.zoom (uiState . uiREPL . replPromptEditor) (handleEditorEvent ev) - uiState . uiREPL . replPromptType %= \case - CmdPrompt _ -> CmdPrompt [] -- reset completions on any event passed to editor - SearchPrompt a -> SearchPrompt a - modify validateREPLForm - -data CompletionType - = FunctionName - | EntityName - deriving (Eq) - --- | Try to complete the last word in a partially-entered REPL prompt using --- reserved words and names in scope (in the case of function names) or --- entity names (in the case of string literals). -tabComplete :: [Var] -> EntityMap -> REPLState -> REPLState -tabComplete names em theRepl = case theRepl ^. replPromptType of - SearchPrompt _ -> theRepl - CmdPrompt mms - -- Case 1: If completion candidates have already been - -- populated via case (3), cycle through them. - -- Note that tabbing through the candidates *does* update the value - -- of "t", which one might think would narrow the candidate list - -- to only that match and therefore halt the cycling. - -- However, the candidate list only gets recomputed (repopulated) - -- if the user subsequently presses a non-Tab key. Thus the current - -- value of "t" is ignored for all Tab presses subsequent to the - -- first. - | (m : ms) <- mms -> setCmd (replacementFunc m) (ms ++ [m]) - -- Case 2: Require at least one letter to be typed in order to offer completions for - -- function names. - -- We allow suggestions for Entity Name strings without anything having been typed. - | T.null lastWord && completionType == FunctionName -> setCmd t [] - -- Case 3: Typing another character in the REPL clears the completion candidates from - -- the CmdPrompt, so when Tab is pressed again, this case then gets executed and - -- repopulates them. - | otherwise -> case candidateMatches of - [] -> setCmd t [] - [m] -> setCmd (completeWith m) [] - -- Perform completion with the first candidate, then populate the list - -- of all candidates with the current completion moved to the back - -- of the queue. - (m : ms) -> setCmd (completeWith m) (ms ++ [m]) - where - -- checks the "parity" of the number of quotes. If odd, then there is an open quote. - hasOpenQuotes = (== 1) . (`mod` 2) . T.count "\"" - - completionType = - if hasOpenQuotes t - then EntityName - else FunctionName - - replacementFunc = T.append $ T.dropWhileEnd replacementBoundaryPredicate t - completeWith m = T.append t $ T.drop (T.length lastWord) m - lastWord = T.takeWhileEnd replacementBoundaryPredicate t - candidateMatches = filter (lastWord `T.isPrefixOf`) replacementCandidates - - (replacementCandidates, replacementBoundaryPredicate) = case completionType of - EntityName -> (entityNames, (/= '"')) - FunctionName -> (possibleWords, isIdentChar) - - possibleWords = reservedWords ++ names - - entityNames = M.keys $ entitiesByName em - - t = theRepl ^. replPromptText - setCmd nt ms = - theRepl - & replPromptText .~ nt - & replPromptType .~ CmdPrompt ms - --- | Validate the REPL input when it changes: see if it parses and --- typechecks, and set the color accordingly. -validateREPLForm :: AppState -> AppState -validateREPLForm s = - case replPrompt of - CmdPrompt _ - | T.null uinput -> - let theType = s ^. gameState . gameControls . replStatus . replActiveType - in s & uiState . uiREPL . replType .~ theType - CmdPrompt _ - | otherwise -> - let result = processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput - theType = case result of - Right (Just (ProcessedTerm (Module tm _) _ _)) -> Just (tm ^. sType) - _ -> Nothing - in s - & uiState . uiREPL . replValid .~ isRight result - & uiState . uiREPL . replType .~ theType - SearchPrompt _ -> s - where - uinput = s ^. uiState . uiREPL . replPromptText - replPrompt = s ^. uiState . uiREPL . replPromptType - topCtx = topContext s - --- | Update our current position in the REPL history. -adjReplHistIndex :: TimeDir -> AppState -> AppState -adjReplHistIndex d s = - s - & uiState . 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) - where - -- new AppState after moving the repl index - newREPL :: REPLState - newREPL = theRepl & replHistory %~ moveReplHistIndex d oldEntry - - saveLastEntry = replLast .~ (theRepl ^. replPromptText) - showNewEntry = (replPromptEditor .~ newREPLEditor newEntry) . (replPromptType .~ CmdPrompt []) - -- get REPL data - getCurrEntry = fromMaybe (theRepl ^. replLast) . getCurrentItemText . view replHistory - oldEntry = getCurrEntry theRepl - newEntry = getCurrEntry newREPL - ------------------------------------------------------------- --- World events ------------------------------------------------------------- - -worldScrollDist :: Int32 -worldScrollDist = 8 - -onlyCreative :: (MonadState AppState m) => m () -> m () -onlyCreative a = do - c <- use $ gameState . creativeMode - when c a - --- | Handle a user input event in the world view panel. -handleWorldEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleWorldEvent = \case - Key k - | k `elem` moveKeys -> do - c <- use $ gameState . creativeMode - s <- use $ gameState . landscape . worldScrollable - when (c || s) $ scrollView (.+^ (worldScrollDist *^ keyToDir k)) - CharKey 'c' -> do - invalidateCacheEntry WorldCache - gameState . viewCenterRule .= VCRobot 0 - -- show fps - CharKey 'f' -> uiState . uiShowFPS %= not - -- Fall-through case: don't do anything. - _ -> continueWithoutRedraw - where - moveKeys = - [ V.KUp - , V.KDown - , V.KLeft - , V.KRight - , V.KChar 'h' - , V.KChar 'j' - , V.KChar 'k' - , V.KChar 'l' - ] - --- | Manually scroll the world view. -scrollView :: (Location -> Location) -> EventM Name AppState () -scrollView update = do - -- Manually invalidate the 'WorldCache' instead of just setting - -- 'needsRedraw'. I don't quite understand why the latter doesn't - -- always work, but there seems to be some sort of race condition - -- where 'needsRedraw' gets reset before the UI drawing code runs. - invalidateCacheEntry WorldCache - gameState %= modifyViewCenter (fmap update) - --- | Convert a directional key into a direction. -keyToDir :: V.Key -> Heading -keyToDir V.KUp = north -keyToDir V.KDown = south -keyToDir V.KRight = east -keyToDir V.KLeft = west -keyToDir (V.KChar 'h') = west -keyToDir (V.KChar 'j') = south -keyToDir (V.KChar 'k') = north -keyToDir (V.KChar 'l') = east -keyToDir _ = zero - --- | Adjust the ticks per second speed. -adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState -adjustTPS (+/-) = uiState . lgTicksPerSecond %~ (+/- 1) - ------------------------------------------------------------- --- Robot panel events ------------------------------------------------------------- - --- | Handle user input events in the robot panel. -handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleRobotPanelEvent bev = do - search <- use (uiState . uiInventorySearch) - case search of - Just _ -> handleInventorySearchEvent bev - Nothing -> case bev of - Key V.KEnter -> - gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal - CharKey 'm' -> - gets focusedEntity >>= maybe continueWithoutRedraw makeEntity - CharKey '0' -> do - uiState . uiInventoryShouldUpdate .= True - uiState . uiShowZero %= not - CharKey ';' -> do - uiState . uiInventoryShouldUpdate .= True - uiState . uiInventorySort %= cycleSortOrder - CharKey ':' -> do - uiState . uiInventoryShouldUpdate .= True - uiState . uiInventorySort %= cycleSortDirection - CharKey '/' -> do - uiState . uiInventoryShouldUpdate .= True - uiState . uiInventorySearch .= Just "" - VtyEvent ev -> handleInventoryListEvent ev - _ -> continueWithoutRedraw - --- | Handle an event to navigate through the inventory list. -handleInventoryListEvent :: V.Event -> EventM Name AppState () -handleInventoryListEvent ev = do - -- Note, refactoring like this is tempting: - -- - -- Brick.zoom (uiState . uiInventory . _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 . uiInventory . _Just . _2 - case mList of - Nothing -> continueWithoutRedraw - Just l -> do - l' <- nestEventM' l (handleListEventWithSeparators ev (is _Separator)) - uiState . uiInventory . _Just . _2 .= l' - --- | Handle a user input event in the robot/inventory panel, while in --- inventory search mode. -handleInventorySearchEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleInventorySearchEvent = \case - -- Escape: stop filtering and go back to regular inventory mode - EscapeKey -> do - uiState . uiInventoryShouldUpdate .= True - uiState . uiInventorySearch .= Nothing - -- Enter: return to regular inventory mode, and pop out the selected item - Key V.KEnter -> do - uiState . uiInventoryShouldUpdate .= True - uiState . uiInventorySearch .= Nothing - gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal - -- Any old character: append to the current search string - CharKey c -> do - uiState . uiInventoryShouldUpdate .= True - uiState . uiInventorySearch %= fmap (`snoc` c) - -- Backspace: chop the last character off the end of the current search string - BackspaceKey -> do - uiState . uiInventoryShouldUpdate .= True - uiState . uiInventorySearch %= fmap (T.dropEnd 1) - -- Handle any other event as list navigation, so we can look through - -- the filtered inventory using e.g. arrow keys - VtyEvent ev -> handleInventoryListEvent ev - _ -> continueWithoutRedraw - --- | Attempt to make an entity selected from the inventory, if the --- base is not currently busy. -makeEntity :: Entity -> EventM Name AppState () -makeEntity e = do - s <- get - let name = e ^. entityName - mkPT = [tmQ| make $str:name |] - topStore = - fromMaybe emptyStore $ - s ^? gameState . baseRobot . robotContext . defStore - - case isActive <$> (s ^? gameState . baseRobot) of - Just False -> do - gameState . gameControls . replStatus .= REPLWorking (Typed Nothing PolyUnit (R.singletonCap CMake)) - gameState . baseRobot . machine .= initMachine mkPT empty topStore - gameState %= execState (activateRobot 0) - _ -> continueWithoutRedraw - --- | Display a modal window with the description of an entity. -descriptionModal :: Entity -> EventM Name AppState () -descriptionModal e = do - s <- get - uiState . uiModal ?= generateModal s (DescriptionModal e) - ------------------------------------------------------------- --- Info panel events ------------------------------------------------------------- - --- | Handle user events in the info panel (just scrolling). -handleInfoPanelEvent :: ViewportScroll Name -> BrickEvent Name AppEvent -> EventM Name AppState () -handleInfoPanelEvent vs = \case - Key V.KDown -> vScrollBy vs 1 - Key V.KUp -> vScrollBy vs (-1) - CharKey 'k' -> vScrollBy vs 1 - CharKey 'j' -> vScrollBy vs (-1) - Key V.KPageDown -> vScrollPage vs Brick.Down - Key V.KPageUp -> vScrollPage vs Brick.Up - Key V.KHome -> vScrollToBeginning vs - Key V.KEnd -> vScrollToEnd vs - _ -> return () diff --git a/src/Swarm/TUI/Controller/Util.hs b/src/Swarm/TUI/Controller/Util.hs deleted file mode 100644 --- a/src/Swarm/TUI/Controller/Util.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Controller.Util where - -import Brick hiding (Direction) -import Brick.Focus -import Control.Lens -import Control.Monad (forM_, unless) -import Control.Monad.IO.Class (liftIO) -import Data.Map qualified as M -import Graphics.Vty qualified as V -import Swarm.Game.State -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.TUI.Model -import Swarm.TUI.Model.UI -import Swarm.TUI.View.Util (generateModal) - --- | Pattern synonyms to simplify brick event handler -pattern Key :: V.Key -> BrickEvent n e -pattern Key k = VtyEvent (V.EvKey k []) - -pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e -pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) []) -pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl]) -pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta]) - -pattern ShiftKey :: V.Key -> BrickEvent n e -pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift]) - -pattern EscapeKey :: BrickEvent n e -pattern EscapeKey = VtyEvent (V.EvKey V.KEsc []) - -pattern BackspaceKey :: BrickEvent n e -pattern BackspaceKey = VtyEvent (V.EvKey V.KBS []) - -pattern FKey :: Int -> BrickEvent n e -pattern FKey c = VtyEvent (V.EvKey (V.KFun c) []) - -openModal :: ModalType -> EventM Name AppState () -openModal mt = do - newModal <- gets $ flip generateModal mt - ensurePause - uiState . uiModal ?= newModal - -- Beep - case mt of - ScenarioEndModal _ -> do - vty <- getVtyHandle - liftIO $ V.ringTerminalBell $ V.outputIface vty - _ -> return () - where - -- Set the game to AutoPause if needed - ensurePause = do - pause <- use $ gameState . temporal . paused - unless (pause || isRunningModal mt) $ do - gameState . temporal . runStatus .= AutoPause - --- | The running modals do not autopause the game. -isRunningModal :: ModalType -> Bool -isRunningModal = \case - RobotsModal -> True - MessagesModal -> True - _ -> False - -setFocus :: FocusablePanel -> EventM Name AppState () -setFocus name = uiState . uiFocusRing %= focusSetCurrent (FocusablePanel name) - -immediatelyRedrawWorld :: EventM Name AppState () -immediatelyRedrawWorld = do - invalidateCacheEntry WorldCache - loadVisibleRegion - --- | Make sure all tiles covering the visible part of the world are --- loaded. -loadVisibleRegion :: EventM Name AppState () -loadVisibleRegion = do - mext <- lookupExtent WorldExtent - forM_ mext $ \(Extent _ _ size) -> do - gs <- use gameState - let vr = viewingRegion (gs ^. viewCenter) (over both fromIntegral size) - gameState . landscape . multiWorld %= M.adjust (W.loadRegion (vr ^. planar)) (vr ^. subworld) - -mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe (Cosmic W.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 viewCenter - let regionStart = W.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) $ W.Coords (mx, my) diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs deleted file mode 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Editor.Controller where - -import Brick hiding (Direction (..), Location (..)) -import Brick qualified as B -import Brick.Focus -import Brick.Widgets.List qualified as BL -import Control.Lens -import Control.Monad (forM_, guard, when) -import Control.Monad.Extra (whenJust) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Map qualified as M -import Data.Yaml qualified as Y -import Graphics.Vty qualified as V -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.State -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.TUI.Controller.Util -import Swarm.TUI.Editor.Model -import Swarm.TUI.Editor.Palette -import Swarm.TUI.Editor.Util qualified as EU -import Swarm.TUI.Model -import Swarm.TUI.Model.Name -import Swarm.TUI.Model.UI -import Swarm.Util (hoistMaybe) -import Swarm.Util.Erasable (maybeToErasable) -import System.Clock - ------------------------------------------------------------- --- World Editor panel events ------------------------------------------------------------- - -activateWorldEditorFunction :: WorldEditorFocusable -> EventM Name AppState () -activateWorldEditorFunction BrushSelector = openModal TerrainPaletteModal -activateWorldEditorFunction EntitySelector = openModal EntityPaletteModal -activateWorldEditorFunction AreaSelector = do - selectorStage <- use $ uiState . uiWorldEditor . editingBounds . boundsSelectionStep - case selectorStage of - SelectionComplete -> uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= UpperLeftPending - _ -> return () -activateWorldEditorFunction OutputPathSelector = - -- TODO: #1371 - liftIO $ putStrLn "File selection" -activateWorldEditorFunction MapSaveButton = saveMapFile -activateWorldEditorFunction ClearEntityButton = - uiState . uiWorldEditor . entityPaintList . BL.listSelectedL .= Nothing - -handleCtrlLeftClick :: B.Location -> EventM Name AppState () -handleCtrlLeftClick mouseLoc = do - worldEditor <- use $ uiState . uiWorldEditor - _ <- runMaybeT $ do - guard $ worldEditor ^. worldOverdraw . isWorldEditorEnabled - let getSelected x = snd <$> BL.listSelectedElement x - maybeTerrainType = getSelected $ worldEditor ^. terrainList - maybeEntityPaint = getSelected $ worldEditor ^. entityPaintList - terrain <- hoistMaybe maybeTerrainType - mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - uiState . uiWorldEditor . worldOverdraw . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeToErasable maybeEntityPaint) - uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing - immediatelyRedrawWorld - return () - -handleRightClick :: B.Location -> EventM Name AppState () -handleRightClick mouseLoc = do - worldEditor <- use $ uiState . uiWorldEditor - _ <- runMaybeT $ do - guard $ worldEditor ^. worldOverdraw . isWorldEditorEnabled - mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - uiState . uiWorldEditor . worldOverdraw . paintedTerrain %= M.delete (mouseCoords ^. planar) - immediatelyRedrawWorld - return () - --- | "Eye Dropper" tool: -handleMiddleClick :: B.Location -> EventM Name AppState () -handleMiddleClick mouseLoc = do - worldEditor <- use $ uiState . uiWorldEditor - when (worldEditor ^. worldOverdraw . isWorldEditorEnabled) $ do - w <- use $ gameState . landscape . multiWorld - let setTerrainPaint coords = do - let (terrain, maybeElementPaint) = - EU.getEditorContentAt - (worldEditor ^. worldOverdraw) - w - coords - uiState . uiWorldEditor . terrainList %= BL.listMoveToElement terrain - forM_ maybeElementPaint $ \elementPaint -> - let p = case elementPaint of - Facade efd -> efd - Ref r -> mkFacade r - in uiState . 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 = \case - Key V.KEsc -> uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete - Key V.KEnter -> do - fring <- use $ uiState . uiWorldEditor . editorFocusRing - case focusGetCurrent fring of - Just (WorldEditorPanelControl x) -> activateWorldEditorFunction x - _ -> return () - ControlChar 's' -> saveMapFile - CharKey '\t' -> uiState . uiWorldEditor . editorFocusRing %= focusNext - Key V.KBackTab -> uiState . uiWorldEditor . editorFocusRing %= focusPrev - _ -> return () - --- | Return value: whether the cursor position should be updated -updateAreaBounds :: Maybe (Cosmic W.Coords) -> EventM Name AppState Bool -updateAreaBounds = \case - Nothing -> return True - Just mouseCoords -> do - selectorStage <- use $ uiState . uiWorldEditor . editingBounds . boundsSelectionStep - case selectorStage of - UpperLeftPending -> do - uiState . 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 - uiState - . uiWorldEditor - . editingBounds - . boundsRect - .= Just (fmap (,view planar mouseCoords) upperLeftMouseCoords) - uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing - uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete - t <- liftIO $ getTime Monotonic - uiState . uiWorldEditor . editingBounds . boundsPersistDisplayUntil .= t + TimeSpec 2 0 - setFocus WorldEditorPanel - return False - SelectionComplete -> return True - -saveMapFile :: EventM Name AppState () -saveMapFile = do - worldEditor <- use $ uiState . uiWorldEditor - maybeBounds <- use $ uiState . uiWorldEditor . editingBounds . boundsRect - w <- use $ gameState . landscape . multiWorld - let mapCellGrid = EU.getEditedMapRectangle (worldEditor ^. worldOverdraw) maybeBounds w - - let fp = worldEditor ^. outputFilePath - maybeScenarioPair <- use $ uiState . scenarioRef - liftIO $ Y.encodeFile fp $ constructScenario (fst <$> maybeScenarioPair) mapCellGrid - - uiState . uiWorldEditor . lastWorldEditorMessage .= Just "Saved." diff --git a/src/Swarm/TUI/Editor/Json.hs b/src/Swarm/TUI/Editor/Json.hs deleted file mode 100644 --- a/src/Swarm/TUI/Editor/Json.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Editor.Json where - -import Data.Text (Text) -import Data.Yaml as Y -import GHC.Generics (Generic) -import Swarm.Game.Entity (Entity) -import Swarm.Game.Scenario.Topography.WorldDescription -import Swarm.Language.Syntax (Syntax) -import Swarm.Language.Text.Markdown (Document) - -data SkeletonScenario = SkeletonScenario - { version :: Int - , name :: Text - , description :: Document Syntax - , creative :: Bool - , entities :: [Entity] - , world :: WorldDescriptionPaint - , robots :: [String] - } - deriving (Generic) - -instance ToJSON SkeletonScenario diff --git a/src/Swarm/TUI/Editor/Masking.hs b/src/Swarm/TUI/Editor/Masking.hs deleted file mode 100644 --- a/src/Swarm/TUI/Editor/Masking.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Editor.Masking where - -import Control.Lens hiding (Const, from) -import Data.Maybe (fromMaybe) -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.TUI.Editor.Model -import Swarm.TUI.Editor.Util qualified as EU -import Swarm.TUI.Model.UI - -shouldHideWorldCell :: UIState -> W.Coords -> Bool -shouldHideWorldCell ui coords = - isOutsideSingleSelectedCorner || isOutsideMapSaveBounds - where - we = ui ^. uiWorldEditor - withinTimeout = ui ^. lastFrameTime < we ^. editingBounds . boundsPersistDisplayUntil - - isOutsideMapSaveBounds = - withinTimeout - && fromMaybe - False - ( do - bounds <- we ^. editingBounds . boundsRect - pure $ EU.isOutsideRegion (bounds ^. planar) coords - ) - - isOutsideSingleSelectedCorner = fromMaybe False $ do - Cosmic _ cornerCoords <- case we ^. editingBounds . boundsSelectionStep of - LowerRightPending cornerCoords -> Just cornerCoords - _ -> Nothing - pure $ EU.isOutsideTopLeftCorner cornerCoords coords diff --git a/src/Swarm/TUI/Editor/Model.hs b/src/Swarm/TUI/Editor/Model.hs deleted file mode 100644 --- a/src/Swarm/TUI/Editor/Model.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Editor.Model where - -import Brick.Focus -import Brick.Widgets.List qualified as BL -import Control.Lens hiding (from, (.=), (<.>)) -import Data.Map qualified as M -import Data.Vector qualified as V -import Swarm.Game.Display (Display) -import Swarm.Game.Entity qualified as E -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Game.Terrain (TerrainType) -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.TUI.Model.Name -import Swarm.Util -import System.Clock - -data BoundsSelectionStep - = UpperLeftPending - | -- | Stores the *world coords* of the upper-left click - LowerRightPending (Cosmic W.Coords) - | SelectionComplete - -data EntityPaint - = Facade EntityFacade - | Ref E.Entity - deriving (Eq) - -getDisplay :: EntityPaint -> Display -getDisplay (Facade (EntityFacade _ d)) = d -getDisplay (Ref e) = e ^. E.entityDisplay - -toFacade :: EntityPaint -> EntityFacade -toFacade = \case - Facade f -> f - Ref e -> mkFacade e - -getEntityName :: EntityFacade -> E.EntityName -getEntityName (EntityFacade name _) = name - -data MapEditingBounds = MapEditingBounds - { _boundsRect :: Maybe (Cosmic W.BoundsRectangle) - -- ^ Upper-left and lower-right coordinates - -- of the map to be saved. - , _boundsPersistDisplayUntil :: TimeSpec - , _boundsSelectionStep :: BoundsSelectionStep - } - -makeLenses ''MapEditingBounds - -data WorldOverdraw = WorldOverdraw - { _isWorldEditorEnabled :: Bool - -- ^ This field has deferred initialization; it gets populated when a game - -- is initialized. - , _paintedTerrain :: M.Map W.Coords (TerrainWith EntityFacade) - } - -makeLenses ''WorldOverdraw - -data WorldEditor n = WorldEditor - { _worldOverdraw :: WorldOverdraw - , _terrainList :: BL.List n TerrainType - , _entityPaintList :: BL.List n EntityFacade - , _editingBounds :: MapEditingBounds - , _editorFocusRing :: FocusRing n - , _outputFilePath :: FilePath - , _lastWorldEditorMessage :: Maybe String - } - -makeLenses ''WorldEditor - -initialWorldEditor :: TimeSpec -> WorldEditor Name -initialWorldEditor ts = - WorldEditor - (WorldOverdraw False mempty) - (BL.list TerrainList (V.fromList listEnums) 1) - (BL.list EntityPaintList (V.fromList []) 1) - bounds - (focusRing $ map WorldEditorPanelControl listEnums) - "mymap.yaml" - Nothing - where - bounds = - MapEditingBounds - -- Note that these are in "world coordinates", - -- not in player-facing "Location" coordinates - (Just $ Cosmic DefaultRootSubworld (W.Coords (-10, -20), W.Coords (10, 20))) - (ts - 1) - SelectionComplete diff --git a/src/Swarm/TUI/Editor/Palette.hs b/src/Swarm/TUI/Editor/Palette.hs deleted file mode 100644 --- a/src/Swarm/TUI/Editor/Palette.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Editor.Palette where - -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) -import Data.Map qualified as M -import Data.Maybe (mapMaybe) -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 (EntityName, entitiesByName) -import Swarm.Game.Location -import Swarm.Game.Scenario -import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), getAreaDimensions) -import Swarm.Game.Scenario.Topography.Cell -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) -import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Game.Terrain (TerrainType, getTerrainDefaultPaletteChar) -import Swarm.Game.Universe -import Swarm.Language.Text.Markdown (fromText) -import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario)) -import Swarm.Util (binTuples, histogram) -import Swarm.Util qualified as U -import Swarm.Util.Erasable - -makeSuggestedPalette :: Maybe Scenario -> [[CellPaintDisplay]] -> KM.KeyMap (AugmentedCell EntityFacade) -makeSuggestedPalette maybeOriginalScenario cellGrid = - KM.fromMapText - . M.map (AugmentedCell Nothing) - . M.fromList - . M.elems - -- NOTE: the left-most maps take precedence! - $ paletteCellsByKey <> pairsWithDisplays <> terrainOnlyPalette - where - getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display) - getMaybeEntityDisplay (Cell _terrain (erasableToMaybe -> maybeEntity) _) = do - EntityFacade eName d <- maybeEntity - return (eName, d) - - getMaybeEntityNameTerrainPair :: PCell EntityFacade -> Maybe (EntityName, TerrainType) - getMaybeEntityNameTerrainPair (Cell terrain (erasableToMaybe -> maybeEntity) _) = do - EntityFacade eName _ <- maybeEntity - return (eName, terrain) - - getEntityTerrainMultiplicity :: Map EntityName (Map TerrainType Int) - getEntityTerrainMultiplicity = - M.map histogram $ binTuples $ concatMap (mapMaybe getMaybeEntityNameTerrainPair) cellGrid - - usedEntityDisplays :: Map EntityName Display - usedEntityDisplays = - M.fromList $ concatMap (mapMaybe getMaybeEntityDisplay) cellGrid - - -- Finds the most-used terrain type (the "mode" in the statistical sense) - -- paired with each entity - entitiesWithModalTerrain :: [(TerrainType, EntityName)] - entitiesWithModalTerrain = - map (swap . fmap (fst . NE.head)) - . mapMaybe sequenceA - . M.toList - $ M.map (NE.nonEmpty . sortOn snd . M.toList) getEntityTerrainMultiplicity - - invertPaletteMapToDedupe :: - Map a CellPaintDisplay -> - [(TerrainWith EntityName, (a, CellPaintDisplay))] - invertPaletteMapToDedupe = - map (\x@(_, c) -> (toKey $ cellToTerrainPair c, x)) . M.toList - - paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) - paletteCellsByKey = - M.map (NE.head . NE.sortWith toSortVal) - . binTuples - . invertPaletteMapToDedupe - $ KM.toMapText originalPalette - where - toSortVal (symbol, Cell _terrain _maybeEntity robots) = Down (null robots, symbol) - - excludedPaletteChars :: Set Char - excludedPaletteChars = Set.fromList [' '] - - originalPalette :: KM.KeyMap CellPaintDisplay - originalPalette = - KM.map (toCellPaintDisplay . standardCell) $ - maybe mempty (unPalette . palette . NE.head . (^. scenarioWorlds)) maybeOriginalScenario - - pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) - pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain - where - g (terrain, eName) = do - eDisplay <- M.lookup eName usedEntityDisplays - 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)) - - -- TODO (#1153): Filter out terrain-only palette entries that aren't actually - -- used in the map. - terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) - terrainOnlyPalette = M.fromList $ map f U.listEnums - where - f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing [])) - --- | Generate a \"skeleton\" scenario with placeholders for certain required fields -constructScenario :: Maybe Scenario -> [[CellPaintDisplay]] -> SkeletonScenario -constructScenario maybeOriginalScenario cellGrid = - SkeletonScenario - (maybe 1 (^. scenarioVersion) maybeOriginalScenario) - (maybe "My Scenario" (^. scenarioName) maybeOriginalScenario) - (maybe (fromText "The scenario description...") (^. scenarioDescription) maybeOriginalScenario) - -- (maybe True (^. scenarioCreative) maybeOriginalScenario) - True - (M.elems $ entitiesByName customEntities) - wd - [] -- robots - where - customEntities = maybe mempty (^. scenarioEntities) maybeOriginalScenario - wd = - WorldDescription - { offsetOrigin = False - , scrollable = True - , palette = WorldPalette suggestedPalette - , ul = upperLeftCoord - , area = cellGrid - , navigation = Navigation mempty mempty - , worldName = DefaultRootSubworld - , worldProg = Nothing - } - - suggestedPalette = makeSuggestedPalette maybeOriginalScenario cellGrid - - upperLeftCoord = - Location - (negate $ w `div` 2) - (h `div` 2) - where - AreaDimensions w h = getAreaDimensions cellGrid diff --git a/src/Swarm/TUI/Editor/Util.hs b/src/Swarm/TUI/Editor/Util.hs deleted file mode 100644 --- a/src/Swarm/TUI/Editor/Util.hs +++ /dev/null @@ -1,134 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Editor.Util where - -import Control.Applicative ((<|>)) -import Control.Lens hiding (Const, from) -import Control.Monad (guard) -import Data.Map qualified as M -import Data.Map qualified as Map -import Data.Maybe qualified as Maybe -import Data.Vector qualified as V -import Swarm.Game.Entity -import Swarm.Game.Scenario.Topography.Area qualified as EA -import Swarm.Game.Scenario.Topography.Cell -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.WorldDescription -import Swarm.Game.Terrain (TerrainType) -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.TUI.Editor.Model -import Swarm.Util.Erasable - -getEntitiesForList :: EntityMap -> V.Vector EntityFacade -getEntitiesForList em = - V.fromList $ map mkFacade entities - where - entities = M.elems $ entitiesByName em - -getEditingBounds :: WorldDescription -> (Bool, Cosmic W.BoundsRectangle) -getEditingBounds myWorld = - (EA.isEmpty a, newBounds) - where - newBounds = Cosmic DefaultRootSubworld (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc) - upperLeftLoc = ul myWorld - a = EA.getAreaDimensions $ area myWorld - lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc - -getContentAt :: W.MultiWorld Int e -> Cosmic W.Coords -> (TerrainType, Maybe e) -getContentAt w coords = (underlyingCellTerrain, underlyingCellEntity) - where - underlyingCellEntity = W.lookupCosmicEntity coords w - underlyingCellTerrain = W.lookupCosmicTerrain coords w - -getEditorContentAt :: - WorldOverdraw -> - W.MultiWorld Int Entity -> - Cosmic W.Coords -> - (TerrainType, Maybe EntityPaint) -getEditorContentAt editorOverdraw w coords = - (terrainWithOverride, entityWithOverride) - where - terrainWithOverride = Maybe.fromMaybe underlyingCellTerrain $ do - (terrainOverride, _) <- maybePaintedCell - return terrainOverride - - maybeEntityOverride :: Maybe EntityPaint - maybeEntityOverride = do - (_, e) <- maybePaintedCell - Facade <$> erasableToMaybe e - - maybePaintedCell = do - guard $ editorOverdraw ^. isWorldEditorEnabled - Map.lookup (coords ^. planar) pm - - pm = editorOverdraw ^. paintedTerrain - - entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride - (underlyingCellTerrain, underlyingCellEntity) = getContentAt w coords - -getEditorTerrainAt :: - WorldOverdraw -> - W.MultiWorld Int Entity -> - Cosmic W.Coords -> - TerrainType -getEditorTerrainAt editor w coords = - fst $ getEditorContentAt editor w coords - -isOutsideTopLeftCorner :: - -- | top left corner coords - W.Coords -> - -- | current coords - W.Coords -> - Bool -isOutsideTopLeftCorner (W.Coords (yTop, xLeft)) (W.Coords (y, x)) = - x < xLeft || y < yTop - -isOutsideBottomRightCorner :: - -- | bottom right corner coords - W.Coords -> - -- | current coords - W.Coords -> - Bool -isOutsideBottomRightCorner (W.Coords (yBottom, xRight)) (W.Coords (y, x)) = - x > xRight || y > yBottom - -isOutsideRegion :: - -- | full bounds - W.BoundsRectangle -> - -- | current coords - W.Coords -> - Bool -isOutsideRegion (tl, br) coord = - isOutsideTopLeftCorner tl coord || isOutsideBottomRightCorner br coord - -getEditedMapRectangle :: - WorldOverdraw -> - Maybe (Cosmic W.BoundsRectangle) -> - W.MultiWorld Int Entity -> - [[CellPaintDisplay]] -getEditedMapRectangle _ Nothing _ = [] -getEditedMapRectangle worldEditor (Just (Cosmic subworldName coords)) w = - getMapRectangle toFacade getContent coords - where - getContent = getEditorContentAt worldEditor w . Cosmic subworldName - -getMapRectangle :: - (d -> e) -> - (W.Coords -> (TerrainType, Maybe d)) -> - W.BoundsRectangle -> - [[PCell e]] -getMapRectangle paintTransform contentFunc coords = - map renderRow [yTop .. yBottom] - where - (W.Coords (yTop, xLeft), W.Coords (yBottom, xRight)) = coords - - drawCell f rowIndex colIndex = - Cell - terrain - (f <$> maybeToErasable erasableEntity) - [] - where - (terrain, erasableEntity) = contentFunc $ W.Coords (rowIndex, colIndex) - - renderRow rowIndex = map (drawCell paintTransform rowIndex) [xLeft .. xRight] diff --git a/src/Swarm/TUI/Editor/View.hs b/src/Swarm/TUI/Editor/View.hs deleted file mode 100644 --- a/src/Swarm/TUI/Editor/View.hs +++ /dev/null @@ -1,162 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Editor.View where - -import Brick hiding (Direction) -import Brick.Focus -import Brick.Widgets.Center (hCenter) -import Brick.Widgets.List qualified as BL -import Control.Lens hiding (Const, from) -import Data.List qualified as L -import Swarm.Game.Scenario.Topography.Area qualified as EA -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Terrain (TerrainType) -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.TUI.Border -import Swarm.TUI.Editor.Model -import Swarm.TUI.Model -import Swarm.TUI.Model.Name -import Swarm.TUI.Model.UI -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 (listEnums) - -drawWorldEditor :: FocusRing Name -> UIState -> Widget Name -drawWorldEditor toplevelFocusRing uis = - if worldEditor ^. worldOverdraw . isWorldEditorEnabled - then - panel - highlightAttr - toplevelFocusRing - (FocusablePanel WorldEditorPanel) - plainBorder - innerWidget - else emptyWidget - where - privateFocusRing = worldEditor ^. editorFocusRing - maybeCurrentFocus = focusGetCurrent privateFocusRing - - controlsBox = - padBottom Max $ - vBox - [ brushWidget - , entityWidget - , clearEntityButtonWidget - , areaWidget - , outputWidget - , str " " - , saveButtonWidget - ] - - innerWidget = - padLeftRight 1 $ - hLimit 30 $ - controlsBox <=> statusBox - - worldEditor = uis ^. uiWorldEditor - maybeAreaBounds = worldEditor ^. editingBounds . boundsRect - - -- TODO (#1150): Use withFocusRing? - mkFormControl n w = - clickable n $ transformation w - where - transformation = - if Just n == maybeCurrentFocus - then withAttr BL.listSelectedFocusedAttr - else id - - swatchContent list drawFunc = - maybe emptyWidget drawFunc selectedThing - where - selectedThing = snd <$> BL.listSelectedElement list - - brushWidget = - mkFormControl (WorldEditorPanelControl BrushSelector) $ - padRight (Pad 1) (str "Brush:") - <+> swatchContent (worldEditor ^. terrainList) VU.drawLabeledTerrainSwatch - - entityWidget = - mkFormControl (WorldEditorPanelControl EntitySelector) $ - padRight (Pad 1) (str "Entity:") - <+> swatchContent (worldEditor ^. entityPaintList) drawLabeledEntitySwatch - - clearEntityButtonWidget = - if null $ worldEditor ^. entityPaintList . BL.listSelectedL - then emptyWidget - else - mkFormControl (WorldEditorPanelControl ClearEntityButton) - . hLimit 20 - . hCenter - $ str "None" - - areaContent = case worldEditor ^. editingBounds . boundsSelectionStep of - UpperLeftPending -> str "Click top-left" - LowerRightPending _wcoords -> str "Click bottom-right" - SelectionComplete -> maybe emptyWidget (renderBounds . view planar) maybeAreaBounds - - areaWidget = - mkFormControl (WorldEditorPanelControl AreaSelector) $ - vBox - [ str "Area:" - , areaContent - ] - - renderBounds (upperLeftCoord, lowerRightCoord) = - str $ - unwords $ - L.intersperse - "@" - [ EA.renderRectDimensions rectArea - , VU.locationToString upperLeftLoc - ] - where - upperLeftLoc = W.coordsToLoc upperLeftCoord - lowerRightLoc = W.coordsToLoc lowerRightCoord - rectArea = EA.cornersToArea upperLeftLoc lowerRightLoc - - outputWidget = - mkFormControl (WorldEditorPanelControl OutputPathSelector) $ - padRight (Pad 1) (str "Output:") <+> outputWidgetContent - - outputWidgetContent = str $ worldEditor ^. outputFilePath - - saveButtonWidget = - mkFormControl (WorldEditorPanelControl MapSaveButton) - . hLimit 20 - . hCenter - $ str "Save" - - statusBox = maybe emptyWidget str $ worldEditor ^. lastWorldEditorMessage - -drawLabeledEntitySwatch :: EntityFacade -> Widget Name -drawLabeledEntitySwatch (EntityFacade eName eDisplay) = - tile <+> txt eName - where - tile = padRight (Pad 1) $ renderDisplay eDisplay - -drawTerrainSelector :: AppState -> Widget Name -drawTerrainSelector s = - padAll 1 - . hCenter - . vLimit (length (listEnums :: [TerrainType])) - . BL.renderListWithIndex listDrawTerrainElement True - $ s ^. uiState . uiWorldEditor . terrainList - -listDrawTerrainElement :: Int -> Bool -> TerrainType -> Widget Name -listDrawTerrainElement pos _isSelected a = - clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch a - -drawEntityPaintSelector :: AppState -> Widget Name -drawEntityPaintSelector s = - padAll 1 - . hCenter - . vLimit 10 - . BL.renderListWithIndex listDrawEntityPaintElement True - $ s ^. uiState . uiWorldEditor . entityPaintList - -listDrawEntityPaintElement :: Int -> Bool -> EntityFacade -> Widget Name -listDrawEntityPaintElement pos _isSelected a = - clickable (EntityPaintListItem pos) $ drawLabeledEntitySwatch a diff --git a/src/Swarm/TUI/Inventory/Sorting.hs b/src/Swarm/TUI/Inventory/Sorting.hs deleted file mode 100644 --- a/src/Swarm/TUI/Inventory/Sorting.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Inventory.Sorting ( - InventorySortOptions (..), - InventorySortDirection (..), - InventorySortOrder (..), - cycleSortOrder, - cycleSortDirection, - defaultSortOptions, - sortInventory, - renderSortMethod, -) where - -import Algorithms.NaturalSort (sortKey) -import Control.Lens (view) -import Data.List (sortBy) -import Data.Ord (Down (Down), comparing) -import Data.Text qualified as T -import Swarm.Game.Entity as E -import Swarm.Util (cycleEnum) - -data InventorySortDirection - = Ascending - | Descending - deriving (Enum, Bounded, Eq) - -data InventorySortOrder - = ByNaturalAlphabetic - | ByQuantity - | ByType - deriving (Enum, Bounded, Eq) - -data InventorySortOptions = InventorySortOptions InventorySortDirection InventorySortOrder - -defaultSortOptions :: InventorySortOptions -defaultSortOptions = InventorySortOptions Ascending ByNaturalAlphabetic - -renderSortMethod :: InventorySortOptions -> T.Text -renderSortMethod (InventorySortOptions direction order) = - T.unwords [prefix, label] - where - prefix = case direction of - Ascending -> "↑" - Descending -> "↓" - label = case order of - ByNaturalAlphabetic -> "name" - ByQuantity -> "count" - ByType -> "type" - -cycleSortOrder :: InventorySortOptions -> InventorySortOptions -cycleSortOrder (InventorySortOptions direction order) = - InventorySortOptions direction (cycleEnum order) - -cycleSortDirection :: InventorySortOptions -> InventorySortOptions -cycleSortDirection (InventorySortOptions direction order) = - InventorySortOptions (cycleEnum direction) order - --- | All non-alphabetic sort criteria perform alphabetic tie-breaking. --- "Reverse ordering" only applies to the *primary* sort criteria; the secondary --- alphabetic sort is always in ascending order. -getSortCompartor :: Ord a => InventorySortOptions -> (a, Entity) -> (a, Entity) -> Ordering -getSortCompartor (InventorySortOptions direction order) = case order of - ByNaturalAlphabetic -> compReversible (alphabetic . snd) - ByQuantity -> compReversible fst <> secondary - ByType -> compReversible (view entityProperties . snd) <> secondary - where - alphabetic = sortKey . T.toLower . view entityName - secondary = comparing (alphabetic . snd) - - compReversible :: Ord a => (b -> a) -> b -> b -> Ordering - compReversible = case direction of - Ascending -> comparing - Descending -> \f -> comparing (Down . f) - -sortInventory :: Ord a => InventorySortOptions -> [(a, Entity)] -> [(a, Entity)] -sortInventory opts = - sortBy $ getSortCompartor opts diff --git a/src/Swarm/TUI/Launch/Controller.hs b/src/Swarm/TUI/Launch/Controller.hs deleted file mode 100644 --- a/src/Swarm/TUI/Launch/Controller.hs +++ /dev/null @@ -1,172 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Event handling for the scenario launch configuration dialog. -module Swarm.TUI.Launch.Controller where - -import Brick hiding (Direction, Location) -import Brick.Focus -import Brick.Widgets.Edit (handleEditorEvent) -import Brick.Widgets.FileBrowser -import Brick.Widgets.FileBrowser qualified as FB -import Control.Lens -import Control.Monad (forM_, when) -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (listToMaybe) -import Graphics.Vty qualified as V -import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (LaunchParams)) -import Swarm.Game.ScenarioInfo -import Swarm.TUI.Controller.Util -import Swarm.TUI.Launch.Model -import Swarm.TUI.Launch.Prep (initFileBrowserWidget, makeFocusRingWith, parseSeedInput, parseWidgetParams, toValidatedParams) -import Swarm.TUI.Model -import Swarm.TUI.Model.Name -import Swarm.TUI.Model.StateUpdate -import Swarm.TUI.Model.UI -import Swarm.Util (listEnums) - -updateFocusRing :: EditingLaunchParams -> EventM Name LaunchOptions () -updateFocusRing parsedParams = do - currentRing <- use $ controls . scenarioConfigFocusRing - let eitherLaunchParams = toValidatedParams parsedParams - modifyRingMembers = case eitherLaunchParams of - Left _ -> filter (/= StartGameButton) - Right _ -> id - maybeCurrentFocus = focusGetCurrent currentRing - refocusRing = maybe id focusSetCurrent maybeCurrentFocus - - controls . scenarioConfigFocusRing .= refocusRing (makeFocusRingWith $ modifyRingMembers listEnums) - -cacheValidatedInputs :: EventM Name LaunchOptions () -cacheValidatedInputs = do - launchControls <- use controls - parsedParams <- liftIO $ parseWidgetParams launchControls - editingParams .= parsedParams - updateFocusRing parsedParams - --- | This is split out from the combined parameter-validation function --- because validating the seed is cheap, and shouldn't have to pay --- the cost of re-parsing script code as the user types in the seed --- selection field. -cacheValidatedSeedInput :: EventM Name LaunchOptions () -cacheValidatedSeedInput = do - seedEditor <- use $ controls . seedValueEditor - let eitherMaybeSeed = parseSeedInput seedEditor - LaunchParams _ eitherParsedCode <- use editingParams - let newParams = LaunchParams eitherMaybeSeed eitherParsedCode - editingParams .= newParams - updateFocusRing newParams - --- | If the 'FileBrowser' is in "search mode", then we allow --- more of the key events to pass through. Otherwise, --- we intercept things like "q" (for quit) and Space (so that --- we can restrict file selection to at most one). -handleFBEvent :: - BrickEvent Name AppEvent -> - EventM Name AppState () -handleFBEvent ev = do - fb <- use $ uiState . uiLaunchConfig . controls . fileBrowser . fbWidget - let isSearching = fileBrowserIsSearching fb - case (isSearching, ev) of - (False, Key V.KEsc) -> closeModal - (False, CharKey 'q') -> closeModal - (False, ControlChar 'q') -> closeModal - -- Intercept the "space" key so that it cannot be used to select files - -- (see note below). - (False, CharKey ' ') -> return () - (_, VtyEvent e) -> do - (shouldClose, maybeSingleFile) <- Brick.zoom (uiState . uiLaunchConfig . controls . fileBrowser . fbWidget) $ do - handleFileBrowserEvent e - -- If the browser has a selected file after handling the - -- event (because the user pressed Enter), close the dialog. - case e of - V.EvKey V.KEnter [] -> do - b' <- get - case FB.fileBrowserSelection b' of - [] -> return (False, Nothing) - -- We only allow one file to be selected - -- by closing immediately. - -- This is a hack illustrated in the Brick FileBrowser demo: - -- https://github.com/jtdaugherty/brick/blob/4b40476d5d58c40720170d21503c11596bc9ee39/programs/FileBrowserDemo.hs#L68-L69 - -- It is not foolproof on its own, so we also intercept - -- the "Space" key above. - xs -> return (True, FB.fileInfoFilePath <$> listToMaybe xs) - -- NOTE: The "Space" key also selects a file. - -- Apparently, even when directories are specified as - -- non-selectable via "FB.selectNonDirectories", the internal state - -- of the FileBrowser dialog - -- briefly adds a directory to its "fileBrowserSelection" list - -- when the "space" key is pressed. - -- So it is not enough to simply check whether the selection list - -- is nonempty after *any* keypress; we specifically have to listen for "Enter". - -- - -- WARNING: There is still a bug when one presses the "space" key to mark - -- a directory, then presses "Enter" right afterward. - -- The directory will get selected, and then swarm will crash. - -- This is why we prevent the Space key from being handled by the FileBrowser - -- unless we are in file searching mode. - _ -> return (False, Nothing) - - when shouldClose $ do - uiState . uiLaunchConfig . controls . fileBrowser . maybeSelectedFile .= maybeSingleFile - closeModal - _ -> return () - where - closeModal = Brick.zoom (uiState . uiLaunchConfig) $ do - controls . fileBrowser . fbIsDisplayed .= False - cacheValidatedInputs - -handleLaunchOptionsEvent :: - ScenarioInfoPair -> - BrickEvent Name AppEvent -> - EventM Name AppState () -handleLaunchOptionsEvent siPair = \case - Key V.KBackTab -> - uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusPrev - Key V.KUp -> - uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusPrev - CharKey '\t' -> - uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusNext - Key V.KDown -> - uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusNext - MouseDown n _ _ _ -> - case n of - ScenarioConfigControl (ScenarioConfigPanelControl x) -> do - uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusSetCurrent n - activateFocusedControl x - _ -> return () - CharKey ' ' -> activateControl - Key V.KEnter -> activateControl - Key V.KEsc -> closeModal - CharKey 'q' -> closeModal - ControlChar 'q' -> closeModal - ev -> do - fr <- use $ uiState . uiLaunchConfig . controls . scenarioConfigFocusRing - case focusGetCurrent fr of - Just (ScenarioConfigControl (ScenarioConfigPanelControl SeedSelector)) -> Brick.zoom (uiState . uiLaunchConfig) $ do - Brick.zoom (controls . seedValueEditor) (handleEditorEvent ev) - cacheValidatedSeedInput - _ -> return () - where - activateControl = do - fr <- use $ uiState . uiLaunchConfig . controls . scenarioConfigFocusRing - case focusGetCurrent fr of - Just (ScenarioConfigControl (ScenarioConfigPanelControl item)) -> - activateFocusedControl item - _ -> return () - - activateFocusedControl item = case item of - SeedSelector -> return () - ScriptSelector -> Brick.zoom (uiState . uiLaunchConfig . controls . fileBrowser) $ do - maybeSingleFile <- use maybeSelectedFile - configuredFB <- initFileBrowserWidget maybeSingleFile - fbWidget .= configuredFB - fbIsDisplayed .= True - StartGameButton -> do - params <- use $ uiState . uiLaunchConfig . editingParams - let eitherLaunchParams = toValidatedParams params - forM_ eitherLaunchParams $ \launchParams -> do - closeModal - startGameWithSeed siPair launchParams - - closeModal = uiState . uiLaunchConfig . controls . isDisplayedFor .= Nothing diff --git a/src/Swarm/TUI/Launch/Model.hs b/src/Swarm/TUI/Launch/Model.hs deleted file mode 100644 --- a/src/Swarm/TUI/Launch/Model.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Types for representing state of the launch dialog, --- along with conversion functions for validated launch parameters. -module Swarm.TUI.Launch.Model where - -import Brick.Focus qualified as Focus -import Brick.Widgets.Edit -import Brick.Widgets.FileBrowser qualified as FB -import Control.Carrier.Throw.Either (runThrow) -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.Game.State (LaunchParams, ValidatedLaunchParams, getRunCodePath, parseCodeFile) -import Swarm.Language.Pretty (prettyText) -import Swarm.TUI.Model.Name -import Swarm.Util.Effect (withThrow) - --- | Use this to store error messages --- on individual fields -type EditingLaunchParams = LaunchParams (Either Text) - -toSerializableParams :: ValidatedLaunchParams -> SerializableLaunchParams -toSerializableParams (LaunchParams seedValue (Identity codeToRun)) = - LaunchParams seedValue $ pure $ getRunCodePath =<< codeToRun - -fromSerializableParams :: SerializableLaunchParams -> IO EditingLaunchParams -fromSerializableParams (LaunchParams (Identity maybeSeedValue) (Identity maybeCodePath)) = do - eitherCode <- - runThrow . withThrow (prettyText @SystemFailure) $ - traverse parseCodeFile maybeCodePath - return $ LaunchParams (Right maybeSeedValue) eitherCode - -data FileBrowserControl = FileBrowserControl - { _fbWidget :: FB.FileBrowser Name - , _maybeSelectedFile :: Maybe FilePath - , _fbIsDisplayed :: Bool - } - -makeLenses ''FileBrowserControl - --- | UI elements to configure scenario launch options -data LaunchControls = LaunchControls - { _fileBrowser :: FileBrowserControl - , _seedValueEditor :: Editor Text Name - , _scenarioConfigFocusRing :: Focus.FocusRing Name - , _isDisplayedFor :: Maybe ScenarioInfoPair - } - -makeLenses ''LaunchControls - --- | UI elements to configure scenario launch options -data LaunchOptions = LaunchOptions - { _controls :: LaunchControls - , _editingParams :: EditingLaunchParams - } - -makeLenses ''LaunchOptions diff --git a/src/Swarm/TUI/Launch/Prep.hs b/src/Swarm/TUI/Launch/Prep.hs deleted file mode 100644 --- a/src/Swarm/TUI/Launch/Prep.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- HLINT ignore "Use <$>" -} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Prepares and validates scenario launch parameters -module Swarm.TUI.Launch.Prep where - -import Brick (EventM) -import Brick.Focus qualified as Focus -import Brick.Widgets.Edit -import Brick.Widgets.FileBrowser qualified as FB -import Control.Arrow (left) -import Control.Carrier.Throw.Either (runThrow) -import Control.Lens ((.=), (^.)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Functor.Identity (runIdentity) -import Data.Text qualified as T -import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (..), ScenarioInfoPair, getLaunchParams, scenarioStatus) -import Swarm.Game.State (Seed, ValidatedLaunchParams, getRunCodePath, parseCodeFile) -import Swarm.Language.Pretty (prettyText) -import Swarm.TUI.Launch.Model -import Swarm.TUI.Model.Name -import Swarm.Util (listEnums) -import Swarm.Util.Effect (withThrow) -import System.FilePath (takeDirectory) -import Text.Read (readEither) - -swarmLangFileExtension :: String -swarmLangFileExtension = "sw" - -toValidatedParams :: EditingLaunchParams -> Either T.Text ValidatedLaunchParams -toValidatedParams (LaunchParams eitherSeedVal eitherInitialCode) = do - maybeSeed <- eitherSeedVal - maybeParsedCode <- eitherInitialCode - return $ LaunchParams (pure maybeSeed) (pure maybeParsedCode) - -parseSeedInput :: Editor T.Text Name -> Either T.Text (Maybe Seed) -parseSeedInput seedEditor = - if T.null seedFieldText - then Right Nothing - else - fmap Just - . left T.pack - . readEither - . T.unpack - $ seedFieldText - where - seedFieldText = mconcat $ getEditContents seedEditor - -parseWidgetParams :: LaunchControls -> IO EditingLaunchParams -parseWidgetParams (LaunchControls (FileBrowserControl _fb maybeSelectedScript _) seedEditor _ _) = do - eitherParsedCode <- - runThrow . withThrow (prettyText @SystemFailure) $ - traverse parseCodeFile maybeSelectedScript - return $ LaunchParams eitherMaybeSeed eitherParsedCode - where - eitherMaybeSeed = parseSeedInput seedEditor - -makeFocusRingWith :: [ScenarioConfigPanelFocusable] -> Focus.FocusRing Name -makeFocusRingWith = Focus.focusRing . map (ScenarioConfigControl . ScenarioConfigPanelControl) - -initEditorWidget :: T.Text -> Editor T.Text Name -initEditorWidget = - editorText - (ScenarioConfigControl $ ScenarioConfigPanelControl SeedSelector) - (Just 1) -- only allow a single line - --- | Called before any particular scenario is selected, so we --- supply some 'Nothing's as defaults to the 'ValidatedLaunchParams'. -initConfigPanel :: IO LaunchOptions -initConfigPanel = do - -- NOTE: This is kind of pointless, because we must re-instantiate the 'FB.FileBrowser' - -- when it is first displayed, anyway. - fb <- - FB.newFileBrowser - FB.selectNonDirectories - (ScenarioConfigControl $ ScenarioConfigPanelControl ScriptSelector) - Nothing -- Initial working directory to display - return $ - LaunchOptions - (LaunchControls (FileBrowserControl fb Nothing False) myForm ring Nothing) - (LaunchParams (Right Nothing) (Right Nothing)) - where - myForm = initEditorWidget "" - ring = makeFocusRingWith listEnums - -initFileBrowserWidget :: - (MonadIO m) => - Maybe FilePath -> - m (FB.FileBrowser Name) -initFileBrowserWidget maybePlayedScript = do - fb <- - liftIO $ - FB.newFileBrowser - FB.selectNonDirectories - (ScenarioConfigControl $ ScenarioConfigPanelControl ScriptSelector) - (takeDirectory <$> maybePlayedScript) -- Initial working directory to display - return $ FB.setFileBrowserEntryFilter (Just $ FB.fileExtensionMatch swarmLangFileExtension) fb - --- | If the selected scenario has been launched with an initial script before, --- set the file browser to initially open that script's directory. --- Then set the launch dialog to be displayed. --- --- Note that the 'FB.FileBrowser' widget normally allows multiple selections ("marked" files). --- However, there do not exist any public "setters" set the marked files, so we have --- some workarounds: --- --- * When the user marks the first file, we immediately close the 'FB.FileBrowser' widget. --- * We re-instantiate the 'FB.FileBrowser' from scratch every time it is opened, so that --- it is not possible to mark more than one file. --- * 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 -> - EventM Name LaunchOptions () -prepareLaunchDialog siPair@(_, si) = do - let serializableLaunchParams = getLaunchParams $ si ^. scenarioStatus - launchEditingParams <- liftIO $ fromSerializableParams serializableLaunchParams - editingParams .= launchEditingParams - - let maybePlayedScript = case initialCode launchEditingParams of - Right codeToRun -> getRunCodePath =<< codeToRun - Left _ -> Nothing - - controls . fileBrowser . maybeSelectedFile .= maybePlayedScript - controls . seedValueEditor .= initEditorWidget (maybe "" (T.pack . show) $ runIdentity $ seedVal serializableLaunchParams) - controls . isDisplayedFor .= Just siPair diff --git a/src/Swarm/TUI/Launch/View.hs b/src/Swarm/TUI/Launch/View.hs deleted file mode 100644 --- a/src/Swarm/TUI/Launch/View.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Rendering of the scenario launch configuration dialog. -module Swarm.TUI.Launch.View where - -import Brick -import Brick.Focus -import Brick.Forms qualified as BF -import Brick.Widgets.Border -import Brick.Widgets.Center (centerLayer, hCenter) -import Brick.Widgets.Edit -import Brick.Widgets.Edit qualified as E -import Brick.Widgets.FileBrowser qualified as FB -import Control.Exception qualified as E -import Control.Lens -import Data.Either (isRight) -import Data.Text (Text) -import Data.Text qualified as T -import Swarm.Game.Scenario (scenarioSeed) -import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (..)) -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) - -drawFileBrowser :: FB.FileBrowser Name -> Widget Name -drawFileBrowser b = - centerLayer $ hLimit 50 $ ui <=> help - where - ui = - vLimit 15 $ - borderWithLabel (txt "Choose a file") $ - FB.renderFileBrowser True b - - footerRows = - map - (withDefAttr dimAttr . hCenter . txt) - [ "Up/Down: navigate" - , "/: search, Ctrl-C or Esc: cancel search" - , "Enter: change directory or select file" - , "Esc: quit" - ] - - help = - padTop (Pad 1) $ - vBox $ - [ case FB.fileBrowserException b of - Nothing -> emptyWidget - Just e -> - hCenter - . withDefAttr BF.invalidFormInputAttr - . txt - . T.pack - $ E.displayException e - ] - <> footerRows - -optionDescription :: ScenarioConfigPanelFocusable -> Maybe Text -optionDescription = \case - SeedSelector -> Just "Leaving this field blank will use the default seed for the scenario." - ScriptSelector -> Just "Selecting a script to be run upon start permits eligibility for code size scoring." - StartGameButton -> Nothing - -drawLaunchConfigPanel :: LaunchOptions -> [Widget Name] -drawLaunchConfigPanel (LaunchOptions lc launchParams) = - addFileBrowser [panelWidget] - where - validatedOptions = toValidatedParams launchParams - LaunchControls (FileBrowserControl fb _ isFbDisplayed) seedEditor ring displayedFor = lc - addFileBrowser = - if isFbDisplayed - then (drawFileBrowser fb :) - else id - - getFocusedConfigPanel :: Maybe ScenarioConfigPanelFocusable - getFocusedConfigPanel = case focusGetCurrent ring of - Just (ScenarioConfigControl (ScenarioConfigPanelControl x)) -> Just x - _ -> Nothing - - isFocused = (== getFocusedConfigPanel) . Just - - highlightIfFocused x = - if isFocused x - then withDefAttr highlightAttr - else id - - mkButton name label = - clickable (ScenarioConfigControl $ ScenarioConfigPanelControl name) - . highlightIfFocused name - . withAttr boldAttr - $ txt label - - mkSeedEditorWidget = - hLimit 10 $ - overrideAttr E.editFocusedAttr customEditFocusedAttr $ - renderEditor (txt . mconcat) (isFocused SeedSelector) seedEditor - seedEntryWidget = case seedVal launchParams of - Left _ -> mkSeedEditorWidget - Right x -> mkSeedEntryWidget x - - scenarioSeedText = maybe "random" show $ view scenarioSeed . fst =<< displayedFor - mkSeedEntryWidget seedEntryContent = - if isFocused SeedSelector - then mkSeedEditorWidget - else case seedEntryContent of - Just x -> str $ show x - Nothing -> - withDefAttr dimAttr $ - txt $ - T.unwords - [ "scenario default" - , parens $ T.pack scenarioSeedText - ] - - unspecifiedFileMessage = - if isFocused ScriptSelector - then str "<[Enter] to select>" - else withDefAttr dimAttr $ str "" - - fileEntryWidget = case initialCode launchParams of - Left _ -> str "" - Right maybeFilepath -> - maybe - unspecifiedFileMessage - (withEllipsis Beginning . T.pack) - (getRunCodePath =<< maybeFilepath) - - panelWidget = - centerLayer - . borderWithLabel (str " Configure scenario launch ") - . hLimit 60 - . padAll 1 - $ vBox widgetMembers - where - startButton = - hCenter . mkButton StartGameButton $ - T.unwords - [ ">>" - , "Launch with these settings" - , "<<" - ] - - widgetMembers = - [ controlsBox - , infoBox - , if isRight validatedOptions then startButton else emptyWidget - ] - - formatInfo header content = - hBox - [ padLeft (Pad 6) . withAttr boldAttr . txt $ brackets header - , padLeft (Pad 1) $ txtWrap content - ] - - infoContent = case validatedOptions of - Left errmsg -> withDefAttr BF.invalidFormInputAttr $ formatInfo "Error" errmsg - Right _ -> case optionDescription =<< getFocusedConfigPanel of - Just desc -> withDefAttr dimAttr $ formatInfo "Info" desc - Nothing -> str " " - - infoBox = - vLimit 4 - . padBottom Max - . padRight (Pad 2) - $ infoContent - - padControl widgetName label widgetObj = - padBottom (Pad 1) $ - padLeft (Pad 2) $ - hBox - [ mkButton widgetName (label <> ": ") - , widgetObj - ] - - controlsBox = - vBox - [ padControl ScriptSelector "Script" fileEntryWidget - , padControl SeedSelector "Seed" seedEntryWidget - ] diff --git a/src/Swarm/TUI/List.hs b/src/Swarm/TUI/List.hs deleted file mode 100644 --- a/src/Swarm/TUI/List.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A special modified version of 'Brick.Widgets.List.handleListEvent' --- to deal with skipping over separators. -module Swarm.TUI.List (handleListEventWithSeparators) where - -import Brick (EventM) -import Brick.Widgets.List qualified as BL -import Brick.Widgets.List.Skip -import Graphics.Vty qualified as V - --- | Handle a list event, taking an extra predicate to identify which --- list elements are separators; separators will be skipped if --- possible. -handleListEventWithSeparators :: - (Foldable t, BL.Splittable t, Ord n, Searchable t) => - V.Event -> - -- | Is this element a separator? - (e -> Bool) -> - EventM n (BL.GenericList n t e) () -handleListEventWithSeparators e isSep = - listSkip isSep movement - where - movement = case e of - V.EvKey V.KUp [] -> Move One Bwd - V.EvKey (V.KChar 'k') [] -> Move One Bwd - V.EvKey V.KDown [] -> Move One Fwd - V.EvKey (V.KChar 'j') [] -> Move One Fwd - V.EvKey V.KHome [] -> Move Most Bwd - V.EvKey V.KEnd [] -> Move Most Fwd - V.EvKey V.KPageDown [] -> Move Page Fwd - V.EvKey V.KPageUp [] -> Move Page Bwd - _ -> NoMove diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs deleted file mode 100644 --- a/src/Swarm/TUI/Model.hs +++ /dev/null @@ -1,467 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Application state for the @brick@-based Swarm TUI. -module Swarm.TUI.Model ( - -- * Custom UI label types - -- $uilabel - AppEvent (..), - WebCommand (..), - FocusablePanel (..), - Name (..), - - -- * Menus and dialogs - ModalType (..), - ScenarioOutcome (..), - Button (..), - ButtonAction (..), - Modal (..), - modalType, - modalDialog, - MainMenuEntry (..), - mainMenu, - Menu (..), - _NewGameMenu, - mkScenarioList, - mkNewGameMenu, - - -- * UI state - - -- ** REPL - REPLHistItem (..), - replItemText, - isREPLEntry, - getREPLEntry, - REPLHistory, - replIndex, - replLength, - replSeq, - newREPLHistory, - addREPLItem, - restartREPLHistory, - getLatestREPLHistoryItems, - moveReplHistIndex, - getCurrentItemText, - replIndexIsAtInput, - TimeDir (..), - - -- ** Prompt utils - REPLPrompt (..), - removeEntry, - - -- ** Inventory - InventoryListEntry (..), - _Separator, - _InventoryEntry, - _EquippedEntry, - - -- *** REPL Panel Model - REPLState, - ReplControlMode (..), - replPromptType, - replPromptEditor, - replPromptText, - replValid, - replLast, - replType, - replControlMode, - replHistory, - newREPLEditor, - - -- ** Updating - populateInventoryList, - infoScroll, - modalScroll, - replScroll, - - -- * Runtime state - RuntimeState, - webPort, - upstreamRelease, - eventLog, - worlds, - scenarios, - stdEntityMap, - stdRecipes, - appData, - nameParts, - - -- ** Utility - logEvent, - mkGameStateConfig, - - -- * App state - AppState (AppState), - gameState, - uiState, - runtimeState, - - -- ** Initialization - AppOpts (..), - defaultAppOpts, - Seed, - - -- *** Re-exported types used in options - ColorMode (..), - - -- ** Utility - topContext, - focusedItem, - focusedEntity, - nextScenario, - initRuntimeState, -) where - -import Brick -import Brick.Widgets.List qualified as BL -import Control.Effect.Accum -import Control.Effect.Lift -import Control.Effect.Throw -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.Sequence (Seq) -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.CESK (TickNumber (..)) -import Swarm.Game.Entity as E -import Swarm.Game.Failure -import Swarm.Game.Recipe (Recipe, loadRecipes) -import Swarm.Game.ResourceLoading (NameGenerator, initNameGenerator, readAppData) -import Swarm.Game.Robot -import Swarm.Game.Scenario.Status -import Swarm.Game.ScenarioInfo (ScenarioCollection, loadScenarios, _SISingle) -import Swarm.Game.State -import Swarm.Game.World.Load (loadWorlds) -import Swarm.Game.World.Typecheck (WorldMap) -import Swarm.Log -import Swarm.TUI.Inventory.Sorting -import Swarm.TUI.Model.Menu -import Swarm.TUI.Model.Name -import Swarm.TUI.Model.Repl -import Swarm.TUI.Model.UI -import Swarm.Util.Lens (makeLensesNoSigs) -import Swarm.Version (NewReleaseFailure (NoMainUpstreamRelease)) -import Text.Fuzzy qualified as Fuzzy - ------------------------------------------------------------- --- Custom UI label types ------------------------------------------------------------- - --- $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. -data AppEvent - = Frame - | Web WebCommand - | UpstreamVersion (Either NewReleaseFailure String) - deriving (Show) - -infoScroll :: ViewportScroll Name -infoScroll = viewportScroll InfoViewport - -modalScroll :: ViewportScroll Name -modalScroll = viewportScroll ModalViewport - -replScroll :: ViewportScroll Name -replScroll = viewportScroll REPLViewport - --- ---------------------------------------------------------------------------- --- Runtime state -- --- ---------------------------------------------------------------------------- - -data RuntimeState = RuntimeState - { _webPort :: Maybe Port - , _upstreamRelease :: Either NewReleaseFailure String - , _eventLog :: Notifications LogEntry - , _worlds :: WorldMap - , _scenarios :: ScenarioCollection - , _stdEntityMap :: EntityMap - , _stdRecipes :: [Recipe Entity] - , _appData :: Map Text Text - , _nameParts :: NameGenerator - } - -initRuntimeState :: - ( Has (Throw SystemFailure) sig m - , Has (Accum (Seq SystemFailure)) sig m - , Has (Lift IO) sig m - ) => - m RuntimeState -initRuntimeState = do - entities <- loadEntities - recipes <- loadRecipes entities - worlds <- loadWorlds entities - scenarios <- loadScenarios entities worlds - appDataMap <- readAppData - nameGen <- initNameGenerator appDataMap - return $ - RuntimeState - { _webPort = Nothing - , _upstreamRelease = Left (NoMainUpstreamRelease []) - , _eventLog = mempty - , _worlds = worlds - , _scenarios = scenarios - , _stdEntityMap = entities - , _stdRecipes = recipes - , _appData = appDataMap - , _nameParts = nameGen - } - -makeLensesNoSigs ''RuntimeState - --- | The port on which the HTTP debug service is running. -webPort :: Lens' RuntimeState (Maybe Port) - --- | The upstream release version. -upstreamRelease :: Lens' RuntimeState (Either NewReleaseFailure String) - --- | A log of runtime events. --- --- This logging is separate from the logging done during game-play. --- If some error happens before a game is even selected, this is the --- place to log it. -eventLog :: Lens' RuntimeState (Notifications LogEntry) - --- | A collection of typechecked world DSL terms that are available to --- be used in scenario definitions. -worlds :: Lens' RuntimeState WorldMap - --- | The collection of scenarios that comes with the game. -scenarios :: Lens' RuntimeState ScenarioCollection - --- | The standard entity map loaded from disk. Individual scenarios --- may define additional entities which will get added to this map --- when loading the scenario. -stdEntityMap :: Lens' RuntimeState EntityMap - --- | The standard list of recipes loaded from disk. Individual scenarios --- may define additional recipes which will get added to this list --- when loading the scenario. -stdRecipes :: Lens' RuntimeState [Recipe Entity] - --- | Free-form data loaded from the @data@ directory, for things like --- the logo, about page, tutorial story, etc. -appData :: Lens' RuntimeState (Map Text Text) - --- | Lists of words/adjectives for use in building random robot names. -nameParts :: Lens' RuntimeState NameGenerator - --------------------------------------------------- --- Utility - --- | Simply log to the runtime event log. -logEvent :: LogSource -> Severity -> Text -> Text -> Notifications LogEntry -> Notifications LogEntry -logEvent src sev who msg el = - el - & notificationsCount %~ succ - & notificationsContent %~ (l :) - where - l = LogEntry (TickNumber 0) src sev who msg - --- | Create a 'GameStateConfig' record from the 'RuntimeState'. -mkGameStateConfig :: RuntimeState -> GameStateConfig -mkGameStateConfig rs = - GameStateConfig - { initNameParts = rs ^. nameParts - , initEntities = rs ^. stdEntityMap - , initRecipes = rs ^. stdRecipes - , initWorldMap = rs ^. worlds - } - --- ---------------------------------------------------------------------------- --- APPSTATE -- --- ---------------------------------------------------------------------------- - --- | The 'AppState' just stores together the other states. --- --- This is so you can use a smaller state when e.g. writing some game logic --- 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 - , _uiState :: UIState - , _runtimeState :: RuntimeState - } - --------------------------------------------------- --- Lenses for AppState - -makeLensesNoSigs ''AppState - --- | The 'GameState' record. -gameState :: Lens' AppState GameState - --- | The 'UIState' record. -uiState :: Lens' AppState UIState - --- | The 'RuntimeState' record -runtimeState :: Lens' AppState RuntimeState - --------------------------------------------------- --- Utility functions - --- | Get the currently focused 'InventoryListEntry' from the robot --- info panel (if any). -focusedItem :: AppState -> Maybe InventoryListEntry -focusedItem s = do - list <- s ^? uiState . uiInventory . _Just . _2 - (_, entry) <- BL.listSelectedElement list - return entry - --- | Get the currently focused entity from the robot info panel (if --- any). This is just like 'focusedItem' but forgets the --- distinction between plain inventory items and equipped devices. -focusedEntity :: AppState -> Maybe Entity -focusedEntity = - focusedItem >=> \case - Separator _ -> Nothing - InventoryEntry _ e -> Just e - EquippedEntry e -> Just e - ------------------------------------------------------------- --- Functions for updating the UI state ------------------------------------------------------------- - --- | Given the focused robot, populate the UI inventory list in the info --- panel with information about its inventory. -populateInventoryList :: (MonadState UIState m) => Maybe Robot -> m () -populateInventoryList Nothing = uiInventory .= Nothing -populateInventoryList (Just r) = do - mList <- preuse (uiInventory . _Just . _2) - showZero <- use uiShowZero - sortOptions <- use uiInventorySort - search <- use uiInventorySearch - let mkInvEntry (n, e) = InventoryEntry n e - mkInstEntry (_, e) = EquippedEntry e - itemList isInventoryDisplay mk label = - (\case [] -> []; xs -> Separator label : xs) - . map mk - . sortInventory sortOptions - . filter ((&&) <$> matchesSearch <*> shouldDisplay) - . elems - where - -- Display items if we have a positive number of them, or they - -- aren't an equipped device. In other words we don't need to - -- display equipped devices twice unless we actually have some - -- in our inventory in addition to being equipped. - shouldDisplay (n, e) = - n > 0 - || isInventoryDisplay - && showZero - && not ((r ^. equippedDevices) `E.contains` e) - - matchesSearch :: (Count, Entity) -> Bool - matchesSearch (_, e) = maybe (const True) Fuzzy.test search (e ^. E.entityName) - - items = - (r ^. robotInventory . to (itemList True mkInvEntry "Compendium")) - ++ (r ^. equippedDevices . to (itemList False mkInstEntry "Equipped devices")) - - -- Attempt to keep the selected element steady. - sel = mList >>= BL.listSelectedElement -- Get the currently selected element+index. - idx = case sel of - -- If there is no currently selected element, just focus on - -- index 1 (not 0, to avoid the separator). - Nothing -> 1 - -- Otherwise, try to find the same entry in the list; - -- if it's not there, keep the index the same. - Just (selIdx, InventoryEntry _ e) -> - fromMaybe selIdx (findIndex ((== Just e) . preview (_InventoryEntry . _2)) items) - Just (selIdx, EquippedEntry e) -> - fromMaybe selIdx (findIndex ((== Just e) . preview _EquippedEntry) items) - Just (selIdx, _) -> selIdx - - -- Create the new list, focused at the desired index. - lst = BL.listMoveTo idx $ BL.list InventoryList (V.fromList items) 1 - - -- Finally, populate the newly created list in the UI, and remember - -- the hash of the current robot. - uiInventory .= Just (r ^. inventoryHash, lst) - ------------------------------------------------------------- --- App state (= UI state + game state) initialization ------------------------------------------------------------- - --- | Command-line options for configuring the app. -data AppOpts = AppOpts - { userSeed :: Maybe Seed - -- ^ Explicit seed chosen by the user. - , userScenario :: Maybe FilePath - -- ^ Scenario the user wants to play. - , scriptToRun :: Maybe FilePath - -- ^ Code to be run on base. - , autoPlay :: Bool - -- ^ Automatically run the solution defined in the scenario file - , speed :: Int - -- ^ Initial game speed (logarithm) - , cheatMode :: Bool - -- ^ Should cheat mode be enabled? - , colorMode :: Maybe ColorMode - -- ^ What colour mode should be used? - , userWebPort :: Maybe Port - -- ^ Explicit port on which to run the web API - , repoGitInfo :: Maybe GitInfo - -- ^ Information about the Git repository (not present in release). - } - --- | A default/empty 'AppOpts' record. -defaultAppOpts :: AppOpts -defaultAppOpts = - AppOpts - { userSeed = Nothing - , userScenario = Nothing - , scriptToRun = Nothing - , autoPlay = False - , speed = defaultInitLgTicksPerSecond - , cheatMode = False - , 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 - --- | Context for the REPL commands to execute in. Contains the base --- robot context plus the `it` variable that refer to the previously --- computed values. (Note that `it{n}` variables are set in the --- base robot context; we only set `it` here because it's so transient) -topContext :: AppState -> RobotContext -topContext s = ctxPossiblyWithIt - where - ctx = fromMaybe emptyRobotContext $ s ^? gameState . baseRobot . robotContext - - ctxPossiblyWithIt = case s ^. gameState . gameControls . replStatus of - REPLDone (Just p) -> ctx & at "it" ?~ p - _ -> ctx diff --git a/src/Swarm/TUI/Model/Goal.hs b/src/Swarm/TUI/Model/Goal.hs deleted file mode 100644 --- a/src/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) -import Data.Aeson -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 (listEnums) - --- | 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 listEnums) - -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 objectiveCompletion@(ObjectiveCompletion buckets _) = - M.fromList $ - mapMaybe (traverse nonEmpty) categoryList - where - categoryList = - [ (Upcoming, displayableInactives) - , (Active, suppressHidden activeGoals) - , (Completed, completed buckets) - , (Failed, unwinnable buckets) - ] - - displayableInactives = - suppressHidden $ - filter (maybe False previewable . _objectivePrerequisite) inactiveGoals - - suppressHidden = - if isCheating - then id - else filter $ not . _objectiveHidden - - (activeGoals, inactiveGoals) = partitionActiveObjectives objectiveCompletion diff --git a/src/Swarm/TUI/Model/Menu.hs b/src/Swarm/TUI/Model/Menu.hs deleted file mode 100644 --- a/src/Swarm/TUI/Model/Menu.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Sum types that represent menu options, --- modal dialogs, and buttons. -module Swarm.TUI.Model.Menu where - -import Brick.Widgets.Dialog (Dialog) -import Brick.Widgets.List qualified as BL -import Control.Lens hiding (from, (<.>)) -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.ScenarioInfo ( - ScenarioCollection, - ScenarioInfo (..), - ScenarioInfoPair, - ScenarioItem (..), - scMap, - scenarioCollectionToList, - ) -import Swarm.Game.State -import Swarm.TUI.Model.Name -import Swarm.Util -import System.FilePath (dropTrailingPathSeparator, splitPath, takeFileName) -import Witch (into) - ------------------------------------------------------------- --- Menus and dialogs ------------------------------------------------------------- - -data ScenarioOutcome = WinModal | LoseModal - deriving (Show) - -data ModalType - = HelpModal - | RecipesModal - | CommandsModal - | MessagesModal - | EntityPaletteModal - | TerrainPaletteModal - | RobotsModal - | ScenarioEndModal ScenarioOutcome - | QuitModal - | KeepPlayingModal - | DescriptionModal Entity - | GoalModal - deriving (Show) - -data ButtonAction - = Cancel - | KeepPlaying - | StartOver Seed ScenarioInfoPair - | QuitAction - | Next ScenarioInfoPair - -data Modal = Modal - { _modalType :: ModalType - , _modalDialog :: Dialog ButtonAction Name - } - -makeLenses ''Modal - -data MainMenuEntry - = NewGame - | Tutorial - | Achievements - | Messages - | About - | Quit - deriving (Eq, Ord, Show, Read, Bounded, Enum) - -data Menu - = -- | We started playing directly from command line, no menu to show - NoMenu - | MainMenu (BL.List Name MainMenuEntry) - | -- | Stack of scenario item lists. INVARIANT: the currently selected - -- 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)) - | AchievementsMenu (BL.List Name CategorizedAchievement) - | MessagesMenu - | AboutMenu - -mainMenu :: MainMenuEntry -> BL.List Name MainMenuEntry -mainMenu e = BL.list MenuList (V.fromList listEnums) 1 & BL.listMoveToElement e - -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 - ------------------------------------------------------------- --- Inventory list entries ------------------------------------------------------------- - --- | An entry in the inventory list displayed in the info panel. We --- can either have an entity with a count in the robot's inventory, --- an entity equipped on the robot, or a labelled separator. The --- purpose of the separators is to show a clear distinction between --- the robot's /inventory/ and its /equipped devices/. -data InventoryListEntry - = Separator Text - | InventoryEntry Count Entity - | EquippedEntry Entity - deriving (Eq) - -makePrisms ''InventoryListEntry diff --git a/src/Swarm/TUI/Model/Name.hs b/src/Swarm/TUI/Model/Name.hs deleted file mode 100644 --- a/src/Swarm/TUI/Model/Name.hs +++ /dev/null @@ -1,106 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Sum types representing the Brick names --- for every referenceable widget. --- --- Nesting of name types is utilized often to simplify --- case matching. -module Swarm.TUI.Model.Name where - -data WorldEditorFocusable - = BrushSelector - | EntitySelector - | AreaSelector - | OutputPathSelector - | MapSaveButton - | ClearEntityButton - deriving (Eq, Ord, Show, Read, Bounded, Enum) - -data FocusablePanel - = -- | The panel containing the REPL. - REPLPanel - | -- | The panel containing the world view. - WorldPanel - | -- | The panel containing the world editor controls. - WorldEditorPanel - | -- | The panel showing robot info and inventory on the top left. - RobotPanel - | -- | The info panel on the bottom left. - InfoPanel - deriving (Eq, Ord, Show, Read, Bounded, Enum) - -data ScenarioConfigPanel - = ScenarioConfigFileSelector - | ScenarioConfigPanelControl ScenarioConfigPanelFocusable - deriving (Eq, Ord, Show, Read) - -data ScenarioConfigPanelFocusable - = -- | The file selector for launching a scenario with a script - ScriptSelector - | SeedSelector - | StartGameButton - deriving (Eq, Ord, Show, Read, Bounded, Enum) - -data GoalWidget - = ObjectivesList - | GoalSummary - deriving (Eq, Ord, Show, Read, Bounded, Enum) - --- | Clickable buttons in modal dialogs. -data Button - = CancelButton - | KeepPlayingButton - | StartOverButton - | QuitButton - | NextButton - deriving (Eq, Ord, Show, Read, Bounded, Enum) - --- | 'Name' represents names to uniquely identify various components --- of the UI, such as forms, panels, caches, extents, lists, and buttons. -data Name - = FocusablePanel FocusablePanel - | -- | An individual control within the world editor panel. - WorldEditorPanelControl WorldEditorFocusable - | -- | The REPL input form. - REPLInput - | -- | The REPL history cache. - REPLHistoryCache - | -- | The render cache for the world view. - WorldCache - | -- | The cached extent for the world view. - WorldExtent - | -- | The cursor/viewCenter display in the bottom left of the World view - WorldPositionIndicator - | -- | The list of possible entities to paint a map with. - EntityPaintList - | -- | The entity paint item position in the EntityPaintList. - EntityPaintListItem Int - | -- | The list of possible terrain materials. - TerrainList - | -- | The terrain item position in the TerrainList. - TerrainListItem Int - | -- | The list of inventory items for the currently - -- focused robot. - InventoryList - | -- | The inventory item position in the InventoryList. - InventoryListItem Int - | -- | The list of main menu choices. - MenuList - | -- | The list of achievements. - AchievementList - | -- | An individual control within the scenario launch config panel - ScenarioConfigControl ScenarioConfigPanel - | -- | The list of goals/objectives. - GoalWidgets GoalWidget - | -- | The list of scenario choices. - ScenarioList - | -- | The scrollable viewport for the info panel. - InfoViewport - | -- | The scrollable viewport for any modal dialog. - ModalViewport - | -- | The scrollable viewport for the REPL. - REPLViewport - | -- | A clickable button in a modal dialog. - Button Button - deriving (Eq, Ord, Show, Read) diff --git a/src/Swarm/TUI/Model/Repl.hs b/src/Swarm/TUI/Model/Repl.hs deleted file mode 100644 --- a/src/Swarm/TUI/Model/Repl.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Model.Repl ( - -- ** REPL - REPLHistItem (..), - replItemText, - isREPLEntry, - getREPLEntry, - REPLHistory, - replIndex, - replLength, - replHasExecutedManualInput, - replSeq, - newREPLHistory, - addREPLItem, - restartREPLHistory, - getLatestREPLHistoryItems, - getSessionREPLHistoryItems, - moveReplHistIndex, - getCurrentItemText, - replIndexIsAtInput, - TimeDir (..), - - -- ** Prompt utils - REPLPrompt (..), - removeEntry, - - -- *** REPL Panel Model - REPLState, - ReplControlMode (..), - replPromptType, - replPromptEditor, - replPromptText, - replValid, - replLast, - replType, - replControlMode, - replHistory, - newREPLEditor, - - -- ** Initialization - initREPLState, - defaultPrompt, - lastEntry, -) 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) -import Data.Maybe (fromMaybe, isJust) -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Zipper qualified as TZ -import Servant.Docs (ToSample) -import Servant.Docs qualified as SD -import Swarm.Language.Types -import Swarm.TUI.Model.Name -import Swarm.Util.Lens (makeLensesNoSigs) -import Prelude hiding (Applicative (..)) - ------------------------------------------------------------- --- REPL History ------------------------------------------------------------- - --- | An item in the REPL history. -data REPLHistItem - = -- | Something entered by the user. - REPLEntry Text - | -- | A response printed by the system. - REPLOutput Text - | -- | An error printed by the system. - REPLError Text - deriving (Eq, Ord, Show, Read) - -instance ToSample REPLHistItem where - toSamples _ = - SD.samples - [ REPLEntry "grab" - , REPLOutput "it0 : text = \"tree\"" - , REPLEntry "place tree" - , REPLError "1:7: Unbound variable tree" - ] - -instance ToJSON REPLHistItem where - toJSON e = case e of - REPLEntry x -> object ["in" .= x] - REPLOutput x -> object ["out" .= x] - REPLError x -> object ["err" .= x] - --- | Useful helper function to only get user input text. -getREPLEntry :: REPLHistItem -> Maybe Text -getREPLEntry = \case - REPLEntry t -> Just t - _ -> Nothing - --- | Useful helper function to filter out REPL output. -isREPLEntry :: REPLHistItem -> Bool -isREPLEntry = isJust . getREPLEntry - --- | Get the text of REPL input/output. -replItemText :: REPLHistItem -> Text -replItemText = \case - REPLEntry t -> t - REPLOutput t -> t - REPLError t -> t - --- | History of the REPL with indices (0 is first entry) to the current --- line and to the first entry since loading saved history. --- We also (ab)use the length of the REPL as the index of current --- input line, since that number is one past the index of last entry. -data REPLHistory = REPLHistory - { _replSeq :: Seq REPLHistItem - , _replIndex :: Int - , _replStart :: Int - , _replHasExecutedManualInput :: Bool - } - deriving (Show) - -makeLensesNoSigs ''REPLHistory - --- | Sequence of REPL inputs and outputs, oldest entry is leftmost. -replSeq :: Lens' REPLHistory (Seq REPLHistItem) - --- | The current index in the REPL history (if the user is going back --- through the history using up/down keys). -replIndex :: Lens' REPLHistory Int - --- | The index of the first entry since loading saved history. --- --- It will be set on load and reset on save (happens during exit). -replStart :: Lens' REPLHistory Int - --- | Keep track of whether the user has explicitly executed commands --- at the REPL prompt, thus making them ineligible for code size scoring. --- --- Note: Instead of adding a dedicated field to the 'REPLHistory' record, --- an early attempt entailed checking for: --- --- @_replIndex > _replStart@ --- --- However, executing an initial script causes a "REPLOutput" to be --- appended to the REPL history, which increments the replIndex, and --- thus makes the Index greater than the Start even though the --- player has not input commands directly into the REPL. --- --- Therefore, a dedicated boolean is introduced into 'REPLHistory' --- which simply latches True when the user has input a command. --- --- An alternative is described in --- . -replHasExecutedManualInput :: Lens' REPLHistory Bool - --- | Create new REPL history (i.e. from loaded history file lines). -newREPLHistory :: [REPLHistItem] -> REPLHistory -newREPLHistory xs = - let s = Seq.fromList xs - in REPLHistory - { _replSeq = s - , _replStart = length s - , _replIndex = length s - , _replHasExecutedManualInput = False - } - --- | Point the start of REPL history after current last line. See 'replStart'. -restartREPLHistory :: REPLHistory -> REPLHistory -restartREPLHistory h = h & replStart .~ replLength h - --- | Current number lines of the REPL history - (ab)used as index of input buffer. -replLength :: REPLHistory -> Int -replLength = length . _replSeq - --- | Add new REPL input - the index must have been pointing one past --- the last element already, so we increment it to keep it that way. -addREPLItem :: REPLHistItem -> REPLHistory -> REPLHistory -addREPLItem t h = - h - & replSeq %~ (|> t) - & replIndex .~ 1 + replLength h - --- | Get the latest N items in history, starting with the oldest one. --- --- This is used to show previous REPL lines in UI, so we need the items --- sorted in the order they were entered and will be drawn top to bottom. -getLatestREPLHistoryItems :: Int -> REPLHistory -> [REPLHistItem] -getLatestREPLHistoryItems n h = toList latestN - where - latestN = Seq.drop oldestIndex $ h ^. replSeq - oldestIndex = max (h ^. replStart) $ length (h ^. replSeq) - n - --- | Get only the items from the REPL history that were entered during --- the current session. -getSessionREPLHistoryItems :: REPLHistory -> Seq REPLHistItem -getSessionREPLHistoryItems h = Seq.drop (h ^. replStart) (h ^. replSeq) - -data TimeDir = Newer | Older deriving (Eq, Ord, Show) - -moveReplHistIndex :: TimeDir -> Text -> REPLHistory -> REPLHistory -moveReplHistIndex d lastEntered history = history & replIndex .~ newIndex - where - historyLen = replLength history - curText = fromMaybe lastEntered $ getCurrentItemText history - curIndex = history ^. replIndex - entries = history ^. replSeq - -- split repl at index - (olderP, newer) = Seq.splitAt curIndex entries - -- find first different entry in direction - notSameEntry = \case - REPLEntry t -> t /= curText - _ -> False - newIndex = case d of - Newer -> maybe historyLen (curIndex +) $ Seq.findIndexL notSameEntry newer - Older -> fromMaybe curIndex $ Seq.findIndexR notSameEntry olderP - -getCurrentItemText :: REPLHistory -> Maybe Text -getCurrentItemText history = replItemText <$> Seq.lookup (history ^. replIndex) (history ^. replSeq) - -replIndexIsAtInput :: REPLHistory -> Bool -replIndexIsAtInput repl = repl ^. replIndex == replLength repl - --- | Given some text, removes the 'REPLEntry' within 'REPLHistory' which is equal to that. --- This is used when the user enters in search mode and want to traverse the history. --- If a command has been used many times, the history will be populated with it causing --- the effect that search command always finds the same command. -removeEntry :: Text -> REPLHistory -> REPLHistory -removeEntry foundtext hist = hist & replSeq %~ Seq.filter (/= REPLEntry foundtext) - --- | Get the last 'REPLEntry' in 'REPLHistory' matching the given text -lastEntry :: Text -> REPLHistory -> Maybe Text -lastEntry t h = - case Seq.viewr $ Seq.filter matchEntry $ h ^. replSeq of - Seq.EmptyR -> Nothing - _ Seq.:> a -> Just (replItemText a) - where - matchesText histItem = t `T.isInfixOf` replItemText histItem - matchEntry = liftA2 (&&) matchesText isREPLEntry - ------------------------------------------------------------- --- REPL ------------------------------------------------------------- - --- | This data type tells us how to interpret the text typed --- by the player at the prompt (which is stored in Editor). -data REPLPrompt - = -- | Interpret the prompt text as a regular command. - -- The list is for potential completions, which we can - -- cycle through by hitting Tab repeatedly - CmdPrompt [Text] - | -- | Interpret the prompt text as "search this text in history" - SearchPrompt REPLHistory - -defaultPrompt :: REPLPrompt -defaultPrompt = CmdPrompt [] - --- | What is being done with user input to the REPL panel? -data ReplControlMode - = -- | The user is typing at the REPL. - Typing - | -- | The user is driving the base using piloting mode. - Piloting - | -- | A custom user key handler is processing user input. - Handling - deriving (Eq, Bounded, Enum) - -data REPLState = REPLState - { _replPromptType :: REPLPrompt - , _replPromptEditor :: Editor Text Name - , _replValid :: Bool - , _replLast :: Text - , _replType :: Maybe Polytype - , _replControlMode :: ReplControlMode - , _replHistory :: REPLHistory - } - -newREPLEditor :: Text -> Editor Text Name -newREPLEditor t = applyEdit gotoEnd $ editorText REPLInput (Just 1) t - where - ls = T.lines t - pos = (length ls - 1, T.length (last ls)) - gotoEnd = if null ls then id else TZ.moveCursor pos - -initREPLState :: REPLHistory -> REPLState -initREPLState hist = - REPLState - { _replPromptType = defaultPrompt - , _replPromptEditor = newREPLEditor "" - , _replValid = True - , _replLast = "" - , _replType = Nothing - , _replControlMode = Typing - , _replHistory = hist - } - -makeLensesNoSigs ''REPLState - --- | The way we interpret text typed by the player in the REPL prompt. -replPromptType :: Lens' REPLState REPLPrompt - --- | The prompt where the user can type input at the REPL. -replPromptEditor :: Lens' REPLState (Editor Text Name) - --- | Convenience lens to get text from editor and replace it with new --- one that has the provided text. -replPromptText :: Lens' REPLState Text -replPromptText = lens g s - where - g r = r ^. replPromptEditor . to getEditContents . to T.concat - s r t = r & replPromptEditor .~ newREPLEditor t - --- | Whether the prompt text is a valid 'Swarm.Language.Syntax.Term'. -replValid :: Lens' REPLState Bool - --- | The type of the current REPL input which should be displayed to --- the user (if any). -replType :: Lens' REPLState (Maybe Polytype) - --- | The last thing the user has typed which isn't part of the history. --- This is used to restore the repl form after the user visited the history. -replLast :: Lens' REPLState Text - --- | The current REPL control mode, i.e. how user input to the REPL --- panel is being handled. -replControlMode :: Lens' REPLState ReplControlMode - --- | History of things the user has typed at the REPL, interleaved --- with outputs the system has generated. -replHistory :: Lens' REPLState REPLHistory diff --git a/src/Swarm/TUI/Model/StateUpdate.hs b/src/Swarm/TUI/Model/StateUpdate.hs deleted file mode 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Model.StateUpdate ( - initAppState, - initPersistentState, - constructAppState, - initAppStateForScenario, - classicGame0, - startGame, - startGameWithSeed, - restartGame, - attainAchievement, - attainAchievement', - scenarioToAppState, -) where - -import Brick.AttrMap (applyAttrMappings) -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.Effect.Accum -import Control.Effect.Lift -import Control.Effect.Throw -import Control.Lens hiding (from, (<.>)) -import Control.Monad (guard, void) -import Control.Monad.Except (ExceptT (..)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.State (MonadState, execStateT) -import Data.Foldable qualified as F -import Data.List qualified as List -import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M -import Data.Maybe (fromMaybe, isJust) -import Data.Sequence (Seq) -import Data.Text (Text) -import Data.Time (ZonedTime, getZonedTime) -import Swarm.Game.Achievement.Attainment -import Swarm.Game.Achievement.Definitions -import Swarm.Game.Achievement.Persistence -import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorlds) -import Swarm.Game.Scenario.Scoring.Best -import Swarm.Game.Scenario.Scoring.ConcreteMetrics -import Swarm.Game.Scenario.Scoring.GenericMetrics -import Swarm.Game.Scenario.Status -import Swarm.Game.ScenarioInfo ( - loadScenarioInfo, - normalizeScenarioPath, - scenarioItemByPath, - scenarioSolution, - _SISingle, - ) -import Swarm.Game.State -import Swarm.Language.Pretty (prettyText) -import Swarm.Log (LogSource (SystemLog), Severity (..)) -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.Goal (emptyGoalDisplay) -import Swarm.TUI.Model.Repl -import Swarm.TUI.Model.UI -import Swarm.TUI.View.Attribute.Attr (swarmAttrMap) -import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair) -import Swarm.Util.Effect (asExceptT, withThrow) -import System.Clock - --- | Initialize the 'AppState' from scratch. -initAppState :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - AppOpts -> - m AppState -initAppState opts = do - (rs, ui) <- initPersistentState opts - constructAppState rs ui opts - --- | Add some system failures to the list of messages in the --- 'RuntimeState'. -addWarnings :: RuntimeState -> [SystemFailure] -> RuntimeState -addWarnings = List.foldl' logWarning - where - logWarning rs' w = rs' & eventLog %~ logEvent SystemLog Error "UI Loading" (prettyText w) - --- | Based on the command line options, should we skip displaying the --- menu? -skipMenu :: AppOpts -> Bool -skipMenu AppOpts {..} = isJust userScenario || isRunningInitialProgram || isJust userSeed - where - isRunningInitialProgram = isJust scriptToRun || autoPlay - --- | 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 --- once and reuse the resulting states for all tests. -initPersistentState :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - AppOpts -> - m (RuntimeState, UIState) -initPersistentState opts@(AppOpts {..}) = do - (warnings :: Seq SystemFailure, (initRS, initUI)) <- runAccum mempty $ do - rs <- initRuntimeState - ui <- initUIState speed (not (skipMenu opts)) cheatMode - return (rs, ui) - let initRS' = addWarnings initRS (F.toList warnings) - return (initRS', initUI) - --- | 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 -> - AppOpts -> - m AppState -constructAppState rs ui opts@(AppOpts {..}) = do - let gs = initGameState (mkGameStateConfig rs) - case skipMenu opts of - False -> return $ AppState gs (ui & lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs - True -> do - (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. landscape . entityMap) (rs ^. worlds) - maybeRunScript <- traverse parseCodeFile scriptToRun - - let maybeAutoplay = do - guard autoPlay - soln <- scenario ^. scenarioSolution - 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]) - sendIO $ - execStateT - (startGameWithSeed (scenario, si) $ LaunchParams (pure userSeed) (pure codeToRun)) - (AppState gs ui newRs) - --- | 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 - --- | Re-initialize the game from the stored reference to the current scenario. --- --- Note that "restarting" is intended only for "scenarios"; --- with some scenarios, it may be possible to get stuck so that it is --- either impossible or very annoying to win, so being offered an --- option to restart is more user-friendly. --- --- Since scenarios are stored as a Maybe in the UI state, we handle the Nothing --- case upstream so that the Scenario passed to this function definitely exists. -restartGame :: (MonadIO m, MonadState AppState m) => Seed -> ScenarioInfoPair -> m () -restartGame currentSeed siPair = startGameWithSeed siPair $ 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 -> - ValidatedLaunchParams -> - m () -startGameWithSeed siPair@(_scene, si) lp = do - t <- liftIO getZonedTime - ss <- use $ runtimeState . scenarios - p <- liftIO $ normalizeScenarioPath ss (si ^. scenarioPath) - runtimeState - . scenarios - . scenarioItemByPath p - . _SISingle - . _2 - . 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 - where - prevBest t = case si ^. scenarioStatus of - NotStarted -> emptyBest t - Played _ _ b -> b - --- | Modify the 'AppState' appropriately when starting a new scenario. -scenarioToAppState :: - (MonadIO m, MonadState AppState m) => - ScenarioInfoPair -> - ValidatedLaunchParams -> - m () -scenarioToAppState siPair@(scene, _) lp = do - rs <- use runtimeState - gs <- liftIO $ scenarioToGameState scene lp $ mkGameStateConfig rs - gameState .= gs - void $ withLensIO uiState $ scenarioToUIState isAutoplaying siPair gs - where - isAutoplaying = case runIdentity (initialCode lp) of - Just (CodeToRun ScenarioSuggested _) -> True - _ -> False - - withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m x - withLensIO l a = do - x <- use l - x' <- liftIO $ a x - l .= x' - return x' - -attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m () -attainAchievement a = do - currentTime <- liftIO getZonedTime - attainAchievement' currentTime Nothing a - -attainAchievement' :: - (MonadIO m, MonadState AppState m) => - ZonedTime -> - Maybe FilePath -> - CategorizedAchievement -> - m () -attainAchievement' t p a = do - (uiState . uiAchievements) - %= M.insertWith - (<>) - a - (Attainment a p t) - newAchievements <- use $ uiState . uiAchievements - liftIO $ saveAchievementsInfo $ M.elems newAchievements - --- | Modify the UI state appropriately when starting a new scenario. -scenarioToUIState :: - Bool -> - ScenarioInfoPair -> - GameState -> - UIState -> - IO UIState -scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do - curTime <- getTime Monotonic - return $ - u - & uiPlaying .~ True - & uiGoal .~ emptyGoalDisplay - & uiCheatMode ||~ isAutoplaying - & uiHideGoals .~ (isAutoplaying && not (u ^. uiCheatMode)) - & uiFocusRing .~ initFocusRing - & uiInventory .~ Nothing - & uiInventorySort .~ defaultSortOptions - & uiShowFPS .~ False - & uiShowZero .~ True - & uiREPL .~ initREPLState (u ^. uiREPL . replHistory) - & uiREPL . replHistory %~ restartREPLHistory - & uiAttrMap .~ applyAttrMappings (map toAttrPair $ fst siPair ^. scenarioAttrs) swarmAttrMap - & scenarioRef ?~ siPair - & lastFrameTime .~ curTime - & uiWorldEditor . EM.entityPaintList %~ BL.listReplace entityList Nothing - & uiWorldEditor . EM.editingBounds . EM.boundsRect %~ setNewBounds - where - entityList = EU.getEntitiesForList $ gs ^. landscape . entityMap - - (isEmptyArea, newBounds) = EU.getEditingBounds $ NE.head $ scenario ^. scenarioWorlds - setNewBounds maybeOldBounds = - if isEmptyArea - then maybeOldBounds - else Just newBounds - --- | Create an initial app state for a specific scenario. Note that --- this function is used only for unit tests, integration tests, and --- benchmarks. --- --- In normal play, an 'AppState' already exists and we simply need --- to update it using 'scenarioToAppState'. -initAppStateForScenario :: String -> Maybe Seed -> Maybe FilePath -> ExceptT Text IO AppState -initAppStateForScenario sceneName userSeed toRun = - asExceptT . withThrow (prettyText @SystemFailure) . initAppState $ - defaultAppOpts - { userScenario = Just sceneName - , userSeed = userSeed - , scriptToRun = toRun - } - --- | For convenience, the 'AppState' corresponding to the classic game --- with seed 0. This is used only for benchmarks and unit tests. -classicGame0 :: ExceptT Text IO AppState -classicGame0 = initAppStateForScenario "classic" (Just 0) Nothing diff --git a/src/Swarm/TUI/Model/UI.hs b/src/Swarm/TUI/Model/UI.hs deleted file mode 100644 --- a/src/Swarm/TUI/Model/UI.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.Model.UI ( - UIState (..), - GoalDisplay (..), - uiMenu, - uiPlaying, - uiCheatMode, - uiFocusRing, - uiLaunchConfig, - uiWorldCursor, - uiWorldEditor, - uiREPL, - uiInventory, - uiInventorySort, - uiInventorySearch, - uiScrollToEnd, - uiModal, - uiGoal, - uiHideGoals, - uiAchievements, - lgTicksPerSecond, - lastFrameTime, - accumulatedTime, - tickCount, - frameCount, - frameTickCount, - lastInfoTime, - uiShowFPS, - uiShowREPL, - uiShowZero, - uiShowDebug, - uiShowRobots, - uiHideRobotsUntil, - uiInventoryShouldUpdate, - uiTPF, - uiFPS, - uiAttrMap, - scenarioRef, - - -- ** Initialization - initFocusRing, - defaultInitLgTicksPerSecond, - initUIState, -) 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.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 qualified as W -import Swarm.TUI.Editor.Model -import Swarm.TUI.Inventory.Sorting -import Swarm.TUI.Launch.Model -import Swarm.TUI.Launch.Prep -import Swarm.TUI.Model.Goal -import Swarm.TUI.Model.Menu -import Swarm.TUI.Model.Name -import Swarm.TUI.Model.Repl -import Swarm.TUI.View.Attribute.Attr (swarmAttrMap) -import Swarm.Util -import Swarm.Util.Lens (makeLensesExcluding) -import System.Clock - ------------------------------------------------------------- --- UI state ------------------------------------------------------------- - --- | The main record holding the UI state. For access to the fields, --- see the lenses below. -data UIState = UIState - { _uiMenu :: Menu - , _uiPlaying :: Bool - , _uiCheatMode :: Bool - , _uiFocusRing :: FocusRing Name - , _uiLaunchConfig :: LaunchOptions - , _uiWorldCursor :: Maybe (Cosmic W.Coords) - , _uiWorldEditor :: WorldEditor Name - , _uiREPL :: REPLState - , _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry) - , _uiInventorySort :: InventorySortOptions - , _uiInventorySearch :: Maybe Text - , _uiScrollToEnd :: Bool - , _uiModal :: Maybe Modal - , _uiGoal :: GoalDisplay - , _uiHideGoals :: Bool - , _uiAchievements :: Map CategorizedAchievement Attainment - , _uiShowFPS :: Bool - , _uiShowREPL :: Bool - , _uiShowZero :: Bool - , _uiShowDebug :: Bool - , _uiHideRobotsUntil :: TimeSpec - , _uiInventoryShouldUpdate :: Bool - , _uiTPF :: Double - , _uiFPS :: Double - , _lgTicksPerSecond :: Int - , _tickCount :: Int - , _frameCount :: Int - , _frameTickCount :: Int - , _lastFrameTime :: TimeSpec - , _accumulatedTime :: TimeSpec - , _lastInfoTime :: TimeSpec - , _uiAttrMap :: AttrMap - , _scenarioRef :: Maybe ScenarioInfoPair - } - --------------------------------------------------- --- Lenses for UIState - -makeLensesExcluding ['_lgTicksPerSecond] ''UIState - --- | The current menu state. -uiMenu :: Lens' UIState Menu - --- | Are we currently playing the game? --- --- * 'True' = we are playing, and --- should thus display a world, REPL, etc. --- * False = we should --- 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 - --- | Configuration modal when launching a scenario -uiLaunchConfig :: Lens' UIState LaunchOptions - --- | The focus ring is the set of UI panels we can cycle among using --- the @Tab@ key. -uiFocusRing :: Lens' UIState (FocusRing Name) - --- | The last clicked position on the world view. -uiWorldCursor :: Lens' UIState (Maybe (Cosmic W.Coords)) - --- | State of all World Editor widgets -uiWorldEditor :: Lens' UIState (WorldEditor Name) - --- | The state of REPL panel. -uiREPL :: Lens' UIState REPLState - --- | The order and direction of sorting inventory list. -uiInventorySort :: Lens' UIState InventorySortOptions - --- | The current search string used to narrow the inventory view. -uiInventorySearch :: Lens' UIState (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. -uiInventory :: Lens' UIState (Maybe (Int, BL.List Name InventoryListEntry)) - --- | A flag telling the UI to scroll the info panel to the very end --- (used when a new log message is appended). -uiScrollToEnd :: Lens' UIState 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' UIState (Maybe Modal) - --- | Status of the scenario goal: whether there is one, and whether it --- has been displayed to the user initially. -uiGoal :: Lens' UIState GoalDisplay - --- | When running with @--autoplay@, suppress the goal dialogs. --- --- For development, the @--cheat@ flag shows goals again. -uiHideGoals :: Lens' UIState Bool - --- | Map of achievements that were attained -uiAchievements :: Lens' UIState (Map CategorizedAchievement Attainment) - --- | A toggle to show the FPS by pressing @f@ -uiShowFPS :: Lens' UIState Bool - --- | A toggle to expand or collapse the REPL by pressing @Ctrl-k@ -uiShowREPL :: Lens' UIState Bool - --- | A toggle to show or hide inventory items with count 0 by pressing @0@ -uiShowZero :: Lens' UIState Bool - --- | A toggle to show debug. --- --- TODO: #1112 use record for selection of debug features? -uiShowDebug :: Lens' UIState Bool - --- | Hide robots on the world map. -uiHideRobotsUntil :: Lens' UIState TimeSpec - --- | Whether to show or hide robots on the world map. -uiShowRobots :: Getter UIState Bool -uiShowRobots = to (\ui -> ui ^. lastFrameTime > ui ^. uiHideRobotsUntil) - --- | Whether the Inventory ui panel should update -uiInventoryShouldUpdate :: Lens' UIState Bool - --- | Computed ticks per milliseconds -uiTPF :: Lens' UIState Double - --- | Computed frames per milliseconds -uiFPS :: Lens' UIState Double - --- | Attribute map -uiAttrMap :: Lens' UIState AttrMap - --- | The currently active Scenario description, useful for starting over. -scenarioRef :: Lens' UIState (Maybe ScenarioInfoPair) - --- | The base-2 logarithm of the current game speed in ticks/second. --- Note that we cap this value to the range of +/- log2 INTMAX. -lgTicksPerSecond :: Lens' UIState Int -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' UIState Int - --- | A counter used to track how many frames have been rendered since the --- last time we updated the ticks/frame statistics. -frameCount :: Lens' UIState 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' UIState Int - --- | The time of the last info widget update -lastInfoTime :: Lens' UIState TimeSpec - --- | The time of the last 'Swarm.TUI.Model.Frame' event. -lastFrameTime :: Lens' UIState 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' UIState TimeSpec - --------------------------------------------------- --- UIState initialization - --- | The initial state of the focus ring. --- NOTE: Normally, the Tab key might cycle through the members of the --- focus ring. However, the REPL already uses Tab. So, to is not used --- at all right now for navigating the toplevel focus ring. -initFocusRing :: FocusRing Name -initFocusRing = focusRing $ map FocusablePanel listEnums - --- | The initial tick speed. -defaultInitLgTicksPerSecond :: Int -defaultInitLgTicksPerSecond = 4 -- 2^4 = 16 ticks / second - --- | 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. -initUIState :: - ( Has (Accum (Seq SystemFailure)) sig m - , Has (Lift IO) sig m - ) => - Int -> - Bool -> - Bool -> - m UIState -initUIState speedFactor showMainMenu cheatMode = do - historyT <- sendIO $ readFileMayT =<< getSwarmHistoryPath False - let history = maybe [] (map REPLEntry . T.lines) historyT - startTime <- sendIO $ getTime Monotonic - achievements <- loadAchievementsInfo - launchConfigPanel <- sendIO initConfigPanel - let out = - UIState - { _uiMenu = if showMainMenu then MainMenu (mainMenu NewGame) else NoMenu - , _uiPlaying = not showMainMenu - , _uiCheatMode = cheatMode - , _uiLaunchConfig = launchConfigPanel - , _uiFocusRing = initFocusRing - , _uiWorldCursor = Nothing - , _uiWorldEditor = initialWorldEditor startTime - , _uiREPL = initREPLState $ newREPLHistory history - , _uiInventory = Nothing - , _uiInventorySort = defaultSortOptions - , _uiInventorySearch = Nothing - , _uiScrollToEnd = False - , _uiModal = Nothing - , _uiGoal = emptyGoalDisplay - , _uiHideGoals = False - , _uiAchievements = M.fromList $ map (view achievement &&& id) achievements - , _uiShowFPS = False - , _uiShowREPL = True - , _uiShowZero = True - , _uiShowDebug = False - , _uiHideRobotsUntil = startTime - 1 - , _uiInventoryShouldUpdate = False - , _uiTPF = 0 - , _uiFPS = 0 - , _lgTicksPerSecond = speedFactor - , _lastFrameTime = startTime - , _accumulatedTime = 0 - , _lastInfoTime = 0 - , _tickCount = 0 - , _frameCount = 0 - , _frameTickCount = 0 - , _uiAttrMap = swarmAttrMap - , _scenarioRef = Nothing - } - return out diff --git a/src/Swarm/TUI/Panel.hs b/src/Swarm/TUI/Panel.hs deleted file mode 100644 --- a/src/Swarm/TUI/Panel.hs +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -{-# LANGUAGE TemplateHaskell #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A small custom "panel widget" for use in the Swarm TUI. Panels draw --- a border around some content, with the color of the border --- depending on whether the panel is currently focused. Panels exist --- within a 'FocusRing' such that the user can cycle between the --- panels (using /e.g./ the @Tab@ key). -module Swarm.TUI.Panel ( - panel, -) where - -import Brick -import Brick.Focus -import Brick.Widgets.Border -import Control.Lens -import Swarm.TUI.Border - -data Panel n = Panel - {_panelName :: n, _panelLabels :: BorderLabels n, _panelContent :: Widget n} - -makeLenses ''Panel - -instance Named (Panel n) n where - getName = view panelName - -drawPanel :: Eq n => AttrName -> FocusRing n -> Panel n -> Widget n -drawPanel attr fr = withFocusRing fr drawPanel' - where - drawPanel' :: Bool -> Panel n -> Widget n - drawPanel' focused p = - (if focused then overrideAttr borderAttr attr else id) $ - borderWithLabels (p ^. panelLabels) (p ^. panelContent) - --- | Create a panel. -panel :: - Eq n => - -- | Border attribute to use when the panel is focused. - AttrName -> - -- | Focus ring the panel should be part of. - FocusRing n -> - -- | The name of the panel. Must be unique. - n -> - -- | The labels to use around the border. - BorderLabels n -> - -- | The content of the panel. - Widget n -> - Widget n -panel attr fr nm labs w = drawPanel attr fr (Panel nm labs w) diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs deleted file mode 100644 --- a/src/Swarm/TUI/View.hs +++ /dev/null @@ -1,1481 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Code for drawing the TUI. -module Swarm.TUI.View ( - drawUI, - drawTPS, - - -- * Dialog box - drawDialog, - chooseCursor, - - -- * Key hint menu - drawKeyMenu, - drawModalMenu, - drawKeyCmd, - - -- * World - drawWorldPane, - - -- * Robot panel - drawRobotPanel, - drawItem, - drawLabelledEntityName, - renderDutyCycle, - - -- * Info panel - drawInfoPanel, - explainFocusedItem, - - -- * REPL - drawREPL, -) where - -import Brick hiding (Direction, Location) -import Brick.Focus -import Brick.Forms -import Brick.Widgets.Border ( - hBorder, - hBorderWithLabel, - joinableBorder, - vBorder, - ) -import Brick.Widgets.Center (center, centerLayer, hCenter) -import Brick.Widgets.Dialog -import Brick.Widgets.Edit (getEditContents, renderEditor) -import Brick.Widgets.List qualified as BL -import Brick.Widgets.Table qualified as BT -import Control.Lens 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.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NE -import Data.List.Split (chunksOf) -import Data.Map qualified as M -import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe, mapMaybe, maybeToList) -import Data.Semigroup (sconcat) -import Data.Sequence qualified as Seq -import Data.Set qualified as Set (toList) -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 (..), TickNumber (..), addTicks) -import Swarm.Game.Display -import Swarm.Game.Entity as E -import Swarm.Game.Location -import Swarm.Game.Recipe -import Swarm.Game.Robot -import Swarm.Game.Scenario ( - scenarioAuthor, - scenarioCreative, - scenarioDescription, - scenarioKnown, - scenarioName, - scenarioObjectives, - scenarioSeed, - ) -import Swarm.Game.Scenario.Scoring.Best -import Swarm.Game.Scenario.Scoring.CodeSize -import Swarm.Game.Scenario.Scoring.ConcreteMetrics -import Swarm.Game.Scenario.Scoring.GenericMetrics -import Swarm.Game.Scenario.Status -import Swarm.Game.ScenarioInfo ( - ScenarioItem (..), - scenarioItemName, - ) -import Swarm.Game.State -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -import Swarm.Language.Capability (Capability (..), constCaps) -import Swarm.Language.Pretty (prettyText, prettyTextLine) -import Swarm.Language.Syntax -import Swarm.Language.Typecheck (inferConst) -import Swarm.Log -import Swarm.TUI.Border -import Swarm.TUI.Controller (ticksPerFrameCap) -import Swarm.TUI.Editor.Model -import Swarm.TUI.Editor.View qualified as EV -import Swarm.TUI.Inventory.Sorting (renderSortMethod) -import Swarm.TUI.Launch.Model -import Swarm.TUI.Launch.View -import Swarm.TUI.Model -import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow) -import Swarm.TUI.Model.Repl (getSessionREPLHistoryItems, lastEntry) -import Swarm.TUI.Model.UI -import Swarm.TUI.Panel -import Swarm.TUI.View.Achievement -import Swarm.TUI.View.Attribute.Attr -import Swarm.TUI.View.CellDisplay -import Swarm.TUI.View.Objective qualified as GR -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) - --- | The main entry point for drawing the entire UI. Figures out --- which menu screen we should show (if any), or just the game itself. -drawUI :: AppState -> [Widget Name] -drawUI s - | s ^. uiState . uiPlaying = drawGameUI s - | otherwise = case s ^. uiState . uiMenu of - -- We should never reach the NoMenu case if uiPlaying is false; we would have - -- 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 - AchievementsMenu l -> [drawAchievementsMenuUI s l] - MessagesMenu -> [drawMainMessages s] - AboutMenu -> [drawAboutMenuUI (s ^. runtimeState . appData . at "about")] - -drawMainMessages :: AppState -> Widget Name -drawMainMessages s = renderDialog dial . padBottom Max . scrollList $ drawLogs ls - where - ls = reverse $ s ^. runtimeState . eventLog . notificationsContent - dial = dialog (Just $ str "Messages") Nothing maxModalWindowWidth - scrollList = withVScrollBars OnRight . vBox - drawLogs = map (drawLogEntry True) - -drawMainMenuUI :: AppState -> BL.List Name MainMenuEntry -> Widget Name -drawMainMenuUI s l = - vBox . catMaybes $ - [ drawLogo <$> logo - , hCenter . padTopBottom 2 <$> newVersionWidget version - , Just . centerLayer . vLimit 6 . hLimit 20 $ - BL.renderList (const (hCenter . drawMainMenuEntry s)) True l - ] - where - logo = s ^. runtimeState . appData . at "logo" - version = s ^. runtimeState . upstreamRelease - -newVersionWidget :: Either NewReleaseFailure 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 - -drawLogo :: Text -> Widget Name -drawLogo = centerLayer . vBox . map (hBox . T.foldr (\c ws -> drawThing c : ws) []) . T.lines - where - drawThing :: Char -> Widget Name - drawThing c = withAttr (attrFor c) $ str [c] - - attrFor :: Char -> AttrName - attrFor c - | c `elem` ("<>v^" :: String) = robotAttr - attrFor 'T' = plantAttr - attrFor '@' = rockAttr - attrFor '~' = waterAttr - attrFor '▒' = dirtAttr - attrFor _ = defAttr - --- | 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) -> - LaunchOptions -> - [Widget Name] -drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of - Nothing -> pure mainWidget - Just _ -> drawLaunchConfigPanel launchOptions <> pure mainWidget - where - displayedFor = launchOptions ^. controls . isDisplayedFor - mainWidget = - vBox - [ padLeftRight 20 - . centerLayer - $ hBox - [ vBox - [ withAttr boldAttr . txt $ breadcrumbs ls - , txt " " - , vLimit 20 - . hLimit 35 - . BL.renderList (const $ padRight Max . drawScenarioItem) True - $ l - ] - , padLeft (Pad 5) (maybe (txt "") (drawDescription . snd) (BL.listSelectedElement l)) - ] - , launchOptionsMessage - ] - - launchOptionsMessage = case (displayedFor, snd <$> BL.listSelectedElement l) of - (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 ^. 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 ^. scenarioObjectives of - [] -> withAttr cyanAttr $ txt " ◉ " - _ -> withAttr yellowAttr $ txt " ◎ " - Played _initialScript (Metric Completed _) _ -> withAttr greenAttr $ txt " ● " - - 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 = - T.intercalate " > " - . ("Scenarios" :) - . reverse - . mapMaybe (fmap (scenarioItemName . snd) . BL.listSelectedElement) - - drawDescription :: ScenarioItem -> Widget Name - drawDescription (SICollection _ _) = txtWrap " " - drawDescription (SISingle (s, si)) = - vBox - [ drawMarkdown (nonBlank (s ^. scenarioDescription)) - , hCenter . padTop (Pad 1) . vLimit 6 $ hLimitPercent 60 worldPeek - , padTop (Pad 1) table - ] - where - defaultVC = Cosmic DefaultRootSubworld origin - - -- The first robot is guaranteed to be the base. - baseRobotLoc :: Maybe (Cosmic Location) - baseRobotLoc = do - theBaseRobot <- listToMaybe theRobots - view trobotLocation theBaseRobot - - vc = fromMaybe defaultVC baseRobotLoc - - worldTuples = buildWorldTuples s - theWorlds = genMultiWorld worldTuples $ fromMaybe 0 $ s ^. scenarioSeed - theRobots = genRobotTemplates s worldTuples - - ri = - RenderingInput theWorlds $ - getEntityIsKnown $ - EntityKnowledgeDependencies - { isCreativeMode = s ^. scenarioCreative - , globallyKnownEntities = s ^. scenarioKnown - , theFocusedRobot = Nothing - } - renderCoord = renderDisplay . displayLocRaw (WorldOverdraw False mempty) ri [] - worldPeek = worldWidget renderCoord vc - - firstRow = - ( withAttr dimAttr $ txt "Author:" - , withAttr dimAttr . txt <$> s ^. scenarioAuthor - ) - secondRow = - ( txt "last:" - , Just $ describeStatus $ si ^. scenarioStatus - ) - - padTopLeft = padTop (Pad 1) . padLeft (Pad 1) - - tableRows = - map (map padTopLeft . pairToList) $ - mapMaybe sequenceA $ - firstRow : secondRow : makeBestScoreRows (si ^. scenarioStatus) - table = - BT.renderTable - . BT.surroundingBorder False - . BT.rowBorders False - . BT.columnBorders False - . BT.alignRight 0 - . BT.alignLeft 1 - . BT.table - $ tableRows - - nonBlank "" = " " - nonBlank t = t - -pairToList :: (a, a) -> [a] -pairToList (x, y) = [x, y] - -describeProgress :: ProgressMetric -> Widget n -describeProgress (Metric p (ProgressStats _startedAt (AttemptMetrics (DurationMetrics e t) maybeCodeMetrics))) = case p of - Attempted -> - withAttr yellowAttr . vBox $ - [ txt "in progress" - , txt $ parens $ T.unwords ["played for", formatTimeDiff e] - ] - Completed -> - withAttr greenAttr . vBox $ - [ txt $ T.unwords ["completed in", formatTimeDiff e] - , txt . (" " <>) . parens $ T.unwords [T.pack $ drawTime t True, "ticks"] - ] - <> maybeToList (sizeDisplay <$> maybeCodeMetrics) - where - sizeDisplay (ScenarioCodeMetrics myCharCount myAstSize) = - withAttr greenAttr $ - vBox $ - map - txt - [ T.unwords - [ "Code:" - , T.pack $ show myCharCount - , "chars" - ] - , (" " <>) $ - parens $ - T.unwords - [ T.pack $ show myAstSize - , "AST nodes" - ] - ] - where - formatTimeDiff :: NominalDiffTime -> Text - formatTimeDiff = T.pack . formatTime defaultTimeLocale "%hh %Mm %Ss" - --- | If there are multiple different games that each are \"best\" --- by different criteria, display them all separately, labeled --- by which criteria they were best in. --- --- On the other hand, if all of the different \"best\" criteria are for the --- same game, consolidate them all into one entry and don't bother --- labelling the criteria. -makeBestScoreRows :: - ScenarioStatus -> - [(Widget n1, Maybe (Widget n2))] -makeBestScoreRows scenarioStat = - maybe [] makeBestRows getBests - where - getBests = case scenarioStat of - NotStarted -> Nothing - Played _initialScript _ best -> Just best - - makeBestRows b = map (makeBestRow hasMultiple) groups - where - groups = getBestGroups b - hasMultiple = length groups > 1 - - makeBestRow hasDistinctByCriteria (b, criteria) = - ( hLimit (maxLeftColumnWidth + 2) $ - vBox $ - [ padLeft Max $ txt "best:" - ] - <> elaboratedCriteria - , Just $ describeProgress b - ) - where - maxLeftColumnWidth = maximum (map (T.length . describeCriteria) listEnums) - mkCriteriaRow = - withAttr dimAttr - . padLeft Max - . txt - . mconcat - . pairToList - . fmap (\x -> T.singleton $ if x == 0 then ',' else ' ') - elaboratedCriteria = - if hasDistinctByCriteria - then - map mkCriteriaRow - . flip zip [(0 :: Int) ..] - . NE.toList - . NE.reverse - . NE.map describeCriteria - $ criteria - else [] - -drawMainMenuEntry :: AppState -> MainMenuEntry -> Widget Name -drawMainMenuEntry s = \case - NewGame -> txt "New game" - Tutorial -> txt "Tutorial" - Achievements -> txt "Achievements" - About -> txt "About" - Messages -> highlightMessages $ txt "Messages" - Quit -> txt "Quit" - where - highlightMessages = - if s ^. runtimeState . eventLog . notificationsCount > 0 - then withAttr notifAttr - else id - -drawAboutMenuUI :: Maybe Text -> Widget Name -drawAboutMenuUI Nothing = centerLayer $ txt "About swarm!" -drawAboutMenuUI (Just t) = centerLayer . vBox . map (hCenter . txt . nonblank) $ T.lines t - where - -- Turn blank lines into a space so they will take up vertical space as widgets - nonblank "" = " " - nonblank s = s - --- | Draw the main game UI. Generates a list of widgets, where each --- represents a layer. Right now we just generate two layers: the --- main layer and a layer for a floating dialog that can be on top. -drawGameUI :: AppState -> [Widget Name] -drawGameUI s = - [ joinBorders $ drawDialog s - , joinBorders $ - hBox - [ hLimitPercent 25 $ - vBox - [ vLimitPercent 50 - $ panel - highlightAttr - fr - (FocusablePanel RobotPanel) - ( plainBorder - & bottomLabels . centerLabel - .~ fmap - (txt . (" Search: " <>) . (<> " ")) - (s ^. uiState . uiInventorySearch) - ) - $ drawRobotPanel s - , panel - highlightAttr - fr - (FocusablePanel InfoPanel) - plainBorder - $ drawInfoPanel s - , hCenter - . clickable (FocusablePanel WorldEditorPanel) - . EV.drawWorldEditor fr - $ s ^. uiState - ] - , vBox rightPanel - ] - ] - where - addCursorPos = bottomLabels . leftLabel ?~ padLeftRight 1 widg - where - widg = case s ^. uiState . uiWorldCursor of - Nothing -> str $ renderCoordsString $ s ^. gameState . viewCenter - Just coord -> clickable WorldPositionIndicator $ drawWorldCursorInfo (s ^. uiState . uiWorldEditor . worldOverdraw) (s ^. gameState) 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 . lgTicksPerSecond) $ s ^. gameState) - fr = s ^. uiState . uiFocusRing - showREPL = s ^. uiState . uiShowREPL - rightPanel = if showREPL then worldPanel ++ replPanel else worldPanel ++ minimizedREPL - minimizedREPL = case focusGetCurrent fr of - (Just (FocusablePanel REPLPanel)) -> [separateBorders $ clickable (FocusablePanel REPLPanel) (forceAttr highlightAttr hBorder)] - _ -> [separateBorders $ clickable (FocusablePanel REPLPanel) hBorder] - worldPanel = - [ panel - highlightAttr - fr - (FocusablePanel WorldPanel) - ( plainBorder - & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s) - & topLabels . leftLabel ?~ drawModalMenu s - & addCursorPos - & addClock - ) - (drawWorldPane (s ^. uiState) (s ^. gameState)) - , drawKeyMenu s - ] - replPanel = - [ clickable (FocusablePanel REPLPanel) $ - panel - highlightAttr - fr - (FocusablePanel REPLPanel) - ( plainBorder - & topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiREPL . replType)) - ) - ( vLimit replHeight - . padBottom Max - . padLeft (Pad 1) - $ drawREPL s - ) - ] - -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 W.Coords -> Widget Name -drawWorldCursorInfo worldEditor g cCoords = - case getStatic g coords of - Just s -> renderDisplay $ displayStatic s - Nothing -> hBox $ tileMemberWidgets ++ [coordsWidget] - where - Cosmic _ coords = cCoords - coordsWidget = str $ renderCoordsString $ fmap W.coordsToLoc cCoords - - tileMembers = terrain : mapMaybe merge [entity, robot] - tileMemberWidgets = - map (padRight $ Pad 1) - . concat - . reverse - . zipWith f tileMembers - $ ["at", "on", "with"] - where - f cell preposition = [renderDisplay cell, txt preposition] - - ri = RenderingInput (g ^. landscape . multiWorld) (getEntityIsKnown $ mkEntityKnowledge g) - terrain = displayTerrainCell worldEditor ri cCoords - entity = displayEntityCell worldEditor ri cCoords - robot = displayRobotCell g cCoords - - merge = fmap sconcat . NE.nonEmpty . filter (not . (^. invisible)) - --- | Format the clock display to be shown in the upper right of the --- world panel. -drawClockDisplay :: Int -> GameState -> Widget n -drawClockDisplay lgTPS gs = hBox . intersperse (txt " ") $ catMaybes [clockWidget, pauseWidget] - where - 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. -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 [] - --- | Return a possible time display, if the currently focused robot --- has a clock device equipped. The first argument is the number --- of ticks (e.g. 943 = 0x3af), and the second argument indicates --- 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) - --- | Draw info about the current number of ticks per second. -drawTPS :: AppState -> Widget Name -drawTPS s = 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 . uiShowFPS = - [ txt " (" - , let tpf = s ^. uiState . uiTPF - in (if tpf >= fromIntegral ticksPerFrameCap then withAttr redAttr else id) - (str (printf "%0.1f" tpf)) - , txt " tpf, " - , str (printf "%0.1f" (s ^. uiState . uiFPS)) - , txt " fps)" - ] - | otherwise = [] - - l = s ^. uiState . lgTicksPerSecond - n = 2 ^ abs l - --- | The height of the REPL box. Perhaps in the future this should be --- configurable. -replHeight :: Int -replHeight = 10 - --- | Hide the cursor when a modal is set -chooseCursor :: AppState -> [CursorLocation n] -> Maybe (CursorLocation n) -chooseCursor s locs = case s ^. uiState . 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 . 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 . seed) (s ^. runtimeState . webPort) - RobotsModal -> robotsListWidget s - RecipesModal -> availableListWidget (s ^. gameState) RecipeList - CommandsModal -> commandsListWidget (s ^. gameState) - MessagesModal -> availableListWidget (s ^. gameState) MessageList - 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 . uiGoal) - 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 - 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 - -robotsListWidget :: AppState -> Widget Name -robotsListWidget s = hCenter table - 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 - 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 . lastFrameTime - age = nowSec - createdAtSec - - rInvCount = sum $ map fst . E.elems $ robot ^. robotEntity . entityInventory - rLog - | robot ^. robotLogUpdated = "x" - | otherwise = " " - - locWidget = hBox [worldCell, str $ " " <> locStr] - where - rCoords = fmap W.locToCoords rLoc - rLoc = robot ^. robotLocation - worldCell = - drawLoc - (s ^. uiState) - g - rCoords - locStr = renderCoordsString rLoc - - statusWidget = case robot ^. machine of - Waiting {} -> txt "waiting" - _ - | isActive robot -> withAttr notifAttr $ txt "busy" - | otherwise -> withAttr greenAttr $ txt "idle" - - 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 ^. robotMap - creative = g ^. creativeMode - cheat = s ^. uiState . uiCheatMode - debugging = creative && cheat - g = s ^. gameState - -helpWidget :: Seed -> Maybe Port -> Widget Name -helpWidget theSeed mport = - padTop (Pad 1) $ - (hBox . map (padLeftRight 2) $ [helpKeys, info]) - <=> padTop (Pad 1) (hCenter tips) - where - tips = - vBox - [ txt "Have questions? Want some tips? Check out:" - , txt " " - , txt $ " - The Swarm wiki, " <> wikiUrl - , txt " - The #swarm IRC channel on Libera.Chat" - ] - info = - vBox - [ txt "Configuration" - , txt " " - , txt ("Seed: " <> into @Text (show theSeed)) - , txt ("Web server port: " <> maybe "none" (into @Text . show) mport) - ] - helpKeys = - vBox - [ txt "Keybindings" - , txt " " - , mkTable glKeyBindings - ] - mkTable = - BT.renderTable - . BT.surroundingBorder False - . BT.rowBorders False - . BT.table - . map toRow - toRow (k, v) = [padRight (Pad 1) $ txt k, padLeft (Pad 1) $ txt v] - glKeyBindings = - [ ("F1", "Help") - , ("F2", "Robots list") - , ("F3", "Available recipes") - , ("F4", "Available commands") - , ("F5", "Messages") - , ("Ctrl-g", "show goal") - , ("Ctrl-p", "pause") - , ("Ctrl-o", "single step") - , ("Ctrl-z", "decrease speed") - , ("Ctrl-w", "increase speed") - , ("Ctrl-q", "quit the current scenario") - , ("Ctrl-s", "collapse/expand REPL") - , ("Meta-h", "hide robots for 2s") - , ("Meta-w", "focus on the world map") - , ("Meta-e", "focus on the robot inventory") - , ("Meta-r", "focus on the REPL") - , ("Meta-t", "focus on the info panel") - ] - -data NotificationList = RecipeList | MessageList - -availableListWidget :: GameState -> NotificationList -> Widget Name -availableListWidget gs nl = padTop (Pad 1) $ vBox widgetList - where - widgetList = case nl of - RecipeList -> mkAvailableList gs (discovery . availableRecipes) renderRecipe - MessageList -> messagesWidget gs - renderRecipe = padLeftRight 18 . drawRecipe Nothing (fromMaybe E.empty inv) - inv = gs ^? to focusedRobot . _Just . robotInventory - -mkAvailableList :: GameState -> Lens' GameState (Notifications a) -> (a -> Widget Name) -> [Widget Name] -mkAvailableList gs notifLens notifRender = map padRender news <> notifSep <> map padRender knowns - where - padRender = padBottom (Pad 1) . notifRender - count = gs ^. notifLens . notificationsCount - (news, knowns) = splitAt count (gs ^. notifLens . notificationsContent) - notifSep - | count > 0 && not (null knowns) = - [ padBottom (Pad 1) (withAttr redAttr $ hBorderWithLabel (padLeftRight 1 (txt "new↑"))) - ] - | otherwise = [] - -commandsListWidget :: GameState -> Widget Name -commandsListWidget gs = - hCenter $ - vBox - [ table - , padTop (Pad 1) $ txt "For the full list of available commands see the Wiki at:" - , txt wikiCheatSheet - ] - where - commands = gs ^. discovery . availableCommands . notificationsContent - table = - BT.renderTable - . BT.surroundingBorder False - . BT.columnBorders False - . BT.rowBorders False - . BT.setDefaultColAlignment BT.AlignLeft - . BT.alignRight 0 - . BT.table - $ headers : commandsTable - headers = - withAttr robotAttr - <$> [ txt "command name" - , txt " : type" - , txt "Enabled by" - ] - - commandsTable = mkCmdRow <$> commands - mkCmdRow cmd = - map - (padTop $ Pad 1) - [ txt $ syntax $ constInfo cmd - , padRight (Pad 2) . withAttr magentaAttr . txt $ " : " <> prettyTextLine (inferConst cmd) - , listDevices cmd - ] - - base = gs ^? baseRobot - entsByCap = case base of - Just r -> - M.map NE.toList $ - entitiesByCapability $ - (r ^. equippedDevices) `union` (r ^. robotInventory) - Nothing -> mempty - - listDevices cmd = vBox $ map drawLabelledEntityName providerDevices - where - providerDevices = - concatMap (flip (M.findWithDefault []) entsByCap) $ - maybeToList $ - 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) - --- | 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 - drawLogEntry' e = - withAttr (colorLogs e) $ - hBox - [ fromMaybe (txt "") $ maybeDrawTime (e ^. leTime) True gs - , padLeft (Pad 2) . txt $ brackets $ e ^. leName - , padLeft (Pad 1) . txt2 $ e ^. leText - ] - txt2 = txtWrapWith indent2 - -colorLogs :: LogEntry -> AttrName -colorLogs e = case e ^. leSource of - SystemLog -> colorSeverity (e ^. leSeverity) - RobotLog rls rid _loc -> case rls of - Said -> robotColor rid - Logged -> notifAttr - RobotError -> colorSeverity (e ^. leSeverity) - where - -- color each robot message with different color of the world - robotColor = indexWrapNonEmpty worldAttributeNames - -colorSeverity :: Severity -> AttrName -colorSeverity = \case - Info -> infoAttr - Debug -> dimAttr - Warning -> yellowAttr - Error -> redAttr - 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 - where - notificationKey :: Getter GameState (Notifications a) -> Text -> Text -> Maybe (KeyHighlight, Text, Text) - notificationKey notifLens key name - | null (s ^. gameState . notifLens . notificationsContent) = Nothing - | otherwise = - let highlight - | s ^. gameState . notifLens . notificationsCount > 0 = Alert - | otherwise = NoHighlight - in Just (highlight, key, name) - - globalKeyCmds = - catMaybes - [ Just (NoHighlight, "F1", "Help") - , Just (NoHighlight, "F2", "Robots") - , notificationKey (discovery . availableRecipes) "F3" "Recipes" - , notificationKey (discovery . availableCommands) "F4" "Commands" - , notificationKey messageNotifications "F5" "Messages" - ] - --- | 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 = - vLimit 2 $ - hBox - [ padBottom Max $ - vBox - [ mkCmdRow globalKeyCmds - , padLeft (Pad 2) contextCmds - ] - , gameModeWidget - ] - where - mkCmdRow = hBox . map drawPaddedCmd - drawPaddedCmd = padLeftRight 1 . drawKeyCmd - contextCmds - | ctrlMode == Handling = txt $ fromMaybe "" (s ^? gameState . gameControls . inputHandler . _Just . _1) - | otherwise = mkCmdRow focusedPanelCmds - focusedPanelCmds = - map highlightKeyCmds - . keyCmdsFor - . focusGetCurrent - . view (uiState . uiFocusRing) - $ s - - isReplWorking = s ^. gameState . gameControls . replWorking - isPaused = s ^. gameState . temporal . paused - hasDebug = fromMaybe creative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug - viewingBase = (s ^. gameState . viewCenterRule) == VCRobot 0 - creative = s ^. gameState . creativeMode - cheat = s ^. uiState . uiCheatMode - goal = hasAnythingToShow $ s ^. uiState . uiGoal . goalsContent - showZero = s ^. uiState . uiShowZero - inventorySort = s ^. uiState . uiInventorySort - inventorySearch = s ^. uiState . uiInventorySearch - ctrlMode = s ^. uiState . uiREPL . replControlMode - canScroll = creative || (s ^. gameState . landscape . worldScrollable) - handlerInstalled = isJust (s ^. gameState . gameControls . inputHandler) - - renderPilotModeSwitch :: ReplControlMode -> T.Text - renderPilotModeSwitch = \case - Piloting -> "REPL" - _ -> "pilot" - - renderHandlerModeSwitch :: ReplControlMode -> T.Text - renderHandlerModeSwitch = \case - Handling -> "REPL" - _ -> "key handler" - - gameModeWidget = - padLeft Max - . padLeftRight 1 - . txt - . (<> " mode") - $ case creative of - False -> "Classic" - True -> "Creative" - globalKeyCmds = - catMaybes - [ may goal (NoHighlight, "^g", "goal") - , may cheat (NoHighlight, "^v", "creative") - , may cheat (NoHighlight, "^e", "editor") - , Just (NoHighlight, "^p", if isPaused then "unpause" else "pause") - , may isPaused (NoHighlight, "^o", "step") - , may (isPaused && hasDebug) (if s ^. uiState . uiShowDebug then Alert else NoHighlight, "M-d", "debug") - , Just (NoHighlight, "^zx", "speed") - , Just (NoHighlight, "M-,", if s ^. uiState . uiShowREPL then "hide REPL" else "show REPL") - , Just (if s ^. uiState . uiShowRobots then NoHighlight else Alert, "M-h", "hide robots") - ] - may b = if b then Just else const Nothing - - highlightKeyCmds (k, n) = (PanelSpecific, k, n) - - keyCmdsFor (Just (FocusablePanel WorldEditorPanel)) = - [("^s", "save map")] - keyCmdsFor (Just (FocusablePanel REPLPanel)) = - [ ("↓↑", "history") - ] - ++ [("Enter", "execute") | not isReplWorking] - ++ [("^c", "cancel") | isReplWorking] - ++ [("M-p", renderPilotModeSwitch ctrlMode) | creative] - ++ [("M-k", renderHandlerModeSwitch ctrlMode) | handlerInstalled] - ++ [("PgUp/Dn", "scroll")] - keyCmdsFor (Just (FocusablePanel WorldPanel)) = - [ ("←↓↑→ / hjkl", "scroll") | canScroll - ] - ++ [("c", "recenter") | not viewingBase] - ++ [("f", "FPS")] - keyCmdsFor (Just (FocusablePanel RobotPanel)) = - ("Enter", "pop out") - : if isJust inventorySearch - then [("Esc", "exit search")] - else - [ ("m", "make") - , ("0", (if showZero then "hide" else "show") <> " 0") - , (":/;", T.unwords ["Sort:", renderSortMethod inventorySort]) - , ("/", "search") - ] - keyCmdsFor (Just (FocusablePanel InfoPanel)) = [] - keyCmdsFor _ = [] - -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 - ] - where - attr = case h of - NoHighlight -> defAttr - Alert -> notifAttr - PanelSpecific -> highlightAttr - ------------------------------------------------------------- --- World panel ------------------------------------------------------------- - -worldWidget :: - (Cosmic W.Coords -> Widget n) -> - -- | view center - Cosmic Location -> - Widget n -worldWidget renderCoord gameViewCenter = Widget Fixed Fixed $ - do - ctx <- getContext - let w = ctx ^. availWidthL - h = ctx ^. availHeightL - vr = viewingRegion gameViewCenter (fromIntegral w, fromIntegral h) - ixs = range $ vr ^. planar - render . vBox . map hBox . chunksOf w . map (renderCoord . Cosmic (vr ^. subworld)) $ ixs - --- | Draw the current world view. -drawWorldPane :: UIState -> GameState -> Widget Name -drawWorldPane ui g = - center - . cached WorldCache - . reportExtent WorldExtent - -- Set the clickable request after the extent to play nice with the cache - . clickable (FocusablePanel WorldPanel) - $ worldWidget renderCoord (g ^. viewCenter) - where - renderCoord = drawLoc ui g - ------------------------------------------------------------- --- Robot inventory panel ------------------------------------------------------------- - --- | 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 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 . uiInventory = - let drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb - row = - [ txt (r ^. robotName) - , padLeft (Pad 2) . str . renderCoordsString $ r ^. robotLocation - , padLeft (Pad 2) $ renderDisplay (r ^. robotDisplay) - ] - in padBottom Max $ - vBox - [ hCenter $ hBox row - , withLeftPaddedVScrollBars . padLeft (Pad 1) . padTop (Pad 1) $ - BL.renderListWithIndex drawClickableItem True lst - ] - | otherwise = blank - -blank :: Widget Name -blank = padRight Max . padBottom Max $ str " " - --- | Draw an inventory entry. -drawItem :: - -- | The index of the currently selected inventory entry - Maybe Int -> - -- | The index of the entry we are drawing - Int -> - -- | Whether this entry is selected; we can ignore this - -- because it will automatically have a special attribute - -- applied to it. - Bool -> - -- | The entry to draw. - InventoryListEntry -> - Widget Name -drawItem sel i _ (Separator l) = - -- Make sure a separator right before the focused element is - -- visible. Otherwise, when a separator occurs as the very first - -- 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) -drawItem _ _ _ (InventoryEntry n e) = drawLabelledEntityName e <+> showCount n - where - showCount = padLeft Max . str . show -drawItem _ _ _ (EquippedEntry e) = drawLabelledEntityName e <+> padLeft Max (str " ") - --- | Draw the name of an entity, labelled with its visual --- representation as a cell in the world. -drawLabelledEntityName :: Entity -> Widget Name -drawLabelledEntityName e = - hBox - [ padRight (Pad 2) (renderDisplay (e ^. entityDisplay)) - , txt (e ^. entityName) - ] - ------------------------------------------------------------- --- Info panel ------------------------------------------------------------- - --- | Draw the info panel in the bottom-left corner, which shows info --- about the currently focused inventory item. -drawInfoPanel :: AppState -> Widget Name -drawInfoPanel s - | Just Far <- s ^. gameState . to focusedRange = blank - | otherwise = - withVScrollBars OnRight - . viewport InfoViewport Vertical - . padLeftRight 1 - $ explainFocusedItem s - --- | Display info about the currently focused inventory entity, --- such as its description and relevant recipes. -explainFocusedItem :: AppState -> Widget Name -explainFocusedItem s = case focusedItem s of - Just (InventoryEntry _ e) -> explainEntry s e - Just (EquippedEntry e) -> explainEntry s e - _ -> txt " " - -explainEntry :: AppState -> Entity -> Widget Name -explainEntry s e = - vBox $ - [ displayProperties $ Set.toList (e ^. entityProperties) - , drawMarkdown (e ^. entityDescription) - , explainRecipes s e - ] - <> [drawRobotMachine s False | e ^. entityCapabilities . Lens.contains CDebug] - <> [drawRobotLog s | e ^. entityCapabilities . Lens.contains CLog] - -displayProperties :: [EntityProperty] -> Widget Name -displayProperties = displayList . mapMaybe showProperty - where - showProperty Growable = Just "growing" - showProperty Combustible = Just "combustible" - showProperty Infinite = Just "infinite" - showProperty Liquid = Just "liquid" - showProperty Unwalkable = Just "blocking" - showProperty Opaque = Just "opaque" - -- Most things are portable so we don't show that. - showProperty Portable = 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 - - displayList [] = emptyWidget - displayList ps = - vBox - [ hBox . L.intersperse (txt ", ") . map (withAttr robotAttr . txt) $ ps - , txt " " - ] - -explainRecipes :: AppState -> Entity -> Widget Name -explainRecipes s e - | null recipes = emptyWidget - | otherwise = - vBox - [ padBottom (Pad 1) (hBorderWithLabel (txt "Recipes")) - , padLeftRight 2 - . hCenter - . vBox - $ map (hLimit widthLimit . padBottom (Pad 1) . drawRecipe (Just e) inv) recipes - ] - where - recipes = recipesWith s e - - inv = fromMaybe E.empty $ s ^? gameState . to focusedRobot . _Just . robotInventory - - width (n, ingr) = - length (show n) + 1 + maximum0 (map T.length . T.words $ ingr ^. entityName) - - maxInputWidth = - fromMaybe 0 $ - maximumOf (traverse . recipeInputs . traverse . to width) recipes - maxOutputWidth = - fromMaybe 0 $ - maximumOf (traverse . recipeOutputs . traverse . to width) recipes - 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 - 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 - -- first since the first thing you will want to know when you - -- obtain a new entity is what you can do with it. - -- - -- 2. Recipes where it serves as a catalyst --- for the same reason. - -- - -- 3. Recipes where it is an output --- these should go last, - -- since if you have it, you probably already figured out how - -- to make it. - L.nub $ - concat - [ getRecipes recipesIn - , getRecipes recipesCat - , getRecipes recipesOut - ] - --- | Draw an ASCII art representation of a recipe. For now, the --- weight is not shown. -drawRecipe :: Maybe Entity -> Inventory -> Recipe Entity -> Widget Name -drawRecipe me inv (Recipe ins outs reqs time _weight) = - vBox - -- any requirements (e.g. furnace) go on top. - [ hCenter $ drawReqs reqs - , -- then we draw inputs, a connector, and outputs. - hBox - [ vBox (zipWith drawIn [0 ..] (ins <> times)) - , connector - , vBox (zipWith drawOut [0 ..] outs) - ] - ] - where - -- The connector is either just a horizontal line ───── - -- or, if there are requirements, a horizontal line with - -- a vertical piece coming out of the center, ──┴── . - connector - | null reqs = hLimit 5 hBorder - | otherwise = - hBox - [ hLimit 2 hBorder - , joinableBorder (Edges True False True True) - , hLimit 2 hBorder - ] - inLen = length ins + length times - outLen = length outs - times = [(fromIntegral time, timeE) | time /= 1] - - -- Draw inputs and outputs. - drawIn, drawOut :: Int -> (Count, Entity) -> Widget Name - drawIn i (n, ingr) = - hBox - [ padRight (Pad 1) $ str (show n) -- how many? - , fmtEntityName missing ingr -- name of the input - , padLeft (Pad 1) $ -- a connecting line: ─────┬ - hBorder - <+> ( joinableBorder (Edges (i /= 0) (i /= inLen - 1) True False) -- ...maybe plus vert ext: │ - <=> if i /= inLen - 1 - then vLimit (subtract 1 . length . T.words $ ingr ^. entityName) vBorder - else emptyWidget - ) - ] - where - missing = E.lookup ingr inv < n - - drawOut i (n, ingr) = - hBox - [ padRight (Pad 1) $ - ( joinableBorder (Edges (i /= 0) (i /= outLen - 1) False True) - <=> if i /= outLen - 1 - then vLimit (subtract 1 . length . T.words $ ingr ^. entityName) vBorder - else emptyWidget - ) - <+> hBorder - , fmtEntityName False ingr - , padLeft (Pad 1) $ str (show n) - ] - - -- If it's the focused entity, draw it highlighted. - -- If the robot doesn't have any, draw it in red. - fmtEntityName missing ingr - | Just ingr == me = withAttr highlightAttr $ txtLines nm - | ingr == timeE = withAttr yellowAttr $ txtLines nm - | missing = withAttr invalidFormInputAttr $ txtLines nm - | otherwise = txtLines nm - where - -- Split up multi-word names, one line per word - nm = ingr ^. entityName - txtLines = vBox . map txt . T.words - --- | Ad-hoc entity to represent time - only used in recipe drawing -timeE :: Entity -timeE = mkEntity (defaultEntityDisplay '.') "ticks" mempty [] [] - -drawReqs :: IngredientList Entity -> Widget Name -drawReqs = vBox . map (hCenter . drawReq) - where - drawReq (1, e) = txt $ e ^. entityName - drawReq (n, e) = str (show n) <+> txt " " <+> txt (e ^. entityName) - -indent2 :: WrapSettings -indent2 = defaultWrapSettings {fillStrategy = FillIndent 2} - -drawRobotLog :: AppState -> Widget Name -drawRobotLog s = - vBox - [ padBottom (Pad 1) (hBorderWithLabel (txt "Log")) - , vBox . F.toList . imap drawEntry $ logEntries - ] - where - logEntries = s ^. gameState . to focusedRobot . _Just . robotLog - - rid = s ^? gameState . to focusedRobot . _Just . robotID - n = Seq.length logEntries - - allMe = all me logEntries - me le = case le ^. leSource of - RobotLog _ i _ -> Just i == rid - _ -> False - - drawEntry i e = - (if i == n - 1 && s ^. uiState . uiScrollToEnd then visible else id) $ - drawLogEntry (not allMe) e - --- | 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 - Nothing -> machineLine "no selected robot" - Just r -> - vBox - [ machineLine $ r ^. robotName <> "#" <> r ^. robotID . to tshow - , txt $ r ^. machine . to prettyText - ] - where - tshow = T.pack . show - hLine t = padBottom (Pad 1) (hBorderWithLabel (txt t)) - machineLine r = hLine $ if showName then "Machine [" <> r <> "]" else "Machine" - --- | Draw one log entry with an optional robot name first. -drawLogEntry :: Bool -> LogEntry -> Widget a -drawLogEntry addName e = - withAttr (colorLogs e) . txtWrapWith indent2 $ - if addName then name else t - where - t = e ^. leText - name = - "[" - <> view leName e - <> "] " - <> case e ^. leSource of - RobotLog Said _ _ -> "said " <> quote t - _ -> t - ------------------------------------------------------------- --- REPL panel ------------------------------------------------------------- - --- | Turn the repl prompt into a decorator for the form -replPromptAsWidget :: Text -> REPLPrompt -> Widget Name -replPromptAsWidget _ (CmdPrompt _) = txt "> " -replPromptAsWidget t (SearchPrompt rh) = - case lastEntry t rh of - Nothing -> txt "[nothing found] " - Just lastentry - | T.null t -> txt "[find] " - | otherwise -> txt $ "[found: \"" <> lastentry <> "\"] " - -renderREPLPrompt :: FocusRing Name -> REPLState -> Widget Name -renderREPLPrompt focus theRepl = ps1 <+> replE - where - prompt = theRepl ^. replPromptType - replEditor = theRepl ^. replPromptEditor - color = if theRepl ^. replValid then id else withAttr redAttr - ps1 = replPromptAsWidget (T.concat $ getEditContents replEditor) prompt - replE = - renderEditor - (color . vBox . map txt) - (focusGetCurrent focus `elem` [Nothing, Just (FocusablePanel REPLPanel), Just REPLInput]) - replEditor - --- | Draw the REPL. -drawREPL :: AppState -> Widget Name -drawREPL s = - vBox - [ withLeftPaddedVScrollBars - . viewport REPLViewport Vertical - . vBox - $ [cached REPLHistoryCache (vBox history), currentPrompt] - , vBox mayDebug - ] - where - -- rendered history lines fitting above REPL prompt - history :: [Widget n] - history = map fmt . 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 . uiFocusRing) theRepl - _running -> padRight Max $ txt "..." - theRepl = s ^. uiState . uiREPL - base = s ^. gameState . robotMap . at 0 - fmt (REPLEntry e) = txt $ "> " <> e - fmt (REPLOutput t) = txt t - fmt (REPLError t) = txtWrapWith indent2 {preserveIndentation = True} t - mayDebug = [drawRobotMachine s True | s ^. uiState . uiShowDebug] - ------------------------------------------------------------- --- Utility ------------------------------------------------------------- - --- See https://github.com/jtdaugherty/brick/discussions/484 -withLeftPaddedVScrollBars :: Widget n -> Widget n -withLeftPaddedVScrollBars = - withVScrollBarRenderer (addLeftSpacing verticalScrollbarRenderer) - . withVScrollBars OnRight - where - addLeftSpacing :: VScrollbarRenderer n -> VScrollbarRenderer n - addLeftSpacing r = - r - { scrollbarWidthAllocation = 2 - , renderVScrollbar = hLimit 1 $ renderVScrollbar r - , renderVScrollbarTrough = hLimit 1 $ renderVScrollbarTrough r - } diff --git a/src/Swarm/TUI/View/Achievement.hs b/src/Swarm/TUI/View/Achievement.hs deleted file mode 100644 --- a/src/Swarm/TUI/View/Achievement.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.View.Achievement where - -import Brick -import Brick.Widgets.Border (borderWithLabel) -import Brick.Widgets.Center (hCenter) -import Brick.Widgets.List qualified as BL -import Control.Lens ((^.)) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Time.Format (defaultTimeLocale, formatTime) -import Swarm.Game.Achievement.Attainment -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 - -padAllEvenly :: Int -> Widget Name -> Widget Name -padAllEvenly x w = padTopBottom x $ padLeftRight (2 * x) w - -getCompletionIcon :: Bool -> Widget Name -getCompletionIcon = \case - False -> txt " ○ " - True -> withAttr greenAttr $ txt " ● " - -drawAchievementsMenuUI :: AppState -> BL.List Name CategorizedAchievement -> Widget Name -drawAchievementsMenuUI s l = - vBox - [ hCenter $ padTopBottom 1 $ str "🏆 Achievements 🏆 " - , hCenter $ - hBox - [ hLimitPercent 30 $ - padAll 2 $ - BL.renderList (const $ drawAchievementListItem attainedMap) True l - , hLimitPercent 50 $ - maybe emptyWidget (singleAchievementDetails attainedMap . snd) $ - BL.listSelectedElement l - ] - ] - where - attainedMap = s ^. uiState . uiAchievements - -drawAchievementListItem :: - Map CategorizedAchievement Attainment -> - CategorizedAchievement -> - Widget Name -drawAchievementListItem attainedMap x = - getCompletionIcon wasAttained <+> titleWidget - where - wasAttained = M.member x attainedMap - titleWidget = txtWrap $ title details - details = describe x - -singleAchievementDetails :: - Map CategorizedAchievement Attainment -> - CategorizedAchievement -> - Widget Name -singleAchievementDetails attainedMap x = - padRight (Pad 1) $ borderWithLabel titleWidget $ padAllEvenly 1 innerContent - where - wasAttained = M.member x attainedMap - - renderFlavorTextWidget :: FlavorText -> Widget Name - renderFlavorTextWidget (Freeform t) = drawMarkdown t - renderFlavorTextWidget (FTQuotation (Quotation author quoteContent)) = - vBox - [ txtWrap quoteContent - , padLeft Max - . padRight (Pad 2) - . txtWrapWith (defaultWrapSettings {fillStrategy = FillIndent 2}) - $ "--" <> author - ] - - innerContent = - vBox - [ maybe emptyWidget (padAllEvenly 2 . renderFlavorTextWidget) $ humorousElaboration details - , if wasAttained || not (isObfuscated details) - then drawMarkdown $ attainmentProcess details - else txt "???" - , case M.lookup x attainedMap of - Nothing -> emptyWidget - Just attainment -> - padTop (Pad 1) $ - vBox - [ hBox - [ txt "Obtained: " - , withAttr cyanAttr - . str - . formatTime defaultTimeLocale "%l:%M%P on %b %e, %Y" - $ attainment ^. obtainedAt - ] - , flip (maybe emptyWidget) (attainment ^. maybeScenarioPath) $ \s -> - hBox - [ txt "Scenario: " - , withAttr cyanAttr $ - str s - ] - ] - , padTop (Pad 1) $ - hBox - [ txt "Effort: " - , withAttr boldAttr . str . show $ effort details - ] - ] - - titleWidget = padLeftRight 1 $ txt $ title details - details = describe x diff --git a/src/Swarm/TUI/View/Attribute/Attr.hs b/src/Swarm/TUI/View/Attribute/Attr.hs deleted file mode 100644 --- a/src/Swarm/TUI/View/Attribute/Attr.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Rendering attributes (/i.e./ foreground and background colors, --- styles, /etc./) used by the Swarm TUI. --- --- We export constants only for those we use in the Haskell code --- and not those used in the world map, to avoid abusing attributes. --- For example using the robot attribute to highlight some text. --- --- The few attributes that we use for drawing the logo are an exception. -module Swarm.TUI.View.Attribute.Attr ( - swarmAttrMap, - worldAttributeNames, - worldPrefix, - meterAttributeNames, - toAttrName, - - -- ** Terrain attributes - dirtAttr, - grassAttr, - stoneAttr, - waterAttr, - iceAttr, - - -- ** Common attributes - entityAttr, - robotAttr, - rockAttr, - plantAttr, - - -- ** Swarm TUI Attributes - highlightAttr, - notifAttr, - infoAttr, - boldAttr, - italicAttr, - dimAttr, - magentaAttr, - cyanAttr, - lightCyanAttr, - yellowAttr, - blueAttr, - greenAttr, - redAttr, - defAttr, - customEditFocusedAttr, -) where - -import Brick -import Brick.Forms -import Brick.Widgets.Dialog -import Brick.Widgets.Edit qualified as E -import Brick.Widgets.List hiding (reverse) -import Data.Bifunctor (bimap, first) -import Data.Colour.Palette.BrewerSet -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NE -import Data.Maybe (fromMaybe) -import Data.Text (unpack) -import Graphics.Vty qualified as V -import Swarm.Game.Display (Attribute (..)) -import Swarm.TUI.View.Attribute.Util - -toAttrName :: Attribute -> AttrName -toAttrName = \case - ARobot -> robotAttr - AEntity -> entityAttr - AWorld n -> worldPrefix <> attrName (unpack n) - ATerrain n -> terrainPrefix <> attrName (unpack n) - ADefault -> defAttr - --- | A mapping from the defined attribute names to TUI attributes. -swarmAttrMap :: AttrMap -swarmAttrMap = - attrMap - V.defAttr - $ NE.toList activityMeterAttributes - <> NE.toList (NE.map (first getWorldAttrName) worldAttributes) - <> [(waterAttr, V.white `on` V.blue)] - <> terrainAttr - <> [ -- Robot attribute - (robotAttr, fg V.white `V.withStyle` V.bold) - , -- UI rendering attributes - (highlightAttr, fg V.cyan) - , (invalidFormInputAttr, fg V.red) - , (focusedFormInputAttr, V.defAttr) - , (customEditFocusedAttr, V.black `on` V.yellow) - , (listSelectedFocusedAttr, bg V.blue) - , (infoAttr, fg (V.rgbColor @Int 100 100 100)) - , (buttonSelectedAttr, bg V.blue) - , (notifAttr, fg V.yellow `V.withStyle` V.bold) - , (dimAttr, V.defAttr `V.withStyle` V.dim) - , (boldAttr, V.defAttr `V.withStyle` V.bold) - , (italicAttr, V.defAttr `V.withStyle` V.italic) - , -- Basic colors - (redAttr, fg V.red) - , (greenAttr, fg V.green) - , (blueAttr, fg V.blue) - , (yellowAttr, fg V.yellow) - , (cyanAttr, fg V.cyan) - , (lightCyanAttr, fg (V.rgbColor @Int 200 255 255)) - , (magentaAttr, fg V.magenta) - , -- Default attribute - (defAttr, V.defAttr) - ] - -worldPrefix :: AttrName -worldPrefix = attrName "world" - --- | We introduce this (module-private) newtype --- so that we can define the 'entity' attribute --- separate from the list of other 'worldAttributes', --- while enforcing the convention that both its attribute --- name and the rest of 'worldAttributes' be consistently --- prefixed by 'worldPrefix'. -newtype WorldAttr = WorldAttr - { getWorldAttrName :: AttrName - } - -mkWorldAttr :: String -> WorldAttr -mkWorldAttr = WorldAttr . (worldPrefix <>) . attrName - -entity :: (WorldAttr, V.Attr) -entity = (mkWorldAttr "entity", fg V.white) - -entityAttr :: AttrName -entityAttr = getWorldAttrName $ fst entity - --- | Colors of entities in the world. --- --- Also used to color messages, so water is special and excluded. -worldAttributes :: NonEmpty (WorldAttr, V.Attr) -worldAttributes = - entity - :| map - (bimap mkWorldAttr fg) - [ ("device", V.brightYellow) - , ("plant", V.green) - , ("rock", V.rgbColor @Int 80 80 80) - , ("wood", V.rgbColor @Int 139 69 19) - , ("flower", V.rgbColor @Int 200 0 200) - , ("rubber", V.rgbColor @Int 245 224 179) - , ("copper", V.yellow) - , ("copper'", V.rgbColor @Int 78 117 102) - , ("iron", V.rgbColor @Int 97 102 106) - , ("iron'", V.rgbColor @Int 183 65 14) - , ("quartz", V.white) - , ("silver", V.rgbColor @Int 192 192 192) - , ("gold", V.rgbColor @Int 255 215 0) - , ("snow", V.white) - , ("sand", V.rgbColor @Int 194 178 128) - , ("fire", V.brightRed) - , ("red", V.red) - , ("green", V.green) - , ("blue", V.blue) - ] - -worldAttributeNames :: NonEmpty AttrName -worldAttributeNames = NE.map (getWorldAttrName . fst) worldAttributes - -activityMeterPrefix :: AttrName -activityMeterPrefix = attrName "activityMeter" - -activityMeterAttributes :: NonEmpty (AttrName, V.Attr) -activityMeterAttributes = - NE.zip indices $ fromMaybe (pure $ bg V.black) $ NE.nonEmpty brewers - where - indices = NE.map ((activityMeterPrefix <>) . attrName . show) $ (0 :: Int) :| [1 ..] - brewers = map bgWithAutoForeground $ reverse $ brewerSet RdYlGn 7 - -meterAttributeNames :: NonEmpty AttrName -meterAttributeNames = NE.map fst activityMeterAttributes - -terrainPrefix :: AttrName -terrainPrefix = attrName "terrain" - -terrainAttr :: [(AttrName, V.Attr)] -terrainAttr = - [ (dirtAttr, fg (V.rgbColor @Int 165 42 42)) - , (grassAttr, fg (V.rgbColor @Int 0 32 0)) -- dark green - , (stoneAttr, fg (V.rgbColor @Int 32 32 32)) - , (iceAttr, bg V.white) - ] - --- | The default robot attribute. -robotAttr :: AttrName -robotAttr = attrName "robot" - -dirtAttr, grassAttr, stoneAttr, iceAttr, waterAttr, rockAttr, plantAttr :: AttrName -dirtAttr = terrainPrefix <> attrName "dirt" -grassAttr = terrainPrefix <> attrName "grass" -stoneAttr = terrainPrefix <> attrName "stone" -iceAttr = terrainPrefix <> attrName "ice" -waterAttr = worldPrefix <> attrName "water" -rockAttr = worldPrefix <> attrName "rock" -plantAttr = worldPrefix <> attrName "plant" - --- | Some defined attribute names used in the Swarm TUI. -highlightAttr - , notifAttr - , infoAttr - , boldAttr - , italicAttr - , dimAttr - , defAttr :: - AttrName -highlightAttr = attrName "highlight" -notifAttr = attrName "notif" -infoAttr = attrName "info" -boldAttr = attrName "bold" -italicAttr = attrName "italics" -dimAttr = attrName "dim" -defAttr = attrName "def" - -customEditFocusedAttr :: AttrName -customEditFocusedAttr = attrName "custom" <> E.editFocusedAttr - --- | Some basic colors used in TUI. -redAttr, greenAttr, blueAttr, yellowAttr, cyanAttr, lightCyanAttr, magentaAttr :: AttrName -redAttr = attrName "red" -greenAttr = attrName "green" -blueAttr = attrName "blue" -yellowAttr = attrName "yellow" -cyanAttr = attrName "cyan" -lightCyanAttr = attrName "lightCyan" -magentaAttr = attrName "magenta" diff --git a/src/Swarm/TUI/View/Attribute/CustomStyling.hs b/src/Swarm/TUI/View/Attribute/CustomStyling.hs deleted file mode 100644 --- a/src/Swarm/TUI/View/Attribute/CustomStyling.hs +++ /dev/null @@ -1,37 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.View.Attribute.CustomStyling where - -import Brick (AttrName, attrName) -import Data.Colour.SRGB (sRGB24read) -import Data.Set (toList) -import Data.Text qualified as T -import Graphics.Vty.Attributes -import Swarm.Game.Scenario.Style -import Swarm.TUI.View.Attribute.Attr (worldPrefix) -import Swarm.TUI.View.Attribute.Util - -toStyle :: StyleFlag -> Style -toStyle = \case - Standout -> standout - Italic -> italic - Strikethrough -> strikethrough - Underline -> underline - ReverseVideo -> reverseVideo - Blink -> blink - Dim -> dim - Bold -> bold - -hexToAttrColor :: HexColor -> Color -hexToAttrColor (HexColor colorText) = - kolorToAttrColor c - where - c = sRGB24read $ T.unpack colorText - -toAttrPair :: CustomAttr -> (AttrName, Attr) -toAttrPair ca = - (worldPrefix <> attrName (name ca), addStyle $ addFg $ addBg defAttr) - where - addFg = maybe id (flip withForeColor . hexToAttrColor) $ fg ca - addBg = maybe id (flip withBackColor . hexToAttrColor) $ bg ca - addStyle = maybe id (flip withStyle . sum . map toStyle . toList) $ style ca diff --git a/src/Swarm/TUI/View/Attribute/Util.hs b/src/Swarm/TUI/View/Attribute/Util.hs deleted file mode 100644 --- a/src/Swarm/TUI/View/Attribute/Util.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.View.Attribute.Util where - -import Brick.Util (on) -import Data.Colour.CIE (luminance) -import Data.Colour.Palette.BrewerSet (Kolor) -import Data.Colour.SRGB (RGB (..), toSRGB24) -import Graphics.Vty qualified as V -import Graphics.Vty.Attributes - -kolorToAttrColor :: Kolor -> Color -kolorToAttrColor c = - RGBColor r g b - where - RGB r g b = toSRGB24 c - --- | Automatically selects black or white for the foreground --- based on the luminance of the supplied background. -bgWithAutoForeground :: Kolor -> Attr -bgWithAutoForeground c = fgColor `on` kolorToAttrColor c - where - fgColor = - -- "white" is actually gray-ish, so we nudge the threshold - -- below 0.5. - if luminance c > 0.4 - then V.black - else V.white diff --git a/src/Swarm/TUI/View/CellDisplay.hs b/src/Swarm/TUI/View/CellDisplay.hs deleted file mode 100644 --- a/src/Swarm/TUI/View/CellDisplay.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Rendering of cells in the map view --- --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.View.CellDisplay where - -import Brick -import Control.Lens (to, view, (&), (.~), (^.)) -import Data.ByteString (ByteString) -import Data.Hash.Murmur -import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M -import Data.Maybe (maybeToList) -import Data.Semigroup (sconcat) -import Data.Tagged (unTagged) -import Data.Text (Text) -import Data.Word (Word32) -import Linear.Affine ((.-.)) -import Swarm.Game.CESK (TickNumber (..)) -import Swarm.Game.Display ( - Attribute (AEntity), - Display, - defaultEntityDisplay, - displayAttr, - displayChar, - displayPriority, - hidden, - ) -import Swarm.Game.Entity -import Swarm.Game.Robot -import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.State -import Swarm.Game.Terrain -import Swarm.Game.Universe -import Swarm.Game.World qualified as W -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.View.Attribute.Attr -import Witch (from) -import Witch.Encoding qualified as Encoding - --- | Render a display as a UI widget. -renderDisplay :: Display -> Widget n -renderDisplay disp = withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp] - --- | Render the 'Display' for a specific location. -drawLoc :: UIState -> GameState -> Cosmic W.Coords -> Widget Name -drawLoc ui g cCoords@(Cosmic _ coords) = - if shouldHideWorldCell ui coords - then str " " - else drawCell - where - showRobots = ui ^. uiShowRobots - we = ui ^. uiWorldEditor . worldOverdraw - drawCell = renderDisplay $ displayLoc showRobots we g cCoords - --- | Subset of the game state needed to render the world -data RenderingInput = RenderingInput - { multiworldInfo :: W.MultiWorld Int Entity - , isKnownFunc :: EntityPaint -> Bool - } - -displayTerrainCell :: - WorldOverdraw -> - RenderingInput -> - Cosmic W.Coords -> - Display -displayTerrainCell worldEditor ri coords = - terrainMap M.! EU.getEditorTerrainAt worldEditor (multiworldInfo ri) coords - -displayRobotCell :: - GameState -> - Cosmic W.Coords -> - [Display] -displayRobotCell g coords = - map (view robotDisplay) $ - robotsAtLocation (fmap W.coordsToLoc coords) g - --- | Extract the relevant subset of information from the 'GameState' to be able --- to compute whether an entity is "known". -mkEntityKnowledge :: GameState -> EntityKnowledgeDependencies -mkEntityKnowledge gs = - EntityKnowledgeDependencies - { isCreativeMode = gs ^. creativeMode - , globallyKnownEntities = gs ^. discovery . knownEntities - , theFocusedRobot = focusedRobot gs - } - --- | The subset of information required to compute whether --- an entity is "known", and therefore should be rendered --- normally vs as a question mark. -data EntityKnowledgeDependencies = EntityKnowledgeDependencies - { isCreativeMode :: Bool - , globallyKnownEntities :: [Text] - , theFocusedRobot :: Maybe Robot - } - --- | Determines whether an entity should be rendered --- normally vs as a question mark. -getEntityIsKnown :: EntityKnowledgeDependencies -> EntityPaint -> Bool -getEntityIsKnown knowledge ep = case ep of - Facade (EntityFacade _ _) -> True - Ref e -> or reasonsToShow - where - reasonsToShow = - [ isCreativeMode knowledge - , e `hasProperty` Known - , (e ^. entityName) `elem` globallyKnownEntities knowledge - , showBasedOnRobotKnowledge - ] - showBasedOnRobotKnowledge = maybe False (`robotKnows` e) $ theFocusedRobot knowledge - -displayEntityCell :: - WorldOverdraw -> - RenderingInput -> - Cosmic W.Coords -> - [Display] -displayEntityCell worldEditor ri coords = - maybeToList $ displayForEntity <$> maybeEntity - where - (_, maybeEntity) = EU.getEditorContentAt worldEditor (multiworldInfo ri) coords - - displayForEntity :: EntityPaint -> Display - displayForEntity e = (if isKnownFunc ri e then id else 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 --- taking into account "static" based on the distance to the robot --- being @view@ed. -displayLoc :: Bool -> WorldOverdraw -> GameState -> Cosmic W.Coords -> Display -displayLoc showRobots we g cCoords@(Cosmic _ coords) = - staticDisplay g coords - <> displayLocRaw we ri robots cCoords - where - ri = RenderingInput (g ^. landscape . multiWorld) (getEntityIsKnown $ mkEntityKnowledge g) - robots = - if showRobots - then displayRobotCell g cCoords - else [] - --- | Get the 'Display' for a specific location, by combining the --- 'Display's for the terrain, entity, and robots at the location. -displayLocRaw :: - WorldOverdraw -> - RenderingInput -> - -- | Robot displays - [Display] -> - Cosmic W.Coords -> - Display -displayLocRaw worldEditor ri robotDisplays coords = - sconcat $ terrain NE.:| entity <> robotDisplays - where - terrain = displayTerrainCell worldEditor ri coords - entity = displayEntityCell worldEditor ri coords - --- | Random "static" based on the distance to the robot being --- @view@ed. -staticDisplay :: GameState -> W.Coords -> Display -staticDisplay g coords = maybe mempty displayStatic (getStatic g coords) - --- | Draw static given a number from 0-15 representing the state of --- the four quarter-pixels in a cell -displayStatic :: Word32 -> Display -displayStatic s = - defaultEntityDisplay (staticChar s) - & displayPriority .~ maxBound -- Static has higher priority than anything else - & displayAttr .~ AEntity - --- | Given a value from 0--15, considered as 4 bits, pick the --- character with the corresponding quarter pixels turned on. -staticChar :: Word32 -> Char -staticChar = \case - 0 -> ' ' - 1 -> '▖' - 2 -> '▗' - 3 -> '▄' - 4 -> '▘' - 5 -> '▌' - 6 -> '▚' - 7 -> '▙' - 8 -> '▝' - 9 -> '▞' - 10 -> '▐' - 11 -> '▟' - 12 -> '▀' - 13 -> '▛' - 14 -> '▜' - 15 -> '█' - _ -> ' ' - --- | Random "static" based on the distance to the robot being --- @view@ed. A cell can either be static-free (represented by --- @Nothing@) or can have one of sixteen values (representing the --- state of the four quarter-pixels in one cell). -getStatic :: GameState -> W.Coords -> Maybe Word32 -getStatic g coords - | isStatic = Just (h `mod` 16) - | otherwise = Nothing - where - -- Offset from the location of the view center to the location under - -- consideration for display. - offset = W.coordsToLoc coords .-. (g ^. viewCenter . planar) - - -- Hash. - h = - murmur3 1 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ - -- include the current tick count / 16 in the hash, so the pattern of static - -- changes once every 16 ticks - (offset, getTickNumber (g ^. temporal . ticks) `div` 16) - - -- Hashed probability, i.e. convert the hash into a floating-point number between 0 and 1 - hp :: Double - hp = fromIntegral h / fromIntegral (maxBound :: Word32) - - isStatic = case focusedRange g of - -- If we're not viewing a robot, display static. This - -- can happen if e.g. the robot we were viewing drowned. - -- This is overridden by creative mode, e.g. when no robots - -- have been defined for the scenario. - Nothing -> not $ g ^. creativeMode - -- Don't display static if the robot is close, or when we're in - -- creative mode or the player is allowed to scroll the world. - Just Close -> False - -- At medium distances, replace cell with static with a - -- probability that increases with distance. - Just (MidRange s) -> hp < 1 - cos (s * (pi / 2)) - -- Far away, everything is static. - Just Far -> True diff --git a/src/Swarm/TUI/View/Objective.hs b/src/Swarm/TUI/View/Objective.hs deleted file mode 100644 --- a/src/Swarm/TUI/View/Objective.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Display logic for Objectives. -module Swarm.TUI.View.Objective where - -import Brick hiding (Direction, Location) -import Brick.Focus -import Brick.Widgets.Center -import Brick.Widgets.List qualified as BL -import Control.Applicative ((<|>)) -import Control.Lens hiding (Const, from) -import Data.List (intercalate) -import Data.List.NonEmpty qualified as NE -import Data.Map.Strict qualified as M -import Data.Vector qualified as V -import Swarm.Game.Scenario.Objective -import Swarm.Language.Text.Markdown qualified as Markdown -import Swarm.TUI.Model.Goal -import Swarm.TUI.Model.Name -import Swarm.TUI.View.Attribute.Attr -import Swarm.TUI.View.Util - -makeListWidget :: GoalTracking -> BL.List Name GoalEntry -makeListWidget (GoalTracking _announcements categorizedObjs) = - BL.listMoveTo 1 $ BL.list (GoalWidgets ObjectivesList) (V.fromList objList) 1 - where - objList = intercalate [Spacer] $ map f $ M.toList categorizedObjs - f (h, xs) = Header h : map (Goal h) (NE.toList xs) - -renderGoalsDisplay :: GoalDisplay -> Widget Name -renderGoalsDisplay gd = - if hasMultiple - then - vBox - [ hBox - [ leftSide - , hLimitPercent 70 $ padLeft (Pad 2) goalElaboration - ] - , footer - ] - else goalElaboration - where - footer = hCenter $ withAttr italicAttr $ txt "NOTE: [Tab] toggles focus between panes" - hasMultiple = hasMultipleGoals $ gd ^. goalsContent - lw = _listWidget gd - fr = _focus gd - leftSide = - hLimitPercent 30 $ - padAll 1 $ - vBox - [ hCenter $ str "Goals" - , padAll 1 $ - vLimit 10 $ - withFocusRing fr (BL.renderList drawGoalListItem) lw - ] - - -- Adds very subtle coloring to indicate focus switch - highlightIfFocused = case (hasMultiple, focusGetCurrent fr) of - (True, Just (GoalWidgets GoalSummary)) -> withAttr lightCyanAttr - _ -> id - - -- Note: An extra "padRight" is inserted to account for the vertical scrollbar, - -- whether or not it appears. - goalElaboration = - clickable (GoalWidgets GoalSummary) - . maybeScroll ModalViewport - . maybe emptyWidget (padAll 1 . padRight (Pad 1) . highlightIfFocused . singleGoalDetails . snd) - $ BL.listSelectedElement lw - -getCompletionIcon :: Objective -> GoalStatus -> Widget Name -getCompletionIcon obj = \case - Upcoming -> withAttr yellowAttr $ txt " ○ " - Active -> withAttr cyanAttr $ txt " ○ " - Failed -> withAttr redAttr $ txt " ● " - Completed -> withAttr colorAttr $ txt " ● " - where - colorAttr = - if obj ^. objectiveHidden - then magentaAttr - else greenAttr - -drawGoalListItem :: - Bool -> - GoalEntry -> - Widget Name -drawGoalListItem _isSelected e = case e of - Spacer -> str " " - Header gs -> withAttr boldAttr $ str $ show gs - Goal gs obj -> getCompletionIcon obj gs <+> titleWidget - where - textSource = obj ^. objectiveTeaser <|> obj ^. objectiveId <|> Just (Markdown.docToText $ obj ^. objectiveGoal) - titleWidget = maybe (txt "?") (withEllipsis End) textSource - -singleGoalDetails :: GoalEntry -> Widget Name -singleGoalDetails = \case - Goal _gs obj -> drawMarkdown $ obj ^. objectiveGoal - -- Only Goal entries are selectable, so we should never see this: - _ -> emptyWidget diff --git a/src/Swarm/TUI/View/Util.hs b/src/Swarm/TUI/View/Util.hs deleted file mode 100644 --- a/src/Swarm/TUI/View/Util.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause -module Swarm.TUI.View.Util where - -import Brick hiding (Direction, Location) -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.Map.Strict qualified as M -import Data.Maybe (catMaybes, fromMaybe) -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.Location -import Swarm.Game.Scenario (scenarioName) -import Swarm.Game.ScenarioInfo (scenarioItemName) -import Swarm.Game.State -import Swarm.Game.Terrain -import Swarm.Language.Pretty (prettyText) -import Swarm.Language.Syntax (Syntax) -import Swarm.Language.Text.Markdown qualified as Markdown -import Swarm.Language.Types (Polytype) -import Swarm.TUI.Model -import Swarm.TUI.Model.UI -import Swarm.TUI.View.Attribute.Attr -import Swarm.TUI.View.CellDisplay -import Swarm.Util (listEnums) -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)) - where - currentScenario = s ^. uiState . scenarioRef - currentSeed = s ^. gameState . seed - haltingMessage = case s ^. uiState . uiMenu of - NoMenu -> Just "Quit" - _ -> Nothing - descriptionWidth = 100 - helpWidth = 80 - (title, buttons, requiredWidth) = - case mt of - HelpModal -> (" Help ", Nothing, helpWidth) - RobotsModal -> ("Robots", Nothing, descriptionWidth) - RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) - CommandsModal -> ("Available Commands", Nothing, descriptionWidth) - MessagesModal -> ("Messages", 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 ^. scenarioName - in (" " <> T.unpack goalModalTitle <> " ", Nothing, descriptionWidth) - KeepPlayingModal -> ("", Just (Button CancelButton, [("OK", Button CancelButton, Cancel)]), 80) - TerrainPaletteModal -> ("Terrain", Nothing, w) - where - wordLength = maximum $ map (length . show) (listEnums :: [TerrainType]) - w = wordLength + 6 - EntityPaletteModal -> ("Entity", Nothing, 30) - --- | Render the type of the current REPL input to be shown to the user. -drawType :: Polytype -> Widget Name -drawType = withAttr infoAttr . padLeftRight 1 . txt . prettyText - --- | Draw markdown document with simple code/bold/italic attributes. --- --- TODO: #574 Code blocks should probably be handled separately. -drawMarkdown :: Markdown.Document Syntax -> Widget Name -drawMarkdown d = do - Widget Greedy Fixed $ do - ctx <- getContext - let w = ctx ^. availWidthL - let docLines = Markdown.chunksOf w . Markdown.toStream <$> Markdown.paragraphs d - render . layoutParagraphs $ vBox . map (hBox . map mTxt) <$> docLines - where - mTxt = \case - Markdown.TextNode as t -> foldr applyAttr (txt t) as - Markdown.CodeNode t -> withAttr highlightAttr $ txt t - Markdown.RawNode f t -> withAttr (rawAttr f) $ txt t - applyAttr a = withAttr $ case a of - Markdown.Strong -> boldAttr - Markdown.Emphasis -> italicAttr - rawAttr = \case - "entity" -> greenAttr - "type" -> magentaAttr - _snippet -> highlightAttr -- same as plain code - -drawLabeledTerrainSwatch :: TerrainType -> Widget Name -drawLabeledTerrainSwatch a = - tile <+> str materialName - where - tile = padRight (Pad 1) $ renderDisplay $ terrainMap M.! a - materialName = init $ show a - -descriptionTitle :: Entity -> String -descriptionTitle e = " " ++ from @Text (e ^. entityName) ++ " " - --- | Width cap for modal and error message windows -maxModalWindowWidth :: Int -maxModalWindowWidth = 500 - --- | Get the name of the current New Game menu. -curMenuName :: AppState -> Maybe Text -curMenuName s = case s ^. uiState . uiMenu of - NewGameMenu (_ :| (parentMenu : _)) -> - Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName) - NewGameMenu _ -> Just "Scenarios" - _ -> Nothing - -quitMsg :: Menu -> Text -quitMsg m = "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] - --- | Display a list of text-wrapped paragraphs with one blank line after each. -displayParagraphs :: [Text] -> Widget Name -displayParagraphs = layoutParagraphs . map txtWrap - --- | Display a list of paragraphs with one blank line after each. --- --- For the common case of `[Text]` use 'displayParagraphs'. -layoutParagraphs :: [Widget Name] -> Widget Name -layoutParagraphs ps = vBox $ padBottom (Pad 1) <$> ps - -data EllipsisSide = Beginning | End - -withEllipsis :: EllipsisSide -> Text -> Widget Name -withEllipsis side t = - Widget Greedy Fixed $ do - ctx <- getContext - let w = ctx ^. availWidthL - ellipsis = T.replicate 3 $ T.singleton '.' - tLength = T.length t - newText = - if tLength > w - then case side of - Beginning -> ellipsis <> T.drop (w - T.length ellipsis) t - End -> T.take (w - T.length ellipsis) t <> ellipsis - else t - render $ txt newText - --- | Make a widget scrolling if it is bigger than the available --- vertical space. Thanks to jtdaugherty for this code. -maybeScroll :: (Ord n, Show n) => n -> Widget n -> Widget n -maybeScroll vpName contents = - Widget Greedy Greedy $ do - ctx <- getContext - result <- withReaderT (availHeightL .~ 10000) (render contents) - if V.imageHeight (result ^. imageL) <= ctx ^. availHeightL - then return result - else - render - . withVScrollBars OnRight - . viewport vpName Vertical - . Widget Fixed Fixed - $ return result diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs deleted file mode 100644 --- a/src/Swarm/Util.hs +++ /dev/null @@ -1,556 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A random collection of small, useful functions that are (or could --- be) used throughout the code base. -module Swarm.Util ( - -- * Miscellaneous utilities - (?), - sortPair, - maxOn, - maximum0, - cycleEnum, - listEnums, - listEnumsNonempty, - showEnum, - indexWrapNonEmpty, - uniq, - binTuples, - histogram, - findDup, - both, - allEqual, - surfaceEmpty, - applyWhen, - hoistMaybe, - unsnocNE, - - -- * Directory utilities - readFileMay, - readFileMayT, - acquireAllWithExt, - - -- * Text utilities - isIdentChar, - replaceLast, - failT, - showT, - showLowT, - - -- * English language utilities - reflow, - quote, - squote, - bquote, - parens, - brackets, - commaList, - indefinite, - indefiniteQ, - singularSubjectVerb, - plural, - number, - - -- * Validation utilities - holdsOr, - isJustOr, - isRightOr, - isSuccessOr, - - -- * Template Haskell utilities - liftText, - - -- * Lens utilities - (%%=), - (<%=), - (<+=), - (<<.=), - (<>=), - _NonEmpty, - - -- * Set utilities - removeSupersets, - 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.Trans.Maybe (MaybeT (..)) -import Data.Bifunctor (Bifunctor (bimap), first) -import Data.Char (isAlphaNum, toLower) -import Data.Either.Validation -import Data.List (foldl', maximumBy, partition) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) -import Data.Set (Set) -import Data.Set qualified as S -import Data.Text (Text, toUpper) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import Data.Tuple (swap) -import Data.Yaml -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (lift) -import NLP.Minimorph.English qualified as MM -import NLP.Minimorph.Util ((<+>)) -import System.Clock (TimeSpec) -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) -import System.FilePath (takeExtension, ()) -import System.IO.Error (catchIOError) -import Witch (from) - -infixr 1 ? -infix 4 %%=, <+=, <%=, <<.=, <>= - --- | A convenient infix flipped version of 'fromMaybe': @Just a ? b = --- a@, and @Nothing ? b = b@. It can also be chained, as in @x ? y ? --- z ? def@, which takes the value inside the first @Just@, --- defaulting to @def@ as a last resort. -(?) :: Maybe a -> a -> a -(?) = flip fromMaybe - --- | Ensure the smaller value in a pair is the first element. -sortPair :: Ord b => (b, b) -> (b, b) -sortPair (x, y) = if x <= y then (x, y) else (y, x) - --- | Find the maximum of two values, comparing them according to a --- custom projection function. -maxOn :: Ord b => (a -> b) -> a -> a -> a -maxOn f x y - | f x > f y = x - | otherwise = y - --- | Find the maximum of a list of numbers, defaulting to 0 if the --- list is empty. -maximum0 :: (Num a, Ord a) => [a] -> a -maximum0 [] = 0 -maximum0 xs = maximum xs - --- | Take the successor of an 'Enum' type, wrapping around when it --- reaches the end. -cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e -cycleEnum e - | e == maxBound = minBound - | otherwise = succ e - -listEnums :: (Enum e, Bounded e) => [e] -listEnums = [minBound .. maxBound] - --- | Members of the Bounded class are guaranteed to --- have at least one element. -listEnumsNonempty :: (Enum e, Bounded e) => NonEmpty e -listEnumsNonempty = NE.fromList listEnums - --- | We know by the syntax rules of Haskell that constructor --- names must consist of one or more symbols! -showEnum :: (Show e, Enum e) => e -> NonEmpty Char -showEnum = NE.fromList . show - --- | Guaranteed to yield an element of the list. --- --- This is true even if the supplied @index@ is negative, --- since 'mod' always satisfies @0 <= a `mod` b < b@ --- when @b@ is positive --- (see ). -indexWrapNonEmpty :: - Integral b => - NonEmpty a -> - -- | index - b -> - a -indexWrapNonEmpty list idx = - NE.toList list !! fromIntegral wrappedIdx - where - wrappedIdx = idx `mod` fromIntegral (NE.length list) - --- | Drop repeated elements that are adjacent to each other. --- --- >>> uniq [] --- [] --- >>> uniq [1..5] --- [1,2,3,4,5] --- >>> uniq (replicate 10 'a') --- "a" --- >>> uniq "abbbccd" --- "abcd" -uniq :: Eq a => [a] -> [a] -uniq = \case - [] -> [] - (x : xs) -> x : uniq (dropWhile (== x) xs) - --- | Place the second element of the tuples into bins by --- the value of the first element. -binTuples :: - (Foldable t, Ord a) => - t (a, b) -> - Map a (NE.NonEmpty b) -binTuples = foldr f mempty - where - f = uncurry (M.insertWith (<>)) . fmap pure - --- | Count occurrences of a value -histogram :: - (Foldable t, Ord a) => - t a -> - Map a Int -histogram = foldl' (\m k -> M.insertWith (+) k 1 m) M.empty - --- | Find a duplicate element within the list, if any exists. -findDup :: Ord a => [a] -> Maybe a -findDup = go S.empty - where - go _ [] = Nothing - go seen (a : as) - | a `S.member` seen = Just a - | otherwise = go (S.insert a seen) as - -both :: Bifunctor p => (a -> d) -> p a a -> p d d -both f = bimap f f - -allEqual :: (Ord a) => [a] -> Bool -allEqual [] = True -allEqual (x : xs) = all (== x) xs - -surfaceEmpty :: Alternative f => (a -> Bool) -> a -> f a -surfaceEmpty isEmpty t = t <$ guard (not (isEmpty t)) - ------------------------------------------------------------- --- Forward-compatibility functions - --- Note, once we upgrade to an LTS version that includes --- base-compat-0.13, we should switch to using 'applyWhen' from there. -applyWhen :: Bool -> (a -> a) -> a -> a -applyWhen True f x = f x -applyWhen False _ x = x - --- | Convert a 'Maybe' computation to 'MaybeT'. --- --- TODO (#1151): Use implementation from "transformers" package v0.6.0.0 -hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b -hoistMaybe = MaybeT . pure - --- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' --- --- Taken from Cabal-syntax Distribution.Utils.Generic. --- --- Example: --- >>> import Data.List.NonEmpty (NonEmpty ((:|))) --- >>> unsnocNE (1 :| [2, 3]) --- ([1,2],3) --- --- >>> unsnocNE (1 :| []) --- ([],1) -unsnocNE :: NonEmpty a -> ([a], a) -unsnocNE (x :| xs) = go x xs - where - go y [] = ([], y) - go y (z : zs) = let ~(ws, w) = go z zs in (y : ws, w) - ------------------------------------------------------------- --- Directory stuff - --- | Safely attempt to read a file. -readFileMay :: FilePath -> IO (Maybe String) -readFileMay = catchIO . readFile - --- | Safely attempt to (efficiently) read a file. -readFileMayT :: FilePath -> IO (Maybe Text) -readFileMayT = catchIO . T.readFile - --- | Recursively acquire all files in the given directory with the --- given extension, and their contents. -acquireAllWithExt :: FilePath -> String -> IO [(FilePath, String)] -acquireAllWithExt dir ext = do - paths <- listDirectory dir <&> map (dir ) - filePaths <- filterM (\path -> doesFileExist path <&> (&&) (hasExt path)) paths - children <- mapM (\path -> (,) path <$> readFile path) filePaths - -- recurse - sub <- filterM doesDirectoryExist paths - transChildren <- concat <$> mapM (`acquireAllWithExt` ext) sub - return $ children <> transChildren - where - hasExt path = takeExtension path == ("." ++ ext) - --- | Turns any IO error into Nothing. -catchIO :: IO a -> IO (Maybe a) -catchIO act = (Just <$> act) `catchIOError` (\_ -> return Nothing) - ------------------------------------------------------------- --- Some Text-y stuff - --- | Predicate to test for characters which can be part of a valid --- identifier: alphanumeric, underscore, or single quote. --- --- >>> isIdentChar 'A' && isIdentChar 'b' && isIdentChar '9' --- True --- >>> isIdentChar '_' && isIdentChar '\'' --- True --- >>> isIdentChar '$' || isIdentChar '.' || isIdentChar ' ' --- False -isIdentChar :: Char -> Bool -isIdentChar c = isAlphaNum c || c == '_' || c == '\'' - --- | @replaceLast r t@ replaces the last word of @t@ with @r@. --- --- >>> :set -XOverloadedStrings --- >>> replaceLast "foo" "bar baz quux" --- "bar baz foo" --- >>> replaceLast "move" "(make" --- "(move" -replaceLast :: Text -> Text -> Text -replaceLast r t = T.append (T.dropWhileEnd isIdentChar t) r - --- | Fail with a Text-based message, made out of phrases to be joined --- by spaces. -failT :: MonadFail m => [Text] -> m a -failT = fail . from @Text . T.unwords - --- | Show a value, but as Text. -showT :: Show a => a -> Text -showT = from @String . show - --- | Show a value in all lowercase, but as Text. -showLowT :: Show a => a -> Text -showLowT = from @String . map toLower . show - ------------------------------------------------------------- --- Some language-y stuff - --- | Reflow text by removing newlines and condensing whitespace. -reflow :: Text -> Text -reflow = T.unwords . T.words - --- | Prepend a noun with the proper indefinite article (\"a\" or \"an\"). -indefinite :: Text -> Text -indefinite w = MM.indefiniteDet w <+> w - --- | Prepend a noun with the proper indefinite article, and surround --- the noun in single quotes. -indefiniteQ :: Text -> Text -indefiniteQ w = MM.indefiniteDet w <+> squote w - --- | Combine the subject word with the simple present tense of the verb. --- --- Only some irregular verbs are handled, but it should be enough --- to scrap some error message boilerplate and have fun! --- --- >>> :set -XOverloadedStrings --- >>> singularSubjectVerb "I" "be" --- "I am" --- >>> singularSubjectVerb "he" "can" --- "he can" --- >>> singularSubjectVerb "The target robot" "do" --- "The target robot does" -singularSubjectVerb :: Text -> Text -> Text -singularSubjectVerb sub verb - | verb == "be" = case toUpper sub of - "I" -> "I am" - "YOU" -> sub <+> "are" - _ -> sub <+> "is" - | otherwise = sub <+> (if is3rdPerson then verb3rd else verb) - where - is3rdPerson = toUpper sub `notElem` ["I", "YOU"] - verb3rd - | verb == "have" = "has" - | verb == "can" = "can" - | otherwise = fst $ MM.defaultVerbStuff verb - --- | Pluralize a noun. -plural :: Text -> Text -plural = MM.defaultNounPlural - --- For now, it is just MM.defaultNounPlural, which only uses heuristics; --- in the future, if we discover specific nouns that it gets wrong, --- we can add a lookup table. - --- | Either pluralize a noun or not, depending on the value of the --- number. -number :: Int -> Text -> Text -number 1 = id -number _ = plural - --- | Surround some text in single quotes. -squote :: Text -> Text -squote t = T.concat ["'", t, "'"] - --- | Surround some text in double quotes. -quote :: Text -> Text -quote t = T.concat ["\"", t, "\""] - --- | Surround some text in backticks. -bquote :: Text -> Text -bquote t = T.concat ["`", t, "`"] - --- | Surround some text in parentheses. -parens :: Text -> Text -parens t = T.concat ["(", t, ")"] - --- | Surround some text in square brackets. -brackets :: Text -> Text -brackets t = T.concat ["[", t, "]"] - --- | Make a list of things with commas and the word "and". -commaList :: [Text] -> Text -commaList [] = "" -commaList [t] = t -commaList [s, t] = T.unwords [s, "and", t] -commaList ts = T.unwords $ map (`T.append` ",") (init ts) ++ ["and", last ts] - ------------------------------------------------------------- --- Some orphan instances - -deriving instance FromJSON TimeSpec -deriving instance ToJSON TimeSpec - ------------------------------------------------------------- --- Validation utilities - --- | Require that a Boolean value is @True@, or throw an exception. -holdsOr :: Has (Throw e) sig m => Bool -> e -> m () -holdsOr b e = unless b $ throwError e - --- | Require that a 'Maybe' value is 'Just', or throw an exception. -isJustOr :: Has (Throw e) sig m => Maybe a -> e -> m a -Just a `isJustOr` _ = return a -Nothing `isJustOr` e = throwError e - --- | Require that an 'Either' value is 'Right', or throw an exception --- based on the value in the 'Left'. -isRightOr :: Has (Throw e) sig m => Either b a -> (b -> e) -> m a -Right a `isRightOr` _ = return a -Left b `isRightOr` f = throwError (f b) - --- | Require that a 'Validation' value is 'Success', or throw an exception --- based on the value in the 'Failure'. -isSuccessOr :: Has (Throw e) sig m => Validation b a -> (b -> e) -> m a -Success a `isSuccessOr` _ = return a -Failure b `isSuccessOr` f = throwError (f b) - ------------------------------------------------------------- --- Template Haskell utilities - --- See https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable -liftText :: T.Text -> Q Exp -liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt) - ------------------------------------------------------------- --- Fused-Effects Lens utilities - -(<+=) :: (Has (State s) sig m, Num a) => LensLike' ((,) a) s a -> a -> m a -l <+= a = l <%= (+ a) -{-# INLINE (<+=) #-} - -(<%=) :: (Has (State s) sig m) => LensLike' ((,) a) s a -> (a -> a) -> m a -l <%= f = l %%= (\b -> (b, b)) . f -{-# INLINE (<%=) #-} - -(%%=) :: (Has (State s) sig m) => Over p ((,) r) s s a b -> p a (r, b) -> m r -l %%= f = state (swap . l f) -{-# INLINE (%%=) #-} - -(<<.=) :: (Has (State s) sig m) => LensLike ((,) a) s s a b -> b -> m a -l <<.= b = l %%= (,b) -{-# INLINE (<<.=) #-} - -(<>=) :: (Has (State s) sig m, Semigroup a) => ASetter' s a -> a -> m () -l <>= a = modify (l <>~ a) -{-# INLINE (<>=) #-} - ------------------------------------------------------------- --- Other lens utilities - -_NonEmpty :: Lens' (NonEmpty a) (a, [a]) -_NonEmpty = lens (\(x :| xs) -> (x, xs)) (const (uncurry (:|))) - ------------------------------------------------------------- --- Some set utilities - --- | 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. --- --- >>> import qualified Data.Set as S --- >>> rss = map S.toList . S.toList . removeSupersets . S.fromList . map S.fromList --- --- >>> rss [[1,2,3], [1]] --- [[1]] --- --- >>> rss [[1,2,3], [2,4], [2,3]] --- [[2,3],[2,4]] --- --- >>> rss [[], [1], [2,3]] --- [[]] --- --- >>> rss [[1,2], [1,3], [2,3]] --- [[1,2],[1,3],[2,3]] -removeSupersets :: Ord a => Set (Set a) -> Set (Set a) -removeSupersets ss = S.filter (not . isSuperset) ss - where - isSuperset s = any (`S.isSubsetOf` s) (S.delete s ss) - --- | Given a list of /nonempty/ sets, find a hitting set, that is, a --- set which has at least one element in common with each set in the --- list. It is not guaranteed to be the /smallest possible/ such --- set, because that is NP-hard. Instead, we use a greedy algorithm --- that will give us a reasonably small hitting set: first, choose --- all elements in singleton sets, since those must necessarily be --- chosen. Now take any sets which are still not hit, and find an --- element which occurs in the largest possible number of remaining --- sets. Add this element to the set of chosen elements, and filter --- out all the sets it hits. Repeat, choosing a new element to hit --- the largest number of unhit sets at each step, until all sets are --- hit. This algorithm produces a hitting set which might be larger --- than optimal by a factor of lg(m), where m is the number of sets --- in the input. --- --- >>> import qualified Data.Set as S --- >>> shs = smallHittingSet . map S.fromList --- --- >>> shs ["a"] --- fromList "a" --- --- >>> shs ["ab", "b"] --- fromList "b" --- --- >>> shs ["ab", "bc"] --- fromList "b" --- --- >>> shs ["acd", "c", "aef", "a"] --- fromList "ac" --- --- >>> shs ["abc", "abd", "acd", "bcd"] --- fromList "cd" --- --- Here is an example of an input for which @smallHittingSet@ does --- /not/ produce a minimal hitting set. "bc" is also a hitting set and --- is smaller. b, c, and d all occur in exactly two sets, but d is --- unluckily chosen first, leaving "be" and "ac" unhit and --- necessitating choosing one more element from each. --- --- >>> shs ["bd", "be", "ac", "cd"] --- fromList "cde" -smallHittingSet :: Ord a => [Set a] -> Set a -smallHittingSet ss = go fixed (filter (S.null . S.intersection fixed) choices) - where - (fixed, choices) = first S.unions . partition ((== 1) . S.size) . filter (not . S.null) $ ss - - go !soFar [] = soFar - go !soFar cs = go (S.insert best soFar) (filter (not . (best `S.member`)) cs) - where - best = mostCommon cs - - -- Given a nonempty collection of sets, find an element which is shared among - -- as many of them as possible. - mostCommon :: Ord a => [Set a] -> a - mostCommon = fst . maximumBy (comparing snd) . M.assocs . M.fromListWith (+) . map (,1 :: Int) . concatMap S.toList diff --git a/src/Swarm/Util/Effect.hs b/src/Swarm/Util/Effect.hs deleted file mode 100644 --- a/src/Swarm/Util/Effect.hs +++ /dev/null @@ -1,80 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- fused-effect utilities for Swarm. -module Swarm.Util.Effect where - -import Control.Carrier.Accum.FixedStrict -import Control.Carrier.Error.Either (ErrorC (..)) -import Control.Carrier.Throw.Either (ThrowC (..), runThrow) -import Control.Effect.Throw -import Control.Monad ((<=<), (>=>)) -import Control.Monad.Trans.Except (ExceptT) -import Data.Either.Extra (eitherToMaybe) -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Swarm.Game.Failure (SystemFailure) -import Swarm.Language.Pretty (prettyString) -import Witherable - --- | Transform a @Throw e1@ constraint into a @Throw e2@ constraint, --- by supplying an adapter function of type @(e1 -> e2)@. -withThrow :: (Has (Throw e2) sig m) => (e1 -> e2) -> ThrowC e1 m a -> m a -withThrow f = runThrow >=> either (throwError . f) return - --- | Transform a @Throw e@ constrint into a concrete @Maybe@, --- discarding the error. -throwToMaybe :: forall e m a. Functor m => ThrowC e m a -> m (Maybe a) -throwToMaybe = fmap eitherToMaybe . runThrow - --- | Transform a @Throw e@ constrint into a concrete @Maybe@, --- logging any error as a warning. -throwToWarning :: (Has (Accum (Seq e)) sig m) => ThrowC e m a -> m (Maybe a) -throwToWarning m = do - res <- runThrow m - case res of - Left err -> warn err >> return Nothing - Right a -> return (Just a) - --- | Run a computation with an @Accum@ effect (typically accumulating --- a list of warnings), ignoring the accumulated value. -ignoreWarnings :: forall e m a. (Monoid e, Functor m) => AccumC e m a -> m a -ignoreWarnings = evalAccum mempty - --- | Convert a fused-effects style computation using a @Throw e@ --- constraint into an @ExceptT@ computation. This is mostly a stub --- to convert from one style to the other while we are in the middle --- of incrementally converting. Eventually this should not be needed. -asExceptT :: ThrowC e m a -> ExceptT e m a -asExceptT (ThrowC (ErrorC m)) = m - --- | Log a single failure as a warning. -warn :: Has (Accum (Seq w)) sig m => w -> m () -warn = add . Seq.singleton - --- | A version of 'traverse'/'mapM' that also accumulates warnings. --- --- Note that we can't generalize this to work over any 'Traversable' --- because it also needs to have a notion of "filtering". --- 'Witherable' provides exactly the right abstraction. -traverseW :: - (Has (Accum (Seq w)) sig m, Witherable t) => - (a -> m (Either w b)) -> - t a -> - m (t b) -traverseW f = do - wither $ - f >=> \case - Left e -> warn e >> return Nothing - Right e -> return $ Just e - --- | Flipped version of 'traverseW' for convenience. -forMW :: - (Has (Accum (Seq w)) sig m, Witherable t) => - t a -> - (a -> m (Either w b)) -> - m (t b) -forMW = flip traverseW - -simpleErrorHandle :: ThrowC SystemFailure IO a -> IO a -simpleErrorHandle = either (fail . prettyString) pure <=< runThrow diff --git a/src/Swarm/Util/Erasable.hs b/src/Swarm/Util/Erasable.hs deleted file mode 100644 --- a/src/Swarm/Util/Erasable.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Custom extension of 'Semigroup' to 'Monoid' that adds identity + --- annihilator elements. -module Swarm.Util.Erasable where - --- | Extend a semigroup to a monoid by adding an identity ('ENothing') /and/ an --- annihilator ('EErase'). That is, --- --- * @ENothing <> e = e <> ENothing = e@ --- * @EErase <> e = e <> EErase = EErase@ --- --- This allows us to "erase" previous values by combining with --- 'EErase'. The 'erasableToMaybe' function turns an 'Erasable' --- into a 'Maybe' by collapsing 'ENothing' and 'EErase' both back --- into 'Nothing'. -data Erasable e = ENothing | EErase | EJust e - deriving (Show, Eq, Ord, Functor) - -instance Semigroup e => Semigroup (Erasable e) where - ENothing <> e = e - e <> ENothing = e - EErase <> _ = EErase - _ <> EErase = EErase - EJust e1 <> EJust e2 = EJust (e1 <> e2) - -instance Semigroup e => Monoid (Erasable e) where - mempty = ENothing - --- | Generic eliminator for 'Erasable' values. -erasable :: a -> a -> (e -> a) -> Erasable e -> a -erasable x y z = \case - ENothing -> x - EErase -> y - EJust e -> z e - --- | Convert an 'Erasable' value to 'Maybe', turning both 'ENothing' --- and 'EErase' into 'Nothing'. -erasableToMaybe :: Erasable e -> Maybe e -erasableToMaybe = erasable Nothing Nothing Just - --- | Inject a 'Maybe' value into 'Erasable' using 'ENothing' and --- 'EJust'. -maybeToErasable :: Maybe e -> Erasable e -maybeToErasable = maybe ENothing EJust diff --git a/src/Swarm/Util/Lens.hs b/src/Swarm/Util/Lens.hs deleted file mode 100644 --- a/src/Swarm/Util/Lens.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Lens generation utilities. -module Swarm.Util.Lens ( - makeLensesNoSigs, - makeLensesExcluding, -) where - -import Control.Lens ( - generateSignatures, - lensField, - lensRules, - makeLensesWith, - mapped, - (%~), - (&), - (.~), - ) -import Language.Haskell.TH (DecsQ) -import Language.Haskell.TH.Syntax (Name) - --- | Generate lenses but with no type signatures, so we can explicitly --- give type signatures and attach custom Haddock documentation to --- them. -makeLensesNoSigs :: Name -> DecsQ -makeLensesNoSigs = makeLensesWith (lensRules & generateSignatures .~ False) - --- | Generate lenses for the fields of a record type (with no type --- signatures), except for a given list of excluded fields. --- --- Especially useful in conjunction with the design pattern --- described in --- https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ -makeLensesExcluding :: [Name] -> Name -> DecsQ -makeLensesExcluding exclude = - makeLensesWith - ( lensRules - & generateSignatures .~ False - & lensField . mapped . mapped %~ \fn n -> - if n `elem` exclude then [] else fn n - ) diff --git a/src/Swarm/Util/Parse.hs b/src/Swarm/Util/Parse.hs deleted file mode 100644 --- a/src/Swarm/Util/Parse.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Parsing utilities for Swarm. -module Swarm.Util.Parse where - -import Control.Applicative (optional) -import Text.Megaparsec (MonadParsec, eof) - --- | Run a parser "fully", consuming leading whitespace and ensuring --- that the parser extends all the way to eof. -fully :: (MonadParsec e s f) => f () -> f a -> f a -fully sc p = sc *> p <* eof - --- | Run a parser "fully", consuming leading whitespace (including the --- possibility that the input is nothing but whitespace) and --- ensuring that the parser extends all the way to eof. -fullyMaybe :: (MonadParsec e s f) => f () -> f a -> f (Maybe a) -fullyMaybe sc = fully sc . optional diff --git a/src/Swarm/Util/UnitInterval.hs b/src/Swarm/Util/UnitInterval.hs deleted file mode 100644 --- a/src/Swarm/Util/UnitInterval.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Creation and utilities for the unit interval -module Swarm.Util.UnitInterval ( - UnitInterval, - getValue, - mkInterval, - safeIndex, -) where - -import Data.List.NonEmpty (NonEmpty, (!!)) -import Prelude hiding ((!!)) - -newtype UnitInterval a = UnitInterval - { getValue :: a - } - --- | Guarantees that the stored value falls within the closed interval --- @[0, 1]@. It is up to clients to ensure that the promotion --- to this type is lossless. -mkInterval :: (Ord a, Num a) => a -> UnitInterval a -mkInterval = UnitInterval . max 0 . min 1 - --- | Since '(!!)' is partial, here is "proof" that it is safe: --- If "alpha" is its maximum value of @1@, then the maximum value --- of the computed index shall be one less than the length of the --- list (i.e., a valid index). --- --- See also: 'Swarm.Util.indexWrapNonEmpty'. -safeIndex :: - RealFrac a => - -- | alpha - UnitInterval a -> - NonEmpty b -> - b -safeIndex (UnitInterval alpha) xs = - xs !! floor (alpha * fromIntegral (length xs - 1)) diff --git a/src/Swarm/Util/WindowedCounter.hs b/src/Swarm/Util/WindowedCounter.hs deleted file mode 100644 --- a/src/Swarm/Util/WindowedCounter.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Sliding window for activity monitoring. -module Swarm.Util.WindowedCounter ( - WindowedCounter, - Offsettable (..), - - -- * Construction - mkWindow, - - -- * Querying - getOccupancy, - - -- * Maintenance - insert, - discardGarbage, -) where - -import Data.Aeson -import Data.Set (Set) -import Data.Set qualified as Set -import Swarm.Util.UnitInterval -import Prelude hiding (length) - --- | Values that can be offset by an integral amount -class Offsettable a where - offsetBy :: Int -> a -> a - --- | A "sliding window" of a designated span that supports insertion --- of tick "timestamps" that represent some state of interest during that tick. --- This data structure supports efficient querying of the ratio of --- {ticks for which that state existed} --- to the --- {total number of ticks spanned by the window}. --- --- The primary use case is in displaying the "activity level" of a robot. --- --- == Efficiency considerations --- --- The data retention of the window shall be maintained externally by --- invoking the 'discardGarbage' function. However, we should not --- unconditionally invoke this function upon each game tick. --- --- For efficiency, we do not want to iterate over every robot --- upon every tick; we only want to "visit" a robot if it is actually --- doing work that tick. --- Because of this, there may be some ticks in which the oldest element --- that is still stored falls outside of the nominal retention window --- while a robot is inactive. --- --- One might think we could perform garbage collection whenever we execute queries. --- However, in the context in which the view powered by the query is generated, we --- are not permitted to mutate the "state" of the game --- (the type signature of the rendering function is @AppState -> Widget Name@). --- --- Therefore, when we perform "queries" on the window, we must apply some --- filtering to exclude the "stragglers"; data members that have already fallen outside --- the window but have not yet been "garbage collected". --- We use a 'Set' to allow this filtering to be performed in @O(log n)@ time. --- --- In the worst case, the entire dataset may "age out" without being garbage collected, --- so that an @O(log n)@ filtering operation might be performed upon every "frame refresh" --- of the UI view. --- However, we also store the largest element of the window separately from the 'Set' so that --- we can compare against it for a @O(1)@ short-circuited path once every member ages out. --- --- The maximum number of elements ever stored in the 'Set' will be the width of the nominal --- span, even after some protracted failure to "garbage collect". -data WindowedCounter a = WindowedCounter - { _members :: Set a - , _lastLargest :: Maybe a - -- ^ NOTE: It is possible that '_lastLargest' may not exist in the 'Set'. - , _nominalSpan :: Int - -- ^ Data retention window. This value is guaranteed positive by the smart constructor. - } - deriving (Eq, Show) - --- | Automatically deriving 'FromJSON' circumvents the protection offered by "smart constructors", --- and the 'ToJSON' instance may expose internal details. --- Therefore, we write our own custom implementations. --- --- This 'ToJSON' instance is strictly for diagnostic purposes, and we can reveal --- a bit more information than is used for parsing. -instance (ToJSON a) => ToJSON (WindowedCounter a) where - toJSON (WindowedCounter membersSet _lastLargest nominalSpan) = - object - [ "members" .= toJSON membersSet - , "span" .= nominalSpan - ] - --- | We discard any "internal state" revealed by the 'ToJSON' instance and --- just use the "span" so that we can rely on any guarantees offered by the --- smart constructor, no matter the origin of the JSON. --- --- Discarding the internal state is OK, because it is not integral to gameplay; --- it is merely informational as a live indicator in the UI. -instance FromJSON (WindowedCounter a) where - parseJSON = withObject "WindowedCounter" $ \v -> do - s <- v .: "span" - return $ mkWindow s - --- | NOTE: We take the absolute value of the "window span" argument --- so that we can make guarantees about the output of 'getOccupancy'. -mkWindow :: - -- | window span - Int -> - WindowedCounter a -mkWindow = WindowedCounter Set.empty Nothing . abs - --- | Return the ratio of {members in the window} to the {integral span --- represented by the window}. --- --- The "current time" should be at least as large as the largest --- element of the window. --- --- A fully-contiguous collection of ticks would have an occupancy ratio of @1@. --- --- == Unit interval guarantee --- The returned ratio is /guaranteed/ to lie on the unit interval, because: --- --- * Both the numerator and denominator of the ratio are guaranteed positive, and --- * 'discardGarbage' guarantees that the set size is less than or equal to --- the nominal span. -getOccupancy :: - (Ord a, Offsettable a) => - -- | current time - a -> - WindowedCounter a -> - UnitInterval Double -getOccupancy currentTime wc@(WindowedCounter s lastLargest nominalSpan) = - mkInterval $ - if Set.null s || maybe False (< referenceTick) lastLargest - then 0 - else fromIntegral (Set.size culledSet) / fromIntegral nominalSpan - where - referenceTick = offsetBy (negate nominalSpan) currentTime - -- Cull the window according to the current time - WindowedCounter culledSet _ _ = discardGarbage currentTime wc - --- | Invocations of this function shall be guarded externally --- by the conditions meant to be tracked in the window. --- --- Proper usage dictates that the value inserted should always --- be at least as large as the current largest element of the set. --- --- The 'discardGarbage' function is called from inside this function --- so that maintenance of the data structure is simplified. -insert :: - (Ord a, Offsettable a) => - -- | current time - a -> - WindowedCounter a -> - WindowedCounter a -insert x (WindowedCounter s lastLargest nominalSpan) = - discardGarbage x $ WindowedCounter (Set.insert x s) newLargest nominalSpan - where - newLargest = Just $ maybe x (max x) lastLargest - --- | Drop the leading elements that are not larger than the cutoff. --- --- This function is already called by the 'insert' function, so clients --- do not necessarily ever have to call this directly. --- However, there may --- be opportunity to call this even more often, i.e. in code paths where the --- robot is visited but the condition for insertion is not met. --- --- == Invariant --- If the largest member of the set is the current time, --- then after calling this function, the difference between smallest and largest --- value in the set is strictly less than the "nominal span", and the size of the --- set is less than or equal to the nominal span. --- --- For example, if the nominal span is @3@, the current time is @7@, and the --- set entails a contiguous sequence @{2, 3, 4, 5, 6, 7}@, then the pivot for 'Set.split' will be --- @7 - 3 = 4@. The set becomes @{5, 6, 7}@, with cardinality equal to the nominal span. -discardGarbage :: - (Ord a, Offsettable a) => - -- | current time - a -> - WindowedCounter a -> - WindowedCounter a -discardGarbage currentTime (WindowedCounter s lastLargest nominalSpan) = - WindowedCounter larger lastLargest nominalSpan - where - -- NOTE: Neither output set of 'split' includes the "pivot" value. - (_smaller, larger) = Set.split (offsetBy (negate nominalSpan) currentTime) s diff --git a/src/Swarm/Util/Yaml.hs b/src/Swarm/Util/Yaml.hs deleted file mode 100644 --- a/src/Swarm/Util/Yaml.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Various utilities related to parsing YAML files. -module Swarm.Util.Yaml ( - With (..), - ParserE, - liftE, - localE, - withE, - getE, - FromJSONE (..), - decodeFileEitherE, - (..:), - (..:?), - (..!=), - withTextE, - withObjectE, - withArrayE, -) where - -import Control.Applicative (Alternative) -import Control.Monad.Reader -import Data.Aeson.Key (fromText) -import Data.Aeson.Types (explicitParseField, explicitParseFieldMaybe) -import Data.Bifunctor (first) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Vector qualified as V -import Data.Yaml as Y -import Swarm.Util (failT, showT) - ------------------------------------------------------------- --- WithEntities wrapper ------------------------------------------------------------- - --- | A generic wrapper for computations which also depend on knowing a --- value of type @e@. -newtype With e f a = E {runE :: e -> f a} - deriving (Functor) - deriving (Applicative, Monad, MonadFail, Alternative) via (ReaderT e f) - --- | A 'ParserE' is a YAML 'Parser' that can also depend on knowing an --- value of type @e@. The @E@ used to stand for @EntityMap@, but now --- that it is generalized, it stands for Environment. -type ParserE e = With e Parser - --- | Lift a computation that does not care about the environment --- value. -liftE :: Functor f => f a -> With e f a -liftE = E . const - --- | Locally modify an environment. -localE :: (e' -> e) -> With e f a -> With e' f a -localE g (E f) = E (f . g) - --- | Locally merge an environment with the current one for given action. -withE :: Semigroup e => e -> With e f a -> With e f a -withE e = localE (<> e) - --- | Get the current environment. -getE :: (Monad f) => With e f e -getE = E return - ------------------------------------------------------------- --- FromJSONE ------------------------------------------------------------- - --- | 'FromJSONE' governs values that can be parsed from a YAML (or --- JSON) file, but which also have access to an extra, read-only --- environment value. --- --- For things that don't care about the environment, the default --- implementation of 'parseJSONE' simply calls 'parseJSON' from a --- 'FromJSON' instance. -class FromJSONE e a where - parseJSONE :: Value -> ParserE e a - default parseJSONE :: FromJSON a => Value -> ParserE e a - parseJSONE = liftE . parseJSON - - parseJSONE' :: e -> Value -> Parser a - parseJSONE' e = ($ e) . runE . parseJSONE - -instance FromJSONE e Int - -instance FromJSONE e a => FromJSONE e [a] where - parseJSONE = withArrayE "[]" (traverse parseJSONE . V.toList) - -instance (FromJSONE e a, FromJSONE e b) => FromJSONE e (a, b) where - parseJSONE = withArrayE "(a, b)" $ \t -> - let n = V.length t - in if n == 2 - then - (,) - <$> parseJSONE (V.unsafeIndex t 0) - <*> parseJSONE (V.unsafeIndex t 1) - else failT ["cannot unpack array of length", showT n, "into a tuple of length 2"] - ------------------------------------------------------------- --- Decoding ------------------------------------------------------------- - --- | Read a value from a YAML file, providing the needed extra --- environment. -decodeFileEitherE :: FromJSONE e a => e -> FilePath -> IO (Either ParseException a) -decodeFileEitherE e file = do - res <- decodeFileEither file :: IO (Either ParseException Value) - return $ case res of - Left err -> Left err - Right v -> first AesonException $ parseEither (parseJSONE' e) v - ------------------------------------------------------------- --- Accessors ------------------------------------------------------------- - --- | A variant of '.:' for 'ParserE': project out a field of an --- 'Object', passing along the extra environment. -(..:) :: FromJSONE e a => Object -> Text -> ParserE e a -v ..: x = E $ \e -> explicitParseField (parseJSONE' e) v (fromText x) - --- | A variant of '.:?' for 'ParserE': project out an optional field of an --- 'Object', passing along the extra environment. -(..:?) :: FromJSONE e a => Object -> Text -> ParserE e (Maybe a) -v ..:? x = E $ \e -> explicitParseFieldMaybe (parseJSONE' e) v (fromText x) - --- | A variant of '.!=' for any functor. -(..!=) :: Functor f => f (Maybe a) -> a -> f a -p ..!= a = fromMaybe a <$> p - ------------------------------------------------------------- --- Helpers ------------------------------------------------------------- - -withThingE :: - (forall b. String -> (thing -> Parser b) -> Value -> Parser b) -> - (String -> (thing -> ParserE e a) -> Value -> ParserE e a) -withThingE withThing name f = E . (\v es -> withThing name (($ es) . runE . f) v) - --- | @'withTextE' name f value@ applies @f@ to the 'Text' when @value@ is --- a @String@ and fails otherwise. -withTextE :: String -> (Text -> ParserE e a) -> Value -> ParserE e a -withTextE = withThingE withText - --- | @'withObjectE' name f value@ applies @f@ to the 'Object' when @value@ is --- an 'Object' and fails otherwise. -withObjectE :: String -> (Object -> ParserE e a) -> Value -> ParserE e a -withObjectE = withThingE withObject - --- | @'withArrayE' name f value@ applies @f@ to the 'Array' when @value@ is --- an 'Array' and fails otherwise. -withArrayE :: String -> (Y.Array -> ParserE e a) -> Value -> ParserE e a -withArrayE = withThingE withArray diff --git a/src/Swarm/Version.hs b/src/Swarm/Version.hs deleted file mode 100644 --- a/src/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/Web.hs b/src/Swarm/Web.hs deleted file mode 100644 --- a/src/Swarm/Web.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- A web service for Swarm. --- --- The service can be started using the `--port 5357` command line argument, --- or through the REPL by calling `Swarm.App.demoWeb`. --- --- See 'SwarmAPI' for the available endpoints. You can also see them in your --- browser on the top level endpoint: --- @lynx localhost:5357 -dump@ --- or you can output the markdown documentation to your terminal: --- @cabal run swarm -O0 -- generate endpoints@ --- --- Missing endpoints: --- --- * TODO: #625 run endpoint to load definitions --- * TODO: #493 export the whole game state -module Swarm.Web ( - startWebThread, - defaultPort, - - -- ** Docs - SwarmAPI, - swarmApiHtml, - swarmApiMarkdown, - - -- ** Development - webMain, -) where - -import Brick.BChan -import Commonmark qualified as Mark (commonmark, renderHtml) -import Control.Arrow (left) -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Control.Exception (Exception (displayException), IOException, catch, throwIO) -import Control.Lens -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString.Lazy (ByteString) -import Data.Foldable (toList) -import Data.IntMap qualified as IM -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Lazy.Encoding (encodeUtf8) -import Data.Tree (Tree (Node), drawTree) -import Network.HTTP.Types (ok200) -import Network.Wai (responseLBS) -import Network.Wai qualified -import Network.Wai.Handler.Warp qualified as Warp -import Servant -import Servant.Docs (ToCapture) -import Servant.Docs qualified as SD -import Servant.Docs.Internal qualified as SD (renderCurlBasePath) -import Swarm.Game.Robot -import Swarm.Game.Scenario.Objective -import Swarm.Game.Scenario.Objective.Graph -import Swarm.Game.Scenario.Objective.WinCheck -import Swarm.Game.State -import Swarm.Language.Module -import Swarm.Language.Pipeline -import Swarm.Language.Pretty (prettyTextLine) -import Swarm.Language.Syntax -import Swarm.ReadableIORef -import Swarm.TUI.Model -import Swarm.TUI.Model.Goal -import Swarm.TUI.Model.UI -import System.Timeout (timeout) -import Text.Read (readEither) -import Witch (into) - --- ------------------------------------------------------------------ --- Docs --- ------------------------------------------------------------------ - -newtype RobotID = RobotID Int - -type SwarmAPI = - "robots" :> Get '[JSON] [Robot] - :<|> "robot" :> Capture "id" RobotID :> Get '[JSON] (Maybe Robot) - :<|> "goals" :> "prereqs" :> Get '[JSON] [PrereqSatisfaction] - :<|> "goals" :> "active" :> Get '[JSON] [Objective] - :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo) - :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking - :<|> "goals" :> Get '[JSON] WinCondition - :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text - :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text - :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem] - -swarmApi :: Proxy SwarmAPI -swarmApi = Proxy - -type ToplevelAPI = SwarmAPI :<|> Raw - -api :: Proxy ToplevelAPI -api = Proxy - -swarmApiHtml :: ByteString -swarmApiHtml = - encodeUtf8 - . either (error . show) (Mark.renderHtml @()) - . Mark.commonmark "" - $ T.pack swarmApiMarkdown - -swarmApiMarkdown :: String -swarmApiMarkdown = - SD.markdownWith - ( SD.defRenderingOptions - & SD.requestExamples .~ SD.FirstContentType - & SD.responseExamples .~ SD.FirstContentType - & SD.renderCurlBasePath ?~ "http://localhost:" <> show defaultPort - ) - $ SD.docsWithIntros [intro] swarmApi - where - intro = SD.DocIntro "Swarm Web API" ["All of the valid endpoints are documented below."] - --- ------------------------------------------------------------------ --- Handlers --- ------------------------------------------------------------------ - -mkApp :: - ReadableIORef AppState -> - -- | Writable channel to send events to the game - BChan AppEvent -> - Servant.Server SwarmAPI -mkApp state events = - robotsHandler state - :<|> robotHandler state - :<|> prereqsHandler state - :<|> activeGoalsHandler state - :<|> goalsGraphHandler state - :<|> uiGoalHandler state - :<|> goalsHandler state - :<|> codeRenderHandler - :<|> codeRunHandler events - :<|> replHandler state - -robotsHandler :: ReadableIORef AppState -> Handler [Robot] -robotsHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - pure $ IM.elems $ appState ^. gameState . robotMap - -robotHandler :: ReadableIORef AppState -> RobotID -> Handler (Maybe Robot) -robotHandler appStateRef (RobotID rid) = do - appState <- liftIO (readIORef appStateRef) - pure $ IM.lookup rid (appState ^. gameState . robotMap) - -prereqsHandler :: ReadableIORef AppState -> Handler [PrereqSatisfaction] -prereqsHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - case appState ^. gameState . winCondition of - WinConditions _winState oc -> return $ getSatisfaction oc - _ -> return [] - -activeGoalsHandler :: ReadableIORef AppState -> Handler [Objective] -activeGoalsHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - case appState ^. gameState . winCondition of - WinConditions _winState oc -> return $ getActiveObjectives oc - _ -> return [] - -goalsGraphHandler :: ReadableIORef AppState -> Handler (Maybe GraphInfo) -goalsGraphHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - return $ case appState ^. gameState . winCondition of - WinConditions _winState oc -> Just $ makeGraphInfo oc - _ -> Nothing - -uiGoalHandler :: ReadableIORef AppState -> Handler GoalTracking -uiGoalHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - return $ appState ^. uiState . uiGoal . goalsContent - -goalsHandler :: ReadableIORef AppState -> Handler WinCondition -goalsHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - return $ appState ^. gameState . winCondition - -codeRenderHandler :: Text -> Handler Text -codeRenderHandler contents = do - return $ case processTermEither contents of - Right (ProcessedTerm (Module stx@(Syntax' _srcLoc _term _) _) _ _) -> - into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ stx - Left x -> x - -codeRunHandler :: BChan AppEvent -> Text -> Handler Text -codeRunHandler chan contents = do - liftIO . writeBChan chan . Web $ RunWebCode contents - return $ T.pack "Sent\n" - -replHandler :: ReadableIORef AppState -> Handler [REPLHistItem] -replHandler appStateRef = do - appState <- liftIO (readIORef appStateRef) - let replHistorySeq = appState ^. uiState . uiREPL . replHistory . replSeq - items = toList replHistorySeq - pure items - --- ------------------------------------------------------------------ --- Main app (used by service and for development) --- ------------------------------------------------------------------ - --- | Simple result type to report errors from forked startup thread. -data WebStartResult = WebStarted | WebStartError String - -webMain :: - Maybe (MVar WebStartResult) -> - Warp.Port -> - -- | Read-only reference to the application state. - ReadableIORef AppState -> - -- | Writable channel to send events to the game - BChan AppEvent -> - 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 - - server :: Server ToplevelAPI - server = mkApp appStateRef chan :<|> Tagged serveDocs - where - serveDocs _ resp = - resp $ responseLBS ok200 [plain] swarmApiHtml - plain = ("Content-Type", "text/html") - - app :: Network.Wai.Application - app = Servant.serve api server - - handleErr :: IOException -> IO () - handleErr e = case baton of - Just mv -> putMVar mv (WebStartError $ displayException e) - Nothing -> throwIO e - --- ------------------------------------------------------------------ --- Web service --- ------------------------------------------------------------------ - -defaultPort :: Warp.Port -defaultPort = 5357 - --- | Attempt to start a web thread on the requested port, or a default --- one if none is requested (or don't start a web thread if the --- requested port is 0). If an explicit port was requested, fail if --- startup doesn't work. Otherwise, ignore the failure. In any --- case, return a @Maybe Port@ value representing whether a web --- server is actually running, and if so, what port it is on. -startWebThread :: - Maybe Warp.Port -> - -- | Read-only reference to the application state. - ReadableIORef AppState -> - -- | Writable channel to send events to the game - BChan AppEvent -> - 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." -startWebThread userPort appStateRef chan = do - baton <- newEmptyMVar - let port = fromMaybe defaultPort userPort - failMsg = "Failed to start the web API on :" <> show port - void $ forkIO $ webMain (Just baton) port appStateRef chan - res <- timeout 500_000 (takeMVar baton) - case res of - Just WebStarted -> return (Right port) - Just (WebStartError e) -> return . Left $ failMsg <> " - " <> e - -- If user explicitly specified port exit, otherwise just report timeout - Nothing -> case userPort of - Just _p -> fail failMsg - Nothing -> return . Left $ failMsg <> " (timeout)" - --- ------------------------------------------------------------------ --- Necessary instances --- ------------------------------------------------------------------ - -instance SD.ToSample T.Text where - toSamples _ = SD.noSamples - -instance FromHttpApiData RobotID where - parseUrlPiece = fmap RobotID . left T.pack . readEither . T.unpack - -instance SD.ToSample RobotID where - toSamples _ = SD.samples [RobotID 0, RobotID 1] - -instance ToCapture (Capture "id" RobotID) where - toCapture _ = - SD.DocCapture - "id" -- name - "(integer) robot ID" -- description diff --git a/src/swarm-doc/Swarm/Doc/Command.hs b/src/swarm-doc/Swarm/Doc/Command.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Command.hs @@ -0,0 +1,76 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Auto-generation of command attributes matrix. +module Swarm.Doc.Command where + +import Data.Aeson (ToJSON) +import Data.List.Extra (enumerate) +import Data.List.NonEmpty qualified as NE +import Data.Set (Set) +import Data.Set qualified as Set +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) +import Swarm.Language.Types + +data DerivedAttrs = DerivedAttrs + { hasActorTarget :: Bool + , pureComputation :: Bool + , modifiesEnvironment :: Bool + , modifiesRobot :: Bool + , movesRobot :: Bool + , returnsValue :: Bool + , outputType :: String + } + deriving (Generic, ToJSON) + +data CommandEntry = CommandEntry + { cmd :: Const + , effects :: Set CommandEffect + , argTypes :: NE.NonEmpty Type + , derivedAttrs :: DerivedAttrs + } + deriving (Generic, ToJSON) + +newtype CommandCatalog = CommandCatalog + { entries :: [CommandEntry] + } + deriving (Generic, ToJSON) + +instance SD.ToSample CommandCatalog where + toSamples _ = SD.noSamples + +-- | Uses explicit effects documentation as well as +-- type signature information to compute various flags +mkEntry :: Const -> CommandEntry +mkEntry c = + CommandEntry c cmdEffects rawArgs $ + DerivedAttrs + { hasActorTarget = operatesOnActor inputArgs + , pureComputation = Set.null cmdEffects + , modifiesEnvironment = Mutation EntityChange `Set.member` cmdEffects + , modifiesRobot = not . Set.disjoint cmdEffects . Set.fromList $ map (Mutation . RobotChange) enumerate + , movesRobot = Mutation (RobotChange PositionChange) `Set.member` cmdEffects + , returnsValue = theOutputType /= TyCmd TyUnit + , outputType = show theOutputType + } + where + cmdInfo = constInfo c + cmdEffects = effectInfo $ constDoc cmdInfo + + getArgs ((Forall _ t)) = unchainFun t + + rawArgs = getArgs $ inferConst c + + inputArgs = NE.init rawArgs + theOutputType = NE.last rawArgs + + operatesOnActor = elem TyActor + +getCatalog :: CommandCatalog +getCatalog = CommandCatalog $ map mkEntry commands diff --git a/src/swarm-doc/Swarm/Doc/Gen.hs b/src/swarm-doc/Swarm/Doc/Gen.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Gen.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Auto-generation of various forms of documentation. +module Swarm.Doc.Gen ( + -- ** Main document generation function + types + generateDocs, + GenerateDocs (..), + SheetType (..), + + -- ** Wiki pages + PageAddress (..), + + -- ** Recipe graph data + RecipeGraphData (..), + EdgeFilter (..), + classicScenarioRecipeGraphData, + ignoredEntities, +) where + +import Control.Lens (view, (^.)) +import Control.Monad (zipWithM, zipWithM_) +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 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.Language.Key (specialKeyNames) +import Swarm.Util (both) +import Text.Dot (Dot, NodeId, (.->.)) +import Text.Dot qualified as Dot + +-- ============================================================================ +-- MAIN ENTRYPOINT TO CLI DOCUMENTATION GENERATOR +-- ============================================================================ +-- +-- These are the exported functions used by the executable. +-- +-- ---------------------------------------------------------------------------- + +-- | An enumeration of the kinds of documentation we can generate. +data GenerateDocs where + -- | Entity dependencies by recipes. + RecipeGraph :: EdgeFilter -> GenerateDocs + -- | Keyword lists for editors. + EditorKeywords :: Maybe EditorType -> GenerateDocs + -- | List of special key names recognized by 'Swarm.Language.Syntax.Key' command + SpecialKeyNames :: GenerateDocs + -- | Cheat sheets for inclusion on the Swarm wiki. + CheatSheet :: PageAddress -> SheetType -> GenerateDocs + -- | List command introductions by tutorial + TutorialCoverage :: GenerateDocs + deriving (Eq, Show) + +-- | Generate the requested kind of documentation to stdout. +generateDocs :: GenerateDocs -> IO () +generateDocs = \case + RecipeGraph ef -> generateRecipe ef >>= putStrLn + EditorKeywords e -> + case e of + Just et -> generateEditorKeywords et + Nothing -> do + putStrLn "All editor completions:" + let editorGen et = do + putStrLn $ replicate 40 '-' + putStrLn $ "-- " <> show et + putStrLn $ replicate 40 '-' + generateEditorKeywords et + mapM_ editorGen enumerate + SpecialKeyNames -> generateSpecialKeyNames + CheatSheet address s -> makeWikiPage address s + TutorialCoverage -> renderTutorialProgression >>= putStrLn . T.unpack + +-- ---------------------------------------------------------------------------- +-- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED +-- ---------------------------------------------------------------------------- + +-- | Generate a list of keywords in the format expected by one of the +-- supported editors. +generateEditorKeywords :: EditorType -> IO () +generateEditorKeywords = \case + Emacs -> do + putStrLn "(defvar swarm-mode-builtins '(" + T.putStr $ builtinFunctionList Emacs <> "))" + putStrLn "\n(defvar swarm-mode-commands '(" + T.putStr $ keywordsCommands Emacs + T.putStr $ keywordsDirections Emacs <> "))" + putStrLn "\n (defvar swarm-mode-operators '(" + T.putStr $ operatorNames Emacs <> "))" + VSCode -> do + putStrLn "Functions and commands:" + T.putStrLn $ builtinFunctionList VSCode <> "|" <> keywordsCommands VSCode + putStrLn "\nDirections:" + T.putStrLn $ keywordsDirections VSCode + putStrLn "\nOperators:" + T.putStrLn $ operatorNames VSCode + Vim -> do + putStrLn "syn keyword Builtins " + T.putStr $ builtinFunctionList Vim + putStrLn "\nsyn keyword Command " + T.putStr $ keywordsCommands Vim + putStrLn "\nsyn keyword Direction " + T.putStr $ keywordsDirections Vim + putStrLn "\nsyn match Operators " + T.putStr $ "[" <> operatorNames Vim <> "]" + +-- ---------------------------------------------------------------------------- +-- GENERATE SPECIAL KEY NAMES +-- ---------------------------------------------------------------------------- + +generateSpecialKeyNames :: IO () +generateSpecialKeyNames = + T.putStr . T.unlines . Set.toList $ specialKeyNames + +-- ---------------------------------------------------------------------------- +-- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES +-- ---------------------------------------------------------------------------- + +generateRecipe :: EdgeFilter -> IO String +generateRecipe ef = do + graphData <- classicScenarioRecipeGraphData + return . Dot.showDot $ recipesToDot graphData ef + +data EdgeFilter = NoFilter | FilterForward | FilterNext + deriving (Eq, Show) + +filterEdge :: EdgeFilter -> Int -> Int -> Bool +filterEdge ef i o = case ef of + NoFilter -> True + FilterForward -> i <= o + FilterNext -> i + 1 == o + +recipesToDot :: RecipeGraphData -> 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 + -- -------------------------------------------------------------------------- + -- 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 + 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 + -- -------------------------------------------------------------------------- + -- Base inventory + (_bc, ()) <- Dot.cluster $ do + Dot.attribute ("style", "filled") + Dot.attribute ("color", "lightgrey") + mapM_ ((base ---<>) . nid) devs + mapM_ ((base .->.) . nid) inv + -- -------------------------------------------------------------------------- + -- World entities + (_wc, ()) <- Dot.cluster $ do + Dot.attribute ("style", "filled") + Dot.attribute ("color", "forestgreen") + mapM_ (uncurry (Dot..->.) . (world,) . nid) worldEntities + -- -------------------------------------------------------------------------- + let -- put a hidden node above and below entities and connect them by hidden edges + wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId) + wrapBelowAbove ns = do + b <- hiddenNode + t <- hiddenNode + let ns' = map nid $ toList ns + mapM_ (b .~>.) ns' + mapM_ (.~>. t) ns' + return (b, t) + -- put set of entities in nice + subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId) + subLevel i ns = fmap snd . Dot.cluster $ do + Dot.attribute ("style", "filled") + Dot.attribute ("color", "khaki") + bt <- wrapBelowAbove ns + Dot.attribute ("rank", "sink") + -- the normal label for cluster would be cover by lines + _bigLabel <- + Dot.node + [ ("shape", "plain") + , ("label", "Bottom Label") + , ("fontsize", "20pt") + , ("label", "Level #" <> show i) + ] + return bt + -- -------------------------------------------------------------------------- + -- order entities into clusters based on how "far" they are from + -- what is available at the start - see 'recipeLevels'. + bottom <- wrapBelowAbove worldEntities + ls <- zipWithM subLevel [1 ..] (drop 1 levels) + let invisibleLine = zipWithM_ (.~>.) + tls <- mapM (const hiddenNode) levels + bls <- mapM (const hiddenNode) levels + invisibleLine tls bls + invisibleLine bls (drop 1 tls) + let sameBelowAbove (b1, t1) (b2, t2) = Dot.same [b1, b2] >> Dot.same [t1, t2] + zipWithM_ sameBelowAbove (bottom : ls) (zip bls tls) + -- -------------------------------------------------------------------------- + -- add node for the world and draw a line to each entity found in the wild + -- finally draw recipes + let eFilter = filterEdge ef + lvl e = fromMaybe (-1) $ List.findIndex (Set.member e) levels + recipeInOut r = [(i, o) | (_, i) <- r ^. recipeInputs, (_, o) <- r ^. recipeOutputs, lvl i `eFilter` lvl o] + recipeReqOut r = [(q, o) | (_, q) <- r ^. recipeCatalysts, (_, o) <- r ^. recipeOutputs, lvl q `eFilter` lvl o] + recipesToPairs f rs = both nid <$> nubOrd (concatMap f rs) + mapM_ (uncurry (.->.)) (recipesToPairs recipeInOut recipes) + 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 + 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 +-- ---------------------------------------------------------------------------- + +customNode :: [(String, String)] -> String -> Dot NodeId +customNode attrs label = Dot.node $ [("style", "filled"), ("label", label)] <> attrs + +box, diamond :: String -> Dot NodeId +box = customNode [("shape", "box")] +diamond = customNode [("shape", "diamond")] + +-- | Hidden node - used for layout. +hiddenNode :: Dot NodeId +hiddenNode = Dot.node [("style", "invis")] + +-- | Edge for yielded entities. +(.-<>.) :: NodeId -> NodeId -> Dot () +e1 .-<>. e2 = Dot.edge e1 e2 attrs + where + attrs = [("arrowhead", "diamond"), ("color", "purple")] + +-- | Hidden edge - used for layout. +(.~>.) :: NodeId -> NodeId -> Dot () +i .~>. j = Dot.edge i j [("style", "invis")] + +-- | Edge for recipe requirements and outputs. +(---<>) :: NodeId -> NodeId -> Dot () +e1 ---<> e2 = Dot.edge e1 e2 attrs + where + attrs = [("arrowhead", "diamond"), ("color", "blue")] diff --git a/src/swarm-doc/Swarm/Doc/Keyword.hs b/src/swarm-doc/Swarm/Doc/Keyword.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Keyword.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: keywords for doc gen and testing +-- +-- Collect keywords for documentation generation and testing. +module Swarm.Doc.Keyword ( + EditorType (..), + + -- ** Formatted keyword lists + keywordsCommands, + keywordsDirections, + operatorNames, + builtinFunctionList, +) where + +import Data.List (nub) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Doc.Util +import Swarm.Language.Syntax.Direction +import Swarm.Util (quote) + +-- | An enumeration of the editors supported by Swarm (currently, +-- Emacs, VS Code and Vim). +data EditorType = Emacs | VSCode | Vim + deriving (Eq, Show, Enum, Bounded) + +builtinFunctionList :: EditorType -> Text +builtinFunctionList e = editorList e $ map constSyntax builtinFunctions + +editorList :: EditorType -> [Text] -> Text +editorList = \case + Emacs -> T.unlines . map ((" " <>) . quote) + VSCode -> T.intercalate "|" + Vim -> T.intercalate " " + +-- | Get formatted list of basic functions/commands. +keywordsCommands :: EditorType -> Text +keywordsCommands e = editorList e $ map constSyntax commands + +-- | Get formatted list of directions. +keywordsDirections :: EditorType -> Text +keywordsDirections e = editorList e $ map directionSyntax allDirs + +-- | A list of the names of all the operators in the language. +-- These are reflective of how the different editors treat operators, +-- keywords, symbols etc differently. +-- In order to get the list of operators supported by Swarm language +-- irrespective of an editor, @map constSyntax operators@ should suffice. +operatorNames :: EditorType -> Text +operatorNames e = case e of + Emacs -> editorList e $ map constSyntax operators <> extraOperators + -- Vim needs a list of unique characters that can be matched over using a regex + Vim -> T.pack . nub . T.unpack . T.concat $ map constSyntax operators <> extraOperators + VSCode -> editorList e $ map (escape . constSyntax) operators <> extraOperators + where + slashNotComment = \case + '/' -> "/(?![/|*])" + c -> T.singleton c + + special :: String + special = "*+$[]|^" + + -- Extra operators appearing in different places. Eg: Type signatures. + extraOperators :: [Text] + extraOperators = [":"] + + escape = T.concatMap (\c -> if c `elem` special then T.snoc "\\" c else slashNotComment c) diff --git a/src/swarm-doc/Swarm/Doc/Pedagogy.hs b/src/swarm-doc/Swarm/Doc/Pedagogy.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Pedagogy.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Pedagogical soundness of tutorials +-- +-- Assess pedagogical soundness of the tutorials. +-- +-- Approach: +-- +-- 1. Obtain a list of all of the tutorial scenarios, in order +-- 2. Search their \"solution\" code for `commands` +-- 3. "fold" over the tutorial list, noting which tutorial was first to introduce each command +module Swarm.Doc.Pedagogy ( + renderTutorialProgression, + generateIntroductionsSequence, + CoverageInfo (..), + TutorialInfo (..), +) where + +import Control.Lens (universe, view, (^.)) +import Control.Monad (guard) +import Data.List (foldl', intercalate, sort, sortOn) +import Data.List.Extra (zipFrom) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (mapMaybe) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Constant +import Swarm.Game.Failure (SystemFailure, simpleErrorHandle) +import Swarm.Game.Land +import Swarm.Game.Scenario ( + Scenario, + ScenarioInputs (..), + scenarioDescription, + scenarioMetadata, + scenarioName, + scenarioObjectives, + scenarioOperation, + scenarioSolution, + ) +import Swarm.Game.Scenario.Objective (objectiveGoal) +import Swarm.Game.ScenarioInfo ( + ScenarioCollection, + ScenarioInfoPair, + flatten, + getTutorials, + loadScenarios, + 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) + +-- * Constants + +commandsWikiAnchorPrefix :: Text +commandsWikiAnchorPrefix = wikiCheatSheet <> "#" + +-- * Types + +-- | Tutorials augmented by the set of +-- commands that they introduce. +-- Generated by folding over all of the +-- tutorials in sequence. +data CoverageInfo = CoverageInfo + { tutInfo :: TutorialInfo + , novelSolutionCommands :: Map Const [SrcLoc] + } + +-- | Tutorial scenarios with the set of commands +-- introduced in their solution and descriptions +-- having been extracted +data TutorialInfo = TutorialInfo + { scenarioPair :: ScenarioInfoPair + , tutIndex :: Int + , solutionCommands :: Map Const [SrcLoc] + , descriptionCommands :: Set Const + } + +-- | A private type used by the fold +data CommandAccum = CommandAccum + { _encounteredCmds :: Set Const + , tuts :: [CoverageInfo] + } + +-- * Functions + +-- | Extract commands from both goal descriptions and solution code. +extractCommandUsages :: Int -> ScenarioInfoPair -> TutorialInfo +extractCommandUsages idx siPair@(s, _si) = + TutorialInfo siPair idx solnCommands $ getDescCommands s + where + solnCommands = getCommands maybeSoln + maybeSoln = view (scenarioOperation . scenarioSolution) s + +-- | Obtain the set of all commands mentioned by +-- name in the tutorial's goal descriptions. +getDescCommands :: Scenario -> Set Const +getDescCommands s = S.fromList $ concatMap filterConst allCode + where + goalTextParagraphs = view objectiveGoal <$> view (scenarioOperation . scenarioObjectives) s + allCode = concatMap findCode goalTextParagraphs + filterConst :: Syntax -> [Const] + filterConst sx = mapMaybe toConst $ universe (sx ^. sTerm) + toConst :: Term -> Maybe Const + toConst = \case + TConst c -> Just c + _ -> Nothing + +isConsidered :: Const -> Bool +isConsidered c = isUserFunc c && c `S.notMember` ignoredCommands + where + ignoredCommands = S.fromList [Run, Return, Noop, Force] + +-- | Extract the command names from the source code of the solution. +-- +-- NOTE: `noop` gets automatically inserted for an empty `build {}` command +-- at parse time, so we explicitly ignore the `noop` in the case that +-- the player did not write it explicitly in their code. +-- +-- Also, the code from `run` is not parsed transitively yet. +getCommands :: Maybe TSyntax -> Map Const [SrcLoc] +getCommands Nothing = mempty +getCommands (Just tsyn) = + M.fromListWith (<>) $ mapMaybe isCommand nodelist + where + nodelist :: [Syntax' Polytype] + nodelist = universe tsyn + isCommand (Syntax' sloc t _ _) = case t of + TConst c -> guard (isConsidered c) >> Just (c, [sloc]) + _ -> Nothing + +-- | "fold" over the tutorials in sequence to determine which +-- commands are novel to each tutorial's solution. +computeCommandIntroductions :: [(Int, ScenarioInfoPair)] -> [CoverageInfo] +computeCommandIntroductions = + reverse . tuts . foldl' f initial + where + initial = CommandAccum mempty mempty + + f :: CommandAccum -> (Int, ScenarioInfoPair) -> CommandAccum + f (CommandAccum encounteredPreviously xs) (idx, siPair) = + CommandAccum updatedEncountered $ CoverageInfo usages novelCommands : xs + where + usages = extractCommandUsages idx siPair + usedCmdsForTutorial = solutionCommands usages + + updatedEncountered = encounteredPreviously `S.union` M.keysSet usedCmdsForTutorial + novelCommands = M.withoutKeys usedCmdsForTutorial encounteredPreviously + +-- | Extract the tutorials from the complete scenario collection +-- and derive their command coverage info. +generateIntroductionsSequence :: ScenarioCollection -> [CoverageInfo] +generateIntroductionsSequence = + computeCommandIntroductions . zipFrom 0 . getTuts + where + getTuts = + concatMap flatten + . scenarioCollectionToList + . getTutorials + +-- * Rendering functions + +-- | Helper for standalone rendering. +-- For unit tests, can instead access the scenarios via the GameState. +loadScenarioCollection :: IO ScenarioCollection +loadScenarioCollection = simpleErrorHandle $ do + tem <- loadEntitiesAndTerrain + + -- Note we ignore any warnings generated by 'loadWorlds' and + -- 'loadScenarios' below. Any warnings will be caught when loading + -- 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 + +renderUsagesMarkdown :: CoverageInfo -> Text +renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) = + T.unlines bodySections + where + bodySections = firstLine : otherLines + otherLines = + intercalate + [""] + [ pure . surround "`" . T.pack $ view scenarioPath si + , pure . surround "*" . T.strip . docToText $ view (scenarioOperation . scenarioDescription) s + , renderSection "Introduced in solution" . renderCmdList $ M.keysSet novelCmds + , renderSection "Referenced in description" $ renderCmdList dCmds + ] + surround x y = x <> y <> x + + renderSection title content = + ["### " <> title] <> content + + firstLine = + T.unwords + [ "##" + , renderTutorialTitle idx s + ] + +renderTutorialTitle :: (Show a) => a -> Scenario -> Text +renderTutorialTitle idx s = + T.unwords + [ T.pack $ show idx <> ":" + , view (scenarioMetadata . scenarioName) s + ] + +linkifyCommand :: Text -> Text +linkifyCommand c = "[" <> c <> "](" <> commandsWikiAnchorPrefix <> c <> ")" + +renderList :: [Text] -> [Text] +renderList items = + if null items + then pure "(none)" + else map ("* " <>) items + +cmdSetToSortedText :: Set Const -> [Text] +cmdSetToSortedText = sort . map (T.pack . show) . S.toList + +renderCmdList :: Set Const -> [Text] +renderCmdList = renderList . map linkifyCommand . cmdSetToSortedText + +-- | Generate a document which lists all the tutorial scenarios, +-- highlighting for each one which commands are introduced for the +-- first time in the canonical solution, and which commands are +-- referenced in the tutorial description. +renderTutorialProgression :: IO Text +renderTutorialProgression = + processAndRender <$> loadScenarioCollection + where + processAndRender ss = + T.unlines allLines + where + introSection = + "# Command introductions by tutorial" + : "This document indicates which tutorials introduce various commands and keywords." + : "" + : "All used:" + : renderFullCmdList allUsed + + render (cmd, tut) = + T.unwords + [ linkifyCommand cmd + , "(" <> renderTutorialTitle (tutIndex tut) (fst $ scenarioPair tut) <> ")" + ] + renderFullCmdList = renderList . map render . sortOn fst + infos = generateIntroductionsSequence ss + allLines = introSection <> map renderUsagesMarkdown infos + allUsed = concatMap mkTuplesForTutorial infos + + mkTuplesForTutorial tut = + map (\x -> (T.pack $ show x, tutIdxScenario)) $ + M.keys $ + novelSolutionCommands tut + where + tutIdxScenario = tutInfo tut diff --git a/src/swarm-doc/Swarm/Doc/Schema/Arrangement.hs b/src/swarm-doc/Swarm/Doc/Schema/Arrangement.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Schema/Arrangement.hs @@ -0,0 +1,42 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Graph-based heuristics for arranging the +-- order of sections in the schema docs +module Swarm.Doc.Schema.Arrangement (sortAndPruneSchemas) where + +import Data.Graph +import Data.Set qualified as Set +import Swarm.Doc.Schema.Parse +import Swarm.Doc.Schema.Refined +import Swarm.Doc.Schema.SchemaType + +-- | Sort the schemas in topological order. +-- +-- Only includes schema files that are reachable from +-- the root schema +-- (i.e. exclude @entities.json@ and @recipes.json@, +-- which are used independently to validate @entities.yaml@ +-- and @recipes.yaml@). +sortAndPruneSchemas :: + SchemaIdReference -> + [SchemaData] -> + [SchemaData] +sortAndPruneSchemas rootSchemaKey schemas = + reverse . flattenSCCs . stronglyConnComp $ reachableEdges + where + rawEdgeList = map getNodeEdgesEntry schemas + (graph, _nodeFromVertex, vertexFromKey) = graphFromEdges rawEdgeList + reachableVertices = Set.fromList $ maybe [] (reachable graph) $ vertexFromKey rootSchemaKey + + reachableEdges = filter f rawEdgeList + f (_, k, _) = maybe False (`Set.member` reachableVertices) . vertexFromKey $ k + +getNodeEdgesEntry :: + SchemaData -> + (SchemaData, SchemaIdReference, [SchemaIdReference]) +getNodeEdgesEntry sd@(SchemaData fp schem _) = + ( sd + , fromFilePath fp + , Set.toList $ extractReferences $ content schem + ) diff --git a/src/swarm-doc/Swarm/Doc/Schema/Parse.hs b/src/swarm-doc/Swarm/Doc/Schema/Parse.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Schema/Parse.hs @@ -0,0 +1,55 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- There are no modern, comprehensive JSON Schema parsing +-- libraries in Haskell, as explained in +-- . +-- +-- Therefore, a bespoke parser for a small subset of JSON Schema is implemented here, +-- simply for rendering Markdown documentation from Swarm's schema. +module Swarm.Doc.Schema.Parse where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Swarm.Doc.Schema.Refined +import Text.Pandoc + +-- | Includes everything needed to +-- render the schema to markdown +data SchemaData = SchemaData + { schemaPath :: FilePath + , schemaContent :: ToplevelSchema + , markdownFooters :: [Pandoc] + } + +data Members + = ObjectProperties (Map Text SwarmSchema) + | ListMembers (ItemDescription SwarmSchema) + | EnumMembers (NonEmpty Text) + deriving (Eq, Ord, Show) + +data ToplevelSchema = ToplevelSchema + { title :: Text + , description :: Maybe Pandoc + , content :: SwarmSchema + , members :: Maybe Members + , footerPaths :: [FilePath] + } + deriving (Eq, Ord, Show) + +instance FromJSON ToplevelSchema where + parseJSON x = do + rawSchema :: rawSchema <- parseJSON x + swarmSchema <- toSwarmSchema rawSchema + + theTitle <- maybe (fail "Schema requires a title") return $ _title rawSchema + let theFooters = fromMaybe [] $ _footers rawSchema + maybeMembers = + ObjectProperties <$> properties swarmSchema + <|> ListMembers <$> itemsDescription swarmSchema + <|> EnumMembers <$> _enum rawSchema + return $ ToplevelSchema theTitle (objectDescription swarmSchema) swarmSchema maybeMembers theFooters diff --git a/src/swarm-doc/Swarm/Doc/Schema/Refined.hs b/src/swarm-doc/Swarm/Doc/Schema/Refined.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Schema/Refined.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Refined JSON schema after converting +-- all JSON Value types to their specific sum types +module Swarm.Doc.Schema.Refined where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.List.Extra (replace) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Swarm.Doc.Schema.SchemaType +import System.FilePath (takeBaseName) +import Text.Pandoc +import Text.Pandoc.Builder + +-- * Basic + +schemaJsonOptions :: Options +schemaJsonOptions = + defaultOptions + { fieldLabelModifier = replace "S" "$" . drop 1 -- drops leading underscore + } + +-- | A single record that encompasses all possible objects +-- in a JSON schema. All fields are optional. +data SchemaRaw = SchemaRaw + { _description :: Maybe Text + , _default :: Maybe Value + , _title :: Maybe Text + , _type :: Maybe (SingleOrList Text) + , _name :: Maybe Text + , _properties :: Maybe (Map Text SwarmSchema) + , _items :: Maybe (ItemDescription SwarmSchema) + , _examples :: Maybe [Value] + , _Sref :: Maybe Text + , _oneOf :: Maybe [SchemaRaw] + , _footers :: Maybe [FilePath] + , _additionalProperties :: Maybe Bool + , _enum :: Maybe (NonEmpty Text) + } + deriving (Eq, Ord, Show, Generic) + +instance FromJSON SchemaRaw where + parseJSON = genericParseJSON schemaJsonOptions + +extractSchemaType :: SchemaRaw -> Maybe SchemaType +extractSchemaType rawSchema = + mkReference <$> _Sref rawSchema + <|> getTypeFromItems + <|> Simple <$> _type rawSchema + <|> Alternatives . mapMaybe extractSchemaType <$> _oneOf rawSchema + <|> EnumList <$> _enum rawSchema + where + mkReference = Reference . SchemaIdReference . T.pack . takeBaseName . T.unpack + + getTypeFromItems :: Maybe SchemaType + getTypeFromItems = do + itemsThing <- _items rawSchema + case itemsThing of + ItemList _ -> Nothing + ItemType x -> Just $ ListOf $ schemaType x + +-- * Refined + +data ItemDescription a + = ItemList [a] + | ItemType a + deriving (Eq, Ord, Show) + +instance (FromJSON a) => FromJSON (ItemDescription a) where + parseJSON x = + ItemList <$> parseJSON x + <|> ItemType <$> parseJSON x + +getSchemaReferences :: SchemaType -> [SchemaIdReference] +getSchemaReferences = \case + Simple _ -> [] + Alternatives xs -> concatMap getSchemaReferences xs + Reference x -> pure x + ListOf x -> getSchemaReferences x + EnumList _ -> [] + +-- | A subset of all JSON schemas, conforming to internal Swarm conventions. +-- +-- Conveniently, this extra representation layer +-- is able to enforce (via 'toSwarmSchema') that all "object" +-- definitions in the schema contain the @"additionalProperties": true@ attribute. +data SwarmSchema = SwarmSchema + { schemaType :: SchemaType + , defaultValue :: Maybe Value + , objectDescription :: Maybe Pandoc + , properties :: Maybe (Map Text SwarmSchema) + , itemsDescription :: Maybe (ItemDescription SwarmSchema) + , examples :: [Value] + } + deriving (Eq, Ord, Show) + +instance FromJSON SwarmSchema where + parseJSON x = do + rawSchema :: rawSchema <- parseJSON x + toSwarmSchema rawSchema + +getMarkdown :: MonadFail m => Text -> m Pandoc +getMarkdown desc = case runPure (readMarkdown def desc) of + Right d -> return d + Left err -> fail $ T.unpack $ renderError err + +toSwarmSchema :: MonadFail m => SchemaRaw -> m SwarmSchema +toSwarmSchema rawSchema = do + 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'" + + return + SwarmSchema + { schemaType = theType + , defaultValue = _default rawSchema + , objectDescription = markdownDescription <|> doc . plain . text <$> _name rawSchema + , examples = fromMaybe [] $ _examples rawSchema + , properties = _properties rawSchema + , itemsDescription = _items rawSchema + } + where + maybeType = extractSchemaType rawSchema + +-- * Utilities + +-- | Recursively extract references to other schemas +extractReferences :: SwarmSchema -> Set SchemaIdReference +extractReferences s = thisRefList <> otherRefLists + where + thisRefList = Set.fromList . getSchemaReferences $ schemaType s + + otherSchemas = maybe [] M.elems $ properties s + otherRefLists = Set.unions $ map extractReferences otherSchemas diff --git a/src/swarm-doc/Swarm/Doc/Schema/Render.hs b/src/swarm-doc/Swarm/Doc/Schema/Render.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Schema/Render.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Render a markdown document fragment +-- from the Scenario JSON schema files. +module Swarm.Doc.Schema.Render where + +import Control.Arrow (left, (&&&)) +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except (except) +import Data.Aeson +import Data.List (intersperse) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map.Strict qualified as M +import Data.Maybe (fromMaybe) +import Data.Scientific (FPFormat (..), Scientific, formatScientific) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Vector qualified as V +import Swarm.Doc.Schema.Arrangement +import Swarm.Doc.Schema.Parse +import Swarm.Doc.Schema.Refined +import Swarm.Doc.Schema.SchemaType +import Swarm.Doc.Wiki.Util +import Swarm.Util (applyWhen, brackets, quote, showT) +import System.Directory (listDirectory) +import System.FilePath (splitExtension, (<.>), ()) +import Text.Pandoc +import Text.Pandoc.Builder +import Text.Pandoc.Walk (query) + +scenariosDir :: FilePath +scenariosDir = "data/scenarios" + +docFragmentsDir :: FilePath +docFragmentsDir = scenariosDir "_doc-fragments" + +schemasDir :: FilePath +schemasDir = "data/schema" + +schemaExtension :: String +schemaExtension = ".json" + +propertyColumnHeadings :: [T.Text] +propertyColumnHeadings = + [ "Key" + , "Default?" + , "Type" + , "Description" + ] + +listColumnHeadings :: [T.Text] +listColumnHeadings = + [ "Index" + , "Type" + , "Description" + ] + +makeTitleMap :: [SchemaData] -> Map SchemaIdReference T.Text +makeTitleMap = M.fromList . map (fromFilePath . schemaPath &&& title . schemaContent) + +makePandocTable :: Map SchemaIdReference T.Text -> SchemaData -> Pandoc +makePandocTable titleMap (SchemaData _ (ToplevelSchema theTitle theDescription _schema theMembers _) parsedFooters) = + setTitle (text "JSON Schema for Scenarios") $ + doc (header 3 (text theTitle)) + <> fromMaybe mempty theDescription + <> maybe mempty mkTable theMembers + <> mconcat parsedFooters + where + renderItems someStuff = case someStuff of + ItemType x -> plain $ text "List of " <> listToText titleMap (schemaType x) + ItemList xs -> + makePropsTable False listColumnHeadings titleMap + . M.fromList + $ zip (map showT [0 :: Int ..]) xs + + mkTable x = doc $ case x of + ObjectProperties props -> makePropsTable True propertyColumnHeadings titleMap props + ListMembers someStuff -> renderItems someStuff + EnumMembers enumMembers -> + simpleTable [plain $ text "Member"] $ + map (\m -> [plain $ code m]) $ + NE.toList enumMembers + +genPropsRow :: Bool -> Map SchemaIdReference T.Text -> (T.Text, SwarmSchema) -> [Blocks] +genPropsRow includeDefaultColumn titleMap (k, x) = + firstColumn : applyWhen includeDefaultColumn (defaultColumn :) tailColumns + where + firstColumn = plain $ code k + defaultColumn = maybe mempty (plain . code . renderValue) $ defaultValue x + tailColumns = + [ plain . listToText titleMap $ schemaType x + , fromList $ maybe [] (query id) $ objectDescription x + ] + +makePropsTable :: + Bool -> + [T.Text] -> + Map SchemaIdReference T.Text -> + Map T.Text SwarmSchema -> + Blocks +makePropsTable includeDefaultColumn headingsList titleMap = + simpleTable headerRow . map (genPropsRow includeDefaultColumn titleMap) . M.toList + where + headerRow = map (plain . text) headingsList + +type FileStemAndExtension = (FilePath, String) + +recombineExtension :: FileStemAndExtension -> FilePath +recombineExtension (filenameStem, fileExtension) = + filenameStem <.> fileExtension + +genMarkdown :: [SchemaData] -> Either T.Text T.Text +genMarkdown schemaThings = + pandocToText pd + where + titleMap = makeTitleMap schemaThings + pd = + mconcat $ + map (makePandocTable titleMap) $ + sortAndPruneSchemas (fromFilePath "scenario") schemaThings + +parseSchemaFile :: FileStemAndExtension -> IO (Either T.Text ToplevelSchema) +parseSchemaFile stemAndExtension = + left (prependPath . T.pack) <$> eitherDecodeFileStrict fullPath + where + prependPath = ((T.unwords ["in", quote (T.pack filename)] <> ": ") <>) + filename = recombineExtension stemAndExtension + fullPath = schemasDir filename + +loadFooterContent :: (FilePath, ToplevelSchema) -> IO SchemaData +loadFooterContent (fp, schem) = do + xs <- mapM (TIO.readFile . (scenariosDir )) $ footerPaths schem + parsedFooters <- mapM getMarkdown xs + return $ + SchemaData + fp + schem + parsedFooters + +genScenarioSchemaDocs :: IO () +genScenarioSchemaDocs = do + dirContents <- listDirectory schemasDir + let inputFiles = filter ((== schemaExtension) . snd) $ map splitExtension dirContents + xs <- mapM (sequenceA . (recombineExtension &&& parseSchemaFile)) inputFiles + + result <- runExceptT $ do + schemaTuples <- except $ traverse sequenceA xs + things <- liftIO $ mapM loadFooterContent schemaTuples + myMarkdown <- except $ genMarkdown things + docHeader <- liftIO $ TIO.readFile "data/scenarios/_doc-fragments/header.md" + liftIO . writeFile (docFragmentsDir "SCHEMA.md") . T.unpack $ docHeader <> myMarkdown + + case result of + Left e -> print $ unwords ["Failed:", T.unpack e] + Right _ -> return () + +renderValue :: Value -> T.Text +renderValue = \case + Object obj -> showT obj + Array arr -> brackets . T.intercalate ", " . map renderValue $ V.toList arr + String t -> quote t + Number num -> T.pack $ formatNumberCompact num + Bool b -> showT b + Null -> "null" + +fragmentHref :: Map SchemaIdReference T.Text -> SchemaIdReference -> T.Text +fragmentHref titleMap r@(SchemaIdReference ref) = + T.cons '#' . T.toLower . T.replace " " "-" $ x + where + x = M.findWithDefault ref r titleMap + +listToText :: Map SchemaIdReference T.Text -> SchemaType -> Inlines +listToText titleMap = \case + Simple xs -> renderAlternatives $ map code $ getList xs + Alternatives xs -> renderAlternatives $ map (listToText titleMap) xs + Reference r@(SchemaIdReference x) -> schemaLink r x + ListOf x -> listToText titleMap x <> text " list" + EnumList xs -> renderAlternatives $ NE.toList $ text <$> xs + where + renderAlternatives = mconcat . intersperse (text " or ") + schemaLink r = link (fragmentHref titleMap r) "Link to object properties" . text + +-- | +-- Strips trailing zeros and decimal point from a floating-point number +-- when possible. +-- +-- Obtained from here: https://stackoverflow.com/a/35980995/105137 +formatNumberCompact :: Scientific -> String +formatNumberCompact v + | v == 0 = "0" + | abs v < 1e-5 || abs v > 1e10 = formatScientific Exponent Nothing v + | v - fromIntegral (floor v :: Integer) == 0 = formatScientific Fixed (Just 0) v + | otherwise = formatScientific Generic Nothing v diff --git a/src/swarm-doc/Swarm/Doc/Schema/SchemaType.hs b/src/swarm-doc/Swarm/Doc/Schema/SchemaType.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Schema/SchemaType.hs @@ -0,0 +1,40 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Representation of the "type" of a schema. +module Swarm.Doc.Schema.SchemaType where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Text qualified as T +import System.FilePath (takeBaseName) + +newtype SingleOrList a = SingleOrList + { getList :: [a] + } + deriving (Eq, Ord, Show) + +instance (FromJSON a) => FromJSON (SingleOrList a) where + parseJSON x = + fmap SingleOrList $ + pure <$> parseJSON x <|> parseJSON x + +data SchemaType + = -- | A basic built-in type + Simple (SingleOrList Text) + | -- | Any one of multiple possible schema types + Alternatives [SchemaType] + | -- | A reference to a schema defined elsewhere + Reference SchemaIdReference + | -- | Members of a list, all of the given schema type + ListOf SchemaType + | EnumList (NonEmpty Text) + deriving (Eq, Ord, Show) + +newtype SchemaIdReference = SchemaIdReference Text + deriving (Eq, Ord, Show) + +fromFilePath :: FilePath -> SchemaIdReference +fromFilePath = SchemaIdReference . T.pack . takeBaseName diff --git a/src/swarm-doc/Swarm/Doc/Util.hs b/src/swarm-doc/Swarm/Doc/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Util.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Doc markup utilities +-- +-- 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 + +-- * Text operations + +wrap :: Char -> Text -> Text +wrap c = T.cons c . flip T.snoc c + +codeQuote :: Text -> Text +codeQuote = wrap '`' + +addLink :: Text -> Text -> Text +addLink l t = T.concat ["[", t, "](", l, ")"] + +-- * Common symbols + +operators :: [Const] +operators = filter Syntax.isOperator Syntax.allConst + +builtinFunctions :: [Const] +builtinFunctions = filter Syntax.isBuiltinFunction Syntax.allConst + +commands :: [Const] +commands = filter Syntax.isCmd Syntax.allConst + +-- * Other operations + +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 new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Auto-generation of cheat sheets for the wiki. +module Swarm.Doc.Wiki.Cheatsheet ( + PageAddress (..), + SheetType (..), + makeWikiPage, +) where + +import Control.Effect.Lift +import Control.Lens (view, (^.)) +import Control.Lens.Combinators (to) +import Data.Foldable (find, toList) +import Data.List (transpose) +import Data.List.Extra (enumerate) +import Data.Map.Lazy qualified as Map +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 Swarm.Doc.Schema.Render +import Swarm.Doc.Util +import Swarm.Doc.Wiki.Matrix +import Swarm.Doc.Wiki.Util +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) + +-- * Types + +-- | A configuration record holding the URLs of the various cheat +-- sheets, to facilitate cross-linking. +data PageAddress = PageAddress + { entityAddress :: Text + , commandsAddress :: Text + , capabilityAddress :: Text + , recipesAddress :: Text + } + deriving (Eq, Show) + +-- | An enumeration of the kinds of cheat sheets we can produce. +data SheetType = Entities | Terrain | Commands | CommandMatrix | Capabilities | Recipes | Scenario + deriving (Eq, Show, Enum, Bounded) + +-- * Functions + +makeWikiPage :: PageAddress -> SheetType -> IO () +makeWikiPage address s = case s of + Commands -> T.putStrLn commandsPage + CommandMatrix -> case pandocToText commandsMatrix of + Right x -> T.putStrLn x + Left x -> error $ T.unpack x + Capabilities -> simpleErrorHandle $ do + entities <- loadEntities + sendIO $ T.putStrLn $ capabilityPage address entities + Entities -> simpleErrorHandle $ do + entities <- loadEntities + sendIO $ T.putStrLn $ entitiesPage address (Map.elems $ entitiesByName entities) + Terrain -> simpleErrorHandle $ do + terrains <- loadTerrain + sendIO . T.putStrLn . T.unlines . map showT . Map.elems $ terrainByName terrains + Recipes -> simpleErrorHandle $ do + entities <- loadEntities + recipes <- loadRecipes entities + sendIO $ T.putStrLn $ recipePage address recipes + Scenario -> genScenarioSchemaDocs + +-- ---------------------------------------------------------------------------- +-- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE +-- ---------------------------------------------------------------------------- + +escapeTable :: Text -> Text +escapeTable = T.concatMap (\c -> if c == '|' then T.snoc "\\" c else T.singleton c) + +separatingLine :: [Int] -> Text +separatingLine ws = T.cons '|' . T.concat $ map (flip T.snoc '|' . flip T.replicate "-" . (2 +)) ws + +listToRow :: [Int] -> [Text] -> Text +listToRow mw xs = wrap '|' . T.intercalate "|" $ zipWith format mw xs + where + format w x = wrap ' ' x <> T.replicate (w - T.length x) " " + +maxWidths :: [[Text]] -> [Int] +maxWidths = map (maximum . map T.length) . transpose + +-- ** COMMANDS + +commandHeader :: [Text] +commandHeader = ["Syntax", "Type", "Capability", "Description"] + +commandToList :: Const -> [Text] +commandToList c = + map + escapeTable + [ addLink ("#" <> showT c) . codeQuote $ constSyntax c + , codeQuote . prettyTextLine $ inferConst c + , maybe "" Capability.capabilityName $ Capability.constCaps c + , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c + ] + +constTable :: [Const] -> Text +constTable cs = T.unlines $ header <> map (listToRow mw) commandRows + where + mw = maxWidths (commandHeader : commandRows) + commandRows = map commandToList cs + header = [listToRow mw commandHeader, separatingLine mw] + +commandToSection :: Const -> Text +commandToSection c = + T.unlines $ + [ "## " <> T.pack (show c) + , "" + , "- syntax: " <> codeQuote (constSyntax c) + , "- type: " <> (codeQuote . prettyText $ inferConst c) + , maybe "" (("- required capabilities: " <>) . Capability.capabilityName) $ Capability.constCaps c + , "" + , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c + ] + <> let l = Syntax.longDoc . Syntax.constDoc $ Syntax.constInfo c + in if T.null l then [] else ["", l] + +commandsPage :: Text +commandsPage = + T.intercalate "\n\n" $ + [ "# Commands" + , constTable commands + , "# Builtin functions" + , "These functions are evaluated immediately once they have enough arguments." + , constTable builtinFunctions + , "# Operators" + , constTable operators + , "# Detailed descriptions" + ] + <> map commandToSection (commands <> builtinFunctions <> operators) + +-- ** CAPABILITIES + +capabilityHeader :: [Text] +capabilityHeader = ["Name", "Commands", "Entities"] + +capabilityRow :: PageAddress -> EntityMap -> Capability -> [Text] +capabilityRow PageAddress {..} em cap = + map + escapeTable + [ Capability.capabilityName cap + , T.intercalate ", " (linkCommand <$> cs) + , T.intercalate ", " (linkEntity . view entityName <$> es) + ] + where + linkEntity t = + if T.null entityAddress + then t + else addLink (entityAddress <> "#" <> T.replace " " "-" t) t + linkCommand c = + ( if T.null commandsAddress + then id + else addLink (commandsAddress <> "#" <> showT c) + ) + . codeQuote + $ constSyntax c + + cs = [c | c <- Syntax.allConst, let mcap = Capability.constCaps c, isJust $ find (== cap) mcap] + es = E.devicesForCap cap em + +capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text +capabilityTable a em cs = T.unlines $ header <> map (listToRow mw) capabilityRows + where + mw = maxWidths (capabilityHeader : capabilityRows) + capabilityRows = map (capabilityRow a em) cs + header = [listToRow mw capabilityHeader, separatingLine mw] + +capabilityPage :: PageAddress -> EntityMap -> Text +capabilityPage a em = capabilityTable a em enumerate + +-- ** Entities + +entityHeader :: [Text] +entityHeader = ["?", "Name", "Capabilities", "Properties*", "Pickable"] + +entityToList :: Entity -> [Text] +entityToList e = + map + escapeTable + [ codeQuote . T.singleton $ e ^. entityDisplay . to displayChar + , addLink ("#" <> linkID) $ view entityName e + , T.intercalate ", " $ Capability.capabilityName <$> Map.keys (D.getMap $ view E.entityCapabilities e) + , T.intercalate ", " . map showT . filter (/= E.Pickable) $ toList props + , if E.Pickable `elem` props + then ":heavy_check_mark:" + else ":negative_squared_cross_mark:" + ] + where + props = view E.entityProperties e + linkID = T.replace " " "-" $ view entityName e + +entityTable :: [Entity] -> Text +entityTable es = T.unlines $ header <> map (listToRow mw) entityRows + where + mw = maxWidths (entityHeader : entityRows) + entityRows = map entityToList es + header = [listToRow mw entityHeader, separatingLine mw] + +entityToSection :: Entity -> Text +entityToSection e = + T.unlines $ + [ "## " <> view E.entityName e + , "" + , " - Char: " <> (codeQuote . T.singleton $ e ^. entityDisplay . to displayChar) + ] + <> [" - Properties: " <> T.intercalate ", " (map showT $ toList props) | not $ null props] + <> [" - Capabilities: " <> T.intercalate ", " (Capability.capabilityName <$> caps) | not $ null caps] + <> ["\n"] + <> [Markdown.docToMark $ view E.entityDescription e] + where + props = view E.entityProperties e + caps = S.toList $ D.getCapabilitySet $ view E.entityCapabilities e + +entitiesPage :: PageAddress -> [Entity] -> Text +entitiesPage _a es = + T.intercalate "\n\n" $ + [ "# Entities" + , "This is a quick-overview table of entities - click the name for detailed description." + , "*) As a note, most entities have the Pickable property, so we show it in a separate column." + , entityTable es + ] + <> map entityToSection es + +-- ** RECIPES + +recipeHeader :: [Text] +recipeHeader = ["In", "Out", "Required", "Time", "Weight"] + +recipeRow :: PageAddress -> Recipe Entity -> [Text] +recipeRow PageAddress {..} r = + map + escapeTable + [ T.intercalate ", " (map formatCE $ view recipeInputs r) + , T.intercalate ", " (map formatCE $ view recipeOutputs r) + , T.intercalate ", " (map formatCE $ view recipeCatalysts r) + , showT $ view recipeTime r + , showT $ view recipeWeight r + ] + where + formatCE (c, e) = T.unwords [showT c, linkEntity $ view entityName e] + linkEntity t = + if T.null entityAddress + then t + else addLink (entityAddress <> "#" <> T.replace " " "-" t) t + +recipeTable :: PageAddress -> [Recipe Entity] -> Text +recipeTable a rs = T.unlines $ header <> map (listToRow mw) recipeRows + where + mw = maxWidths (recipeHeader : recipeRows) + recipeRows = map (recipeRow a) rs + header = [listToRow mw recipeHeader, separatingLine mw] + +recipePage :: PageAddress -> [Recipe Entity] -> Text +recipePage = recipeTable diff --git a/src/swarm-doc/Swarm/Doc/Wiki/Matrix.hs b/src/swarm-doc/Swarm/Doc/Wiki/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Wiki/Matrix.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Auto-generation of command attributes matrix. +module Swarm.Doc.Wiki.Matrix where + +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Swarm.Doc.Command +import Text.Pandoc +import Text.Pandoc.Builder + +commandsMatrix :: Pandoc +commandsMatrix = + setTitle (text "Commands matrix") $ + doc (header 3 (text "Commands matrix")) + <> doc (makePropsTable ["Command", "Effects", "Actor Target", "Type"]) + +makePropsTable :: + [T.Text] -> + Blocks +makePropsTable headingsList = + simpleTable headerRow $ map genPropsRow catalogEntries + where + CommandCatalog catalogEntries = getCatalog + headerRow = map (plain . text) headingsList + +genPropsRow :: CommandEntry -> [Blocks] +genPropsRow e = + [ showCode (cmd e) + , showCode (effects e) + , showCode (hasActorTarget $ derivedAttrs e) + ] + <> NE.toList completeTypeMembers + where + showCode :: Show a => a -> Blocks + showCode = plain . code . T.pack . show + completeTypeMembers = NE.map showCode $ argTypes e diff --git a/src/swarm-doc/Swarm/Doc/Wiki/Util.hs b/src/swarm-doc/Swarm/Doc/Wiki/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-doc/Swarm/Doc/Wiki/Util.hs @@ -0,0 +1,15 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utilities for generating doc markup +module Swarm.Doc.Wiki.Util where + +import Control.Arrow (left) +import Data.Text (Text) +import Text.Pandoc + +pandocToText :: Pandoc -> Either Text Text +pandocToText = + left renderError + . runPure + . writeMarkdown (def {writerExtensions = extensionsFromList [Ext_pipe_tables]}) diff --git a/src/swarm-engine/Swarm/Effect.hs b/src/swarm-engine/Swarm/Effect.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Effect.hs @@ -0,0 +1,9 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Effect system +module Swarm.Effect ( + module X, +) +where + +import Swarm.Effect.Time as X diff --git a/src/swarm-engine/Swarm/Effect/Time.hs b/src/swarm-engine/Swarm/Effect/Time.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Effect/Time.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Time effects +module Swarm.Effect.Time where + +import Control.Algebra +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Kind (Type) +import System.Clock (Clock (Monotonic), TimeSpec, getTime) + +-- | Effect for things related to time +data Time (m :: Type -> Type) k where + GetNow :: Time m TimeSpec + +getNow :: Has Time sig m => m TimeSpec +getNow = send GetNow + +newtype TimeIOC m a = TimeIOC {runTimeIO :: m a} + deriving newtype (Applicative, Functor, Monad, MonadIO) + +instance (MonadIO m, Algebra sig m) => Algebra (Time :+: sig) (TimeIOC m) where + alg hdl sig ctx = case sig of + L GetNow -> (<$ ctx) <$> liftIO (System.Clock.getTime System.Clock.Monotonic) + R other -> TimeIOC (alg (runTimeIO . hdl) other ctx) diff --git a/src/swarm-engine/Swarm/Game/Achievement/Attainment.hs b/src/swarm-engine/Swarm/Game/Achievement/Attainment.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Achievement/Attainment.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Achievements player obtained +-- +-- Metadata about achievements that the player has obtained. +module Swarm.Game.Achievement.Attainment ( + Attainment (..), + achievement, + maybeScenarioPath, + obtainedAt, +) where + +import Control.Lens hiding (from, (<.>)) +import Data.Aeson ( + Options (..), + defaultOptions, + genericParseJSON, + genericToJSON, + ) +import Data.Function (on) +import Data.Time (ZonedTime, zonedTimeToUTC) +import Data.Yaml as Y +import GHC.Generics (Generic) +import Swarm.Game.Achievement.Definitions + +-- | A record holding an achievement along with some metadata to +-- record the time at which the achievement was obtained, and the +-- scenario in which it was achieved. +data Attainment = Attainment + { _achievement :: CategorizedAchievement + -- ^ The achievement. + , _maybeScenarioPath :: Maybe FilePath + -- ^ From which scenario was it obtained? + , _obtainedAt :: ZonedTime + -- ^ What time was it obtained? + } + deriving (Generic) + +makeLenses ''Attainment + +instance Eq Attainment where + (==) = (==) `on` _achievement + +instance Ord Attainment where + compare = compare `on` (zonedTimeToUTC . _obtainedAt) + +instance Semigroup Attainment where + (<>) = min + +instance FromJSON Attainment where + parseJSON = genericParseJSON achievementJsonOptions + +instance ToJSON Attainment where + toJSON = genericToJSON achievementJsonOptions + +achievementJsonOptions :: Options +achievementJsonOptions = + defaultOptions + { fieldLabelModifier = drop 1 -- drops leading underscore + } diff --git a/src/swarm-engine/Swarm/Game/Achievement/Description.hs b/src/swarm-engine/Swarm/Game/Achievement/Description.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Achievement/Description.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Flavor text +-- +-- Flavor text about all defined achievements. +module Swarm.Game.Achievement.Description where + +import Swarm.Game.Achievement.Definitions + +-- | Function mapping each 'CategorizedAchievement' to an appropriate +-- 'AchievementInfo' record. This function must be updated whenever +-- a new type of achievement is added. +describe :: CategorizedAchievement -> AchievementInfo +describe = \case + GlobalAchievement CompletedSingleTutorial -> + AchievementInfo + "Welcome Freshmen" + (Just $ Freeform "School is in session!") + "Complete one of the tutorials." + Easy + False + GlobalAchievement CompletedAllTutorials -> + AchievementInfo + "Autodidact" + ( Just $ + FTQuotation $ + Quotation + "Terry Pratchet" + "I didn't go to university... But I have sympathy for those who did." + ) + "Complete all of the tutorials." + Moderate + False + GlobalAchievement LookedAtAboutScreen -> + AchievementInfo + "About time!" + Nothing + "View the About screen." + Trivial + True + GameplayAchievement CraftedBitcoin -> + -- Bitcoin is the deepest level of the recipes + -- hierarchy. + AchievementInfo + "Master of Your Craft" + Nothing + "Make a Bitcoin" + Moderate + True + GameplayAchievement RobotIntoWater -> + AchievementInfo + "Watery Grave" + (Just $ Freeform "This little robot thinks he's a submarine.") + "Destroy a robot by sending it into the water." + Easy + True + GameplayAchievement AttemptSelfDestructBase -> + AchievementInfo + "Call of the Void" + (Just $ Freeform "What does that big red button do?") + "Attempt to self-destruct your base." + Easy + True + GameplayAchievement DestroyedBase -> + AchievementInfo + "That Could Have Gone Better" + (Just $ Freeform "Boom.") + "Actually destroy your base." + Moderate + True + GameplayAchievement LoseScenario -> + AchievementInfo + "Silver Lining" + (Just $ Freeform "Here's your consolation prize.") + "Lose at a scenario." + Easy + True + GameplayAchievement GetDisoriented -> + AchievementInfo + "Playing Ostrich" + ( Just $ + FTQuotation $ + Quotation + "Lil Jon" + "Fire up that loud / Another round of shots / Turn down for what?" + ) + "`turn down` without a compass. Congratulations, you are \"disoriented\". How are you supposed to move now?" + Easy + True + GameplayAchievement SwapSame -> + AchievementInfo + "Fair Trade" + (Just $ Freeform "The *Law of Equivalent Exchange*... taken literally.") + "`swap` an item for itself." + Easy + True + GameplayAchievement GaveToSelf -> + AchievementInfo + "Treat. Yo. Self." + (Just $ FTQuotation $ Quotation "Tom, Parks and Recreation" "Fragrances. Massages. Treat yourself. Mimosas. Fine leather goods...It's the best day of the year.") + "`give` something to your`self`." + Easy + True + +-- | Validity conditions are required if-and-only-if the achievement +-- category is 'GameplayAchievement'. +getValidityRequirements :: GameplayAchievement -> ValidityConditions +getValidityRequirements = \case + CraftedBitcoin -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode + RobotIntoWater -> ValidityConditions OnlyPlayerRobot ValidInCreativeMode + AttemptSelfDestructBase -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode + DestroyedBase -> ValidityConditions OnlyPlayerRobot ValidInCreativeMode + LoseScenario -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode + GetDisoriented -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode + SwapSame -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode + GaveToSelf -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode diff --git a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs @@ -0,0 +1,57 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Achievements load/save +-- +-- Load/save logic for achievements. +-- Each achievement is saved to its own file to better +-- support forward-compatibility. +module Swarm.Game.Achievement.Persistence where + +import Control.Arrow (left) +import Control.Effect.Accum +import Control.Effect.Lift +import Control.Monad (forM_) +import Data.Sequence (Seq) +import Data.Yaml qualified as Y +import Swarm.Game.Achievement.Attainment +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Failure +import Swarm.Game.ResourceLoading (getSwarmAchievementsPath) +import Swarm.Util.Effect (forMW) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (()) + +-- | Load saved info about achievements from XDG data directory. +-- Returns a list of attained achievements. +loadAchievementsInfo :: + (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => + m [Attainment] +loadAchievementsInfo = do + savedAchievementsPath <- sendIO $ getSwarmAchievementsPath False + doesParentExist <- sendIO $ doesDirectoryExist savedAchievementsPath + if doesParentExist + then do + contents <- sendIO $ listDirectory savedAchievementsPath + forMW contents $ \p -> do + let fullPath = savedAchievementsPath p + isFile <- sendIO $ doesFileExist fullPath + if isFile + then do + eitherDecodedFile <- sendIO (Y.decodeFileEither fullPath) + return $ left (AssetNotLoaded Achievement p . CanNotParseYaml) eitherDecodedFile + else return . Left $ AssetNotLoaded Achievement p (EntryNot File) + else do + return [] + +-- | Save info about achievements to XDG data directory. +saveAchievementsInfo :: + [Attainment] -> + IO () +saveAchievementsInfo attainmentList = do + savedAchievementsPath <- getSwarmAchievementsPath True + forM_ attainmentList $ \x -> do + let achievementName = case _achievement x of + GlobalAchievement y -> show y + GameplayAchievement y -> show y + fullPath = savedAchievementsPath achievementName + Y.encodeFile fullPath x diff --git a/src/swarm-engine/Swarm/Game/CESK.hs b/src/swarm-engine/Swarm/Game/CESK.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/CESK.hs @@ -0,0 +1,464 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: State machine of Swarm's interpreter +-- +-- The Swarm interpreter uses a technique known as a +-- (if +-- you want to read up on them, you may want to start by reading about +-- +-- first). Execution happens simply by iterating a step function, +-- sending one state of the CESK machine to the next. In addition to +-- being relatively efficient, this means we can easily run a bunch of +-- robots synchronously, in parallel, without resorting to any threads +-- (by stepping their machines in a round-robin fashion); pause and +-- single-step the game; save and resume, and so on. +-- +-- Essentially, a CESK machine state has four components: +-- +-- - The __C__ontrol is the thing we are currently focused on: +-- either a 'Term' to evaluate, or a 'Value' that we have +-- just finished evaluating. +-- - The __E__nvironment ('Env') is a mapping from variables that might +-- occur free in the Control to their values. +-- - The __S__tore ('Store') is a mapping from abstract integer +-- /locations/ to values. We use it to store delayed (lazy) values, +-- so they will be computed at most once. +-- - The __K__ontinuation ('Cont') is a stack of 'Frame's, +-- representing the evaluation context, /i.e./ what we are supposed +-- to do after we finish with the currently focused thing. When we +-- reduce the currently focused term to a value, the top frame on +-- the stack tells us how to proceed. +-- +-- You can think of a CESK machine as a defunctionalization of a +-- recursive big-step interpreter, where we explicitly keep track of +-- the call stack and the environments that would be in effect at +-- various places in the recursion. One could probably even derive +-- this mechanically, by writing a recursive big-step interpreter, +-- then converting it to CPS, then defunctionalizing the +-- continuations. +-- +-- The slightly confusing thing about CESK machines is how we +-- have to pass around environments everywhere. Basically, +-- anywhere there can be unevaluated terms containing free +-- variables (in values, in continuation stack frames, ...), we +-- have to store the proper environment alongside so that when +-- we eventually get around to evaluating it, we will be able to +-- pull out the environment to use. +module Swarm.Game.CESK ( + -- * Frames and continuations + Frame (..), + Cont, + + -- ** Wrappers for creating delayed change of state + WorldUpdate (..), + RobotUpdate (..), + + -- * Store + Store, + Addr, + emptyStore, + allocate, + resolveValue, + lookupStore, + setStore, + + -- * CESK machine states + CESK (..), + + -- ** Construction + initMachine, + continue, + cancel, + prepareTerm, + + -- ** Extracting information + finalValue, + suspendedEnv, + store, + cont, +) where + +import Control.Lens (Lens', Traversal', lens, traversal, (^.)) +import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IM +import GHC.Generics (Generic) +import Prettyprinter (Doc, Pretty (..), encloseSep, hsep, (<+>)) +import Swarm.Game.Entity (Entity) +import Swarm.Game.Exception +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.Util.JSON (optionsMinimize) + +------------------------------------------------------------ +-- Frames and continuations +------------------------------------------------------------ + +-- | A frame is a single component of a continuation stack, explaining +-- what to do next after we finish evaluating the currently focused +-- term. +data Frame + = -- | We were evaluating the first component of a pair; next, we + -- should evaluate the second component which was saved in this + -- frame (and push a 'FFst' frame on the stack to save the first component). + FSnd Term Env + | -- | We were evaluating the second component of a pair; when done, + -- we should combine it with the value of the first component saved + -- in this frame to construct a fully evaluated pair. + FFst Value + | -- | @FArg t e@ says that we were evaluating the left-hand side of + -- an application, so the next thing we should do is evaluate the + -- term @t@ (the right-hand side, /i.e./ argument of the + -- application) in environment @e@. We will also push an 'FApp' + -- frame on the stack. + FArg Term Env + | -- | @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@. + FApp Value + | -- | @FLet x ty t2 e@ says that we were evaluating a term @t1@ of + -- type @ty@ in an expression of the form @let x = t1 in t2@, that + -- is, we were evaluating the definition of @x@; the next thing we + -- should do is evaluate @t2@ in the environment @e@ extended with + -- a binding for @x@. + FLet Var (Maybe (Polytype, Requirements)) Term Env + | -- | We are executing inside a 'Try' block. If an exception is + -- raised, we will execute the stored term (the "catch" block). + FTry Value + | -- | An @FExec@ frame means the focused value is a command, which + -- we should now execute. + FExec + | -- | We are in the process of executing the first component of a + -- bind; once done, we should also execute the second component + -- in the given environment (extended by binding the variable, + -- if there is one, to the output of the first command). + FBind (Maybe Var) (Maybe (Polytype, Requirements)) Term Env + | -- | Apply specific updates to the world and current robot. + -- + -- The 'Const' is used to track the original command for error messages. + FImmediate Const [WorldUpdate Entity] [RobotUpdate] + | -- | Update the cell at a certain location in the store with the computed value. + FUpdate Addr + | -- | Signal that we are done with an atomic computation. + FFinishAtomic + | -- | We are in the middle of evaluating a record: some fields have + -- already been evaluated; we are focusing on evaluating one + -- field; and some fields have yet to be evaluated. + FRcd Env [(Var, Value)] Var [(Var, Maybe Term)] + | -- | We are in the middle of evaluating a record field projection. + FProj Var + | -- | We should suspend with the given environment once we finish + -- the current evaluation. + FSuspend Env + | -- | 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) + +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] + +------------------------------------------------------------ +-- Store +------------------------------------------------------------ + +type Addr = Int + +-- | '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) + +emptyStore :: Store +emptyStore = Store 0 IM.empty + +-- | Allocate a new memory cell containing a given value. Return the +-- index of the allocated cell. +allocate :: Value -> Store -> (Addr, Store) +allocate v (Store n m) = (n, Store (n + 1) (IM.insert n v m)) + +-- | Resolve a value, recursively looking up any indirections in the +-- store. +resolveValue :: Store -> Value -> Either Addr Value +resolveValue s = \case + VIndir loc -> lookupStore s loc + v -> Right v + +-- | Look up the value at a given index, but keep following +-- indirections until encountering a value that is not a 'VIndir'. +lookupStore :: Store -> Addr -> Either Addr Value +lookupStore s = go + where + go loc = case IM.lookup loc (mu s) of + Nothing -> Left loc + Just v -> case v of + VIndir loc' -> go loc' + _ -> Right v + +-- | Set the value at a given index. +setStore :: Addr -> Value -> Store -> Store +setStore n c (Store nxt m) = Store nxt (IM.insert n c m) + +------------------------------------------------------------ +-- CESK machine +------------------------------------------------------------ + +-- | The overall state of a CESK machine, which can actually be one of +-- four kinds of states. The CESK machine is named after the first +-- kind of state, and it would probably be possible to inline a +-- bunch of things and get rid of the second state, but I find it +-- much more natural and elegant this way. Most tutorial +-- presentations of CEK/CESK machines only have one kind of state, but +-- then again, most tutorial presentations only deal with the bare +-- lambda calculus, so one can tell whether a term is a value just +-- by seeing whether it is syntactically a lambda. I learned this +-- approach from Harper's Practical Foundations of Programming +-- Languages. +data CESK + = -- | When we are on our way "in/down" into a term, we have a + -- currently focused term to evaluate in the environment, a store, + -- and a continuation. In this mode we generally pattern-match on the + -- 'Term' to decide what to do next. + In Term Env Store Cont + | -- | Once we finish evaluating a term, we end up with a 'Value' + -- and we switch into "out" mode, bringing the value back up + -- out of the depths to the context that was expecting it. In + -- this mode we generally pattern-match on the 'Cont' to decide + -- what to do next. + -- + -- Note that there is no 'Env', because we don't have anything + -- with variables to evaluate at the moment, and we maintain the + -- invariant that any unevaluated terms buried inside a 'Value' + -- or 'Cont' must carry along their environment with them. + Out Value Store Cont + | -- | An exception has been raised. Keep unwinding the + -- continuation stack (until finding an enclosing 'Try' in the + -- case of a command failure or a user-generated exception, or + -- until the stack is empty in the case of a fatal exception). + Up Exn Store Cont + | -- | The machine is waiting for the game to reach a certain time + -- to resume its execution. + Waiting TickNumber CESK + | -- | The machine is suspended, i.e. waiting for another term to + -- evaluate. This happens after we have evaluated whatever the + -- user entered at the REPL and we are waiting for them to type + -- something else. Conceptually, this is like a combination of + -- 'Out' and 'In': we store a 'Value' that was just yielded by + -- 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) + +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 +{-# INLINE finalValue #-} +finalValue (Out v _ []) = Just v +finalValue (Suspended v _ _ []) = Just v +finalValue _ = Nothing + +-- | Extract the environment from a suspended CESK machine (/e.g./ to +-- use for typechecking). +suspendedEnv :: Traversal' CESK Env +suspendedEnv = traversal go + where + go :: Applicative f => (Env -> f Env) -> CESK -> f CESK + go f (Suspended v e s k) = Suspended v <$> f e <*> pure s <*> pure k + go _ cesk = pure cesk + +-- | Lens focusing on the store of a CESK machine. +store :: Lens' CESK Store +store = lens get set + where + get = \case + In _ _ s _ -> s + Out _ s _ -> s + Up _ s _ -> s + Waiting _ c -> get c + Suspended _ _ s _ -> s + set cesk s = case cesk of + In t e _ k -> In t e s k + Out v _ k -> Out v s k + Up x _ k -> Up x s k + Waiting t c -> Waiting t (set c s) + Suspended v e _ k -> Suspended v e s k + +-- | Lens focusing on the continuation of a CESK machine. +cont :: Lens' CESK Cont +cont = lens get set + where + get = \case + In _ _ _ k -> k + Out _ _ k -> k + Up _ _ k -> k + Waiting _ c -> get c + Suspended _ _ _ k -> k + set cesk k = case cesk of + In t e s _ -> In t e s k + Out v s _ -> Out v s k + Up x s _ -> Up x s k + Waiting t c -> Waiting t (set c k) + Suspended v e s _ -> Suspended v e s k + +-- | 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@. +initMachine :: TSyntax -> CESK +initMachine t = In (prepareTerm mempty t) mempty emptyStore [FExec] + +-- | Load a program into an existing robot CESK machine: either +-- continue from a suspended state, or, as a fallback, start from +-- scratch with an empty environment but the same store. +-- +-- Also insert a @suspend@ primitive at the end, so the resulting +-- term is suitable for execution by the base (REPL) robot. +continue :: TSyntax -> CESK -> CESK +continue t = \case + -- The normal case is when we are continuing from a suspended state. We: + -- + -- (1) insert a suspend call at the end of the term, so that in + -- the normal case after executing the entire term we will suspend + -- in the innermost scope, to continue executing another term + -- within that scope later. + -- + -- (2) insert a failsafe FRestoreEnv frame into the continuation + -- stack, in case execution of the term throws an exception. In + -- that case we will fall back to suspending with the original + -- environment e (any names brought into scope by executing the + -- term will be discarded). If the term succeeds, the extra + -- FRestoreEnv frame will be discarded. + Suspended _ e s k -> In (insertSuspend $ prepareTerm e t) e s (FExec : FRestoreEnv e : k) + -- 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)) + +-- | 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 +-- 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' + where + t' = eraseS t + +-- | Cancel the currently running computation. +cancel :: CESK -> CESK +cancel cesk = Up Cancel (cesk ^. store) (cesk ^. cont) + +------------------------------------------------------------ +-- Pretty printing CESK machine states +------------------------------------------------------------ + +instance PrettyPrec CESK where + prettyPrec _ = \case + In c _ _ k -> prettyCont k (11, "▶" <> ppr c <> "◀") + Out v _ k -> prettyCont k (11, "◀" <> ppr (valueToTerm v) <> "▶") + Up e _ k -> prettyCont k (11, "!" <> (pretty (formatExn mempty e) <> "!")) + Waiting t cesk -> "🕑" <> pretty t <> "(" <> ppr cesk <> ")" + Suspended v _ _ k -> prettyCont k (11, "◀" <> ppr (valueToTerm v) <> "...▶") + +-- | Take a continuation, and the pretty-printed expression which is +-- the focus of the continuation (i.e. the expression whose value +-- will be given to the continuation) along with its top-level +-- precedence, and pretty-print the whole thing. +-- +-- As much as possible, we try to print to look like an *expression* +-- with a currently focused part, that is, we print the continuation +-- from the inside out instead of as a list of frames. This makes +-- it much more intuitive to read. +prettyCont :: Cont -> (Int, Doc ann) -> Doc ann +prettyCont [] (_, inner) = inner +prettyCont (f : k) inner = prettyCont k (prettyFrame f inner) + +-- | Pretty-print a single continuation frame, given its already +-- pretty-printed focus. In particular, given a frame and its +-- "inside" (i.e. the expression or other frames being focused on, +-- whose value will eventually be passed to this frame), with the +-- precedence of the inside's top-level construct, return a +-- pretty-printed version of the entire frame along with its +-- top-level precedence. +prettyFrame :: Frame -> (Int, Doc ann) -> (Int, Doc ann) +prettyFrame f (p, inner) = case f of + FSnd t _ -> (11, "(" <> inner <> "," <+> ppr t <> ")") + FFst v -> (11, "(" <> ppr (valueToTerm v) <> "," <+> inner <> ")") + FArg t _ -> (10, pparens (p < 10) inner <+> prettyPrec 11 t) + FApp v -> (10, prettyPrec 10 (valueToTerm v) <+> pparens (p < 11) inner) + FLet x _ t _ -> (11, hsep ["let", pretty 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]) + 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 + 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) + FSuspend _ -> (10, "suspend" <+> pparens (p < 11) inner) + FRestoreEnv _ -> (10, "restore" <+> pparens (p < 11) inner) + +-- | Pretty-print a special "prefix application" frame, i.e. a frame +-- formatted like @X· inner@. Unlike typical applications, these +-- associate to the *right*, so that we can print something like @X· +-- Y· Z· inner@ with no parens. +prettyPrefix :: Doc ann -> (Int, Doc ann) -> (Int, Doc ann) +prettyPrefix pre (p, inner) = (11, pre <+> pparens (p < 11) inner) + +-------------------------------------------------------------- +-- Runtime robot update +-------------------------------------------------------------- + +-- | Enumeration of robot updates. This type is used for changes by +-- /e.g./ the @drill@ command which must be carried out at a later +-- tick. Using a first-order representation (as opposed to /e.g./ +-- just a @Robot -> Robot@ function) allows us to serialize and +-- inspect the updates. +-- +-- Note that this can not be in 'Swarm.Game.Robot' as it would create +-- a cyclic dependency. +data RobotUpdate + = -- | Add copies of an entity to the robot's inventory. + AddEntity Count Entity + | -- | Make the robot learn about an entity. + LearnEntity Entity + deriving (Eq, Ord, Show, Generic) + +instance ToJSON RobotUpdate where + toJSON = genericToJSON optionsMinimize + +instance FromJSON RobotUpdate where + parseJSON = genericParseJSON optionsMinimize diff --git a/src/swarm-engine/Swarm/Game/Exception.hs b/src/swarm-engine/Swarm/Game/Exception.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Exception.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Runtime exceptions for the Swarm language interpreter. +module Swarm.Game.Exception ( + Exn (..), + IncapableFix (..), + formatExn, + exnSeverity, + IncapableFixWords (..), + + -- * Helper functions + formatIncapable, + formatIncapableFix, +) where + +import Control.Lens ((^.)) +import Data.Aeson (FromJSON, ToJSON) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Swarm.Constant +import Swarm.Game.Achievement.Definitions +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.Util +import Witch (from) + +-- ------------------------------------------------------------------ +-- SETUP FOR DOCTEST + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Control.Lens +-- >>> import Data.Text (unpack) +-- >>> import Swarm.Language.Syntax +-- >>> import Swarm.Language.Capability +-- >>> import Swarm.Game.Entity +-- >>> import Swarm.Game.Display +-- >>> import qualified Swarm.Language.Requirements.Type as R + +-- ------------------------------------------------------------------ + +-- | Suggested way to fix things when a robot does not meet the +-- requirements to run a command. +data IncapableFix + = -- | 'Swarm.Language.Syntax.Equip' the missing device on yourself/target + FixByEquip + | -- | Add the missing device to your inventory + FixByObtainDevice + | -- | Add the missing consumables to your inventory + FixByObtainConsumables + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +-- | The type of exceptions that can be thrown by robot programs. +data Exn + = -- | Something went very wrong. This is a bug in Swarm and cannot + -- be caught by a @try@ block (but at least it will not crash + -- the entire UI). + Fatal Text + | -- | The user manually cancelled the computation (e.g. by hitting + -- Ctrl-C). This cannot be caught by a @try@ block, and results + -- in the CESK machine unwinding the stack all the way back to + -- the top level. + Cancel + | -- | An infinite loop was detected via a blackhole. This cannot + -- be caught by a @try@ block. + InfiniteLoop + | -- | A robot tried to do something for which it does not have some + -- of the required capabilities. This cannot be caught by a + -- @try@ block. Also contains the missing requirements, the + -- term that caused the problem, and a suggestion for how to fix + -- things. + Incapable IncapableFix Requirements Term + | -- | A command failed in some "normal" way (/e.g./ a 'Swarm.Language.Syntax.Move' + -- command could not move, or a 'Swarm.Language.Syntax.Grab' command found nothing to + -- grab, /etc./). Can be caught by a @try@ block. + CmdFailed Const Text (Maybe GameplayAchievement) + | -- | The user program explicitly called 'Swarm.Language.Syntax.Undefined' or 'Swarm.Language.Syntax.Fail'. Can + -- be caught by a @try@ block. + User Text + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +-- | Pretty-print an exception for displaying to the player. +formatExn :: EntityMap -> Exn -> Text +formatExn em = \case + Fatal t -> + T.unlines + [ "Fatal error: " <> t + , "Please report this as a bug at" + , "<" <> swarmRepoUrl <> "issues/new>." + ] + Cancel -> "Computation cancelled." + InfiniteLoop -> "Infinite loop detected!" + (CmdFailed c t _) -> T.concat [prettyText c, ": ", t] + (User t) -> "Player exception: " <> t + (Incapable f caps tm) -> formatIncapable em f caps tm + +exnSeverity :: Exn -> Severity +exnSeverity = \case + Fatal {} -> Critical + Cancel {} -> Info + InfiniteLoop {} -> Error + Incapable {} -> Error + CmdFailed {} -> Error + User {} -> Error + +-- ------------------------------------------------------------------ +-- INCAPABLE HELPERS +-- ------------------------------------------------------------------ + +data IncapableFixWords = IncapableFixWords + { fixVerb :: Text + , fixNoun :: Text + } + +-- | Pretty-print an 'IncapableFix': either "equip device", +-- "obtain device", or "obtain consumables". +formatIncapableFix :: IncapableFix -> IncapableFixWords +formatIncapableFix = \case + FixByEquip -> IncapableFixWords "equip" "device" + FixByObtainDevice -> IncapableFixWords "obtain" "device" + FixByObtainConsumables -> IncapableFixWords "obtain" "consumables" + +-- | Pretty print the incapable exception with an actionable suggestion +-- on how to fix it. +-- +-- >>> import Data.Either (fromRight) +-- >>> import Control.Carrier.Throw.Either (runThrow) +-- >>> import Control.Algebra (run) +-- >>> import Swarm.Game.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) +-- >>> m = fromRight mempty . run . runThrow @LoadingFailure $ buildEntityMap [w,r] +-- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByEquip cs t +-- +-- >>> incapableError (R.singletonCap CGod) (TConst As) +-- Thou shalt not utter such blasphemy: +-- '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: +-- 'appear' +-- Please equip: +-- - magic wand or the one ring +-- +-- >>> incapableError (R.singletonCap CRandom) (TConst Random) +-- Missing the random capability for: +-- 'random' +-- but no device yet provides it. See +-- https://github.com/swarm-game/swarm/issues/26 +-- +-- >>> incapableError (R.singletonInv 3 "tree") (TConst Noop) +-- You are missing required inventory for: +-- 'noop' +-- Please obtain: +-- - tree (3) +formatIncapable :: EntityMap -> IncapableFix -> Requirements -> Term -> Text +formatIncapable em f (Requirements caps _ inv) tm + | CGod `S.member` caps = + unlinesExText $ + "Thou shalt not utter such blasphemy:" + :| [ squote $ prettyText tm + , "If God in troth thou wantest to play, try thou a Creative game." + ] + | not (null capsNone) = + unlinesExText $ + "Missing the " <> capMsg <> " for:" + :| [ squote $ prettyText tm + , "but no device yet provides it. See" + , swarmRepoUrl <> "issues/26" + ] + | not (S.null caps) = + let IncapableFixWords fVerb fNoun = formatIncapableFix f + in unlinesExText + ( T.unwords ["You do not have the", fNoun, "required for:"] + :| squote (prettyText tm) + : "Please " <> fVerb <> ":" + : (("- " <>) . formatDevices <$> filter (not . null) deviceSets) + ) + | otherwise = + unlinesExText + ( "You are missing required inventory for:" + :| squote (prettyText tm) + : "Please obtain:" + : (("- " <>) . formatEntity <$> M.assocs inv) + ) + where + capList = S.toList caps + deviceSets = map (`devicesForCap` em) capList + devicePerCap = zip capList deviceSets + -- capabilities not provided by any device + capsNone = map (capabilityName . fst) $ filter (null . snd) devicePerCap + capMsg = case capsNone of + [ca] -> ca <> " capability" + cas -> "capabilities " <> T.intercalate ", " cas + formatDevices = T.intercalate " or " . map (^. entityName) + formatEntity (e, 1) = e + formatEntity (e, n) = e <> " (" <> from (show n) <> ")" + +-- | Exceptions that span multiple lines should be indented. +unlinesExText :: NonEmpty Text -> Text +unlinesExText (t :| ts) = T.unlines $ (t :) $ map (" " <>) ts diff --git a/src/swarm-engine/Swarm/Game/Robot/Activity.hs b/src/swarm-engine/Swarm/Game/Robot/Activity.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Robot/Activity.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Live activity monitoring for instantiated robots. +module Swarm.Game.Robot.Activity ( + ActivityCounts, + tickStepBudget, + tangibleCommandCount, + commandsHistogram, + lifetimeStepCount, + activityWindow, + emptyActivityCount, +) where + +import Control.Lens hiding (Const, contains) +import Data.Aeson qualified as Ae (FromJSON (..), ToJSON (..)) +import Data.Map (Map) +import GHC.Generics (Generic) +import Swarm.Game.Tick +import Swarm.Language.Syntax (Const) +import Swarm.Util.Lens (makeLensesNoSigs) +import Swarm.Util.WindowedCounter + +data ActivityCounts = ActivityCounts + { _tickStepBudget :: Int + , _tangibleCommandCount :: Int + , _commandsHistogram :: Map Const Int + , _lifetimeStepCount :: Int + , _activityWindow :: WindowedCounter TickNumber + } + deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON) + +emptyActivityCount :: ActivityCounts +emptyActivityCount = + ActivityCounts + { _tickStepBudget = 0 + , _tangibleCommandCount = 0 + , _commandsHistogram = mempty + , _lifetimeStepCount = 0 + , -- NOTE: This value was chosen experimentally. + -- TODO(#1341): Make this dynamic based on game speed. + _activityWindow = mkWindow 64 + } + +makeLensesNoSigs ''ActivityCounts + +-- | A counter that is decremented upon each step of the robot within the +-- CESK machine. Initially set to 'Swarm.Game.State.robotStepsPerTick' +-- at each new tick. +-- +-- The need for 'tickStepBudget' is a bit technical, and I hope I can +-- eventually find a different, better way to accomplish it. +-- Ideally, we would want each robot to execute a single +-- /command/ at every game tick, so that /e.g./ two robots +-- executing @move;move;move@ and @repeat 3 move@ (given a +-- suitable definition of @repeat@) will move in lockstep. +-- However, the second robot actually has to do more computation +-- than the first (it has to look up the definition of @repeat@, +-- reduce its application to the number 3, etc.), so its CESK +-- machine will take more steps. It won't do to simply let each +-- robot run until executing a command---because robot programs +-- can involve arbitrary recursion, it is very easy to write a +-- program that evaluates forever without ever executing a +-- command, which in this scenario would completely freeze the +-- UI. (It also wouldn't help to ensure all programs are +-- terminating---it would still be possible to effectively do +-- the same thing by making a program that takes a very, very +-- long time to terminate.) So instead, we allocate each robot +-- a certain maximum number of computation steps per tick +-- (defined in 'Swarm.Game.Step.evalStepsPerTick'), and it +-- suspends computation when it either executes a command or +-- reaches the maximum number of steps, whichever comes first. +-- +-- It seems like this really isn't something the robot should be +-- keeping track of itself, but that seemed the most technically +-- convenient way to do it at the time. The robot needs some +-- way to signal when it has executed a command, which it +-- currently does by setting tickStepBudget to zero. However, that +-- has the disadvantage that when tickStepBudget becomes zero, we +-- can't tell whether that happened because the robot ran out of +-- steps, or because it executed a command and set it to zero +-- manually. +tickStepBudget :: Lens' ActivityCounts Int + +-- | Total number of tangible commands executed over robot's lifetime +tangibleCommandCount :: Lens' ActivityCounts Int + +-- | Histogram of commands executed over robot's lifetime +commandsHistogram :: Lens' ActivityCounts (Map Const Int) + +-- | Total number of CESK steps executed over robot's lifetime. +-- This could be thought of as "CPU cycles" consumed, and is labeled +-- as "cycles" in the F2 dialog in the UI. +lifetimeStepCount :: Lens' ActivityCounts Int + +-- | Sliding window over a span of ticks indicating ratio of activity +activityWindow :: Lens' ActivityCounts (WindowedCounter TickNumber) diff --git a/src/swarm-engine/Swarm/Game/Robot/Concrete.hs b/src/swarm-engine/Swarm/Game/Robot/Concrete.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Robot/Concrete.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Support for instantiated robots. +module Swarm.Game.Robot.Concrete ( + -- * Lenses + machine, + activityCounts, + robotLog, + robotLogUpdated, + + -- * Query + waitingUntil, + getResult, + isActive, + wantsToStep, + + -- * Utilities + instantiateRobot, +) where + +import Control.Lens hiding (Const, contains) +import Data.Aeson qualified as Ae (Key, KeyValue, ToJSON (..), object, (.=)) +import Data.Maybe (catMaybes, fromMaybe, isNothing) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Linear +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Game.CESK qualified as C +import Swarm.Game.Display (defaultRobotDisplay, invisible) +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Robot +import Swarm.Game.Robot.Activity +import Swarm.Game.Robot.Walk (emptyExceptions) +import Swarm.Game.Tick +import Swarm.Game.Universe +import Swarm.Language.Pipeline.QQ (tmQ) +import Swarm.Language.Syntax (TSyntax) +import Swarm.Language.Value as V +import Swarm.Log + +type instance RobotMachine 'ConcreteRobot = C.CESK +type instance RobotActivity 'ConcreteRobot = ActivityCounts +type instance RobotLogMember 'ConcreteRobot = Seq LogEntry +type instance RobotLogUpdatedMember 'ConcreteRobot = Bool + +machine :: Lens' Robot C.CESK +machine = lens _machine (\r x -> r {_machine = x}) + +-- | Diagnostic and operational tracking of CESK steps or other activity +activityCounts :: Lens' Robot ActivityCounts +activityCounts = lens _activityCounts (\r x -> r {_activityCounts = x}) + +-- | The robot's own private message log, most recent message last. +-- Messages can be added both by explicit use of the 'Swarm.Language.Syntax.Log' command, +-- and by uncaught exceptions. Stored as a 'Seq' so that +-- we can efficiently add to the end and also process from beginning +-- to end. Note that updating via this lens will also set the +-- 'robotLogUpdated'. +robotLog :: Lens' Robot (Seq LogEntry) +robotLog = lens _robotLog setLog + where + setLog r newLog = + r + { _robotLog = newLog + , -- Flag the log as updated if (1) if already was, or (2) the new + -- log is a different length than the old. (This would not + -- catch updates that merely modify an entry, but we don't want + -- to have to compare the entire logs, and we only ever append + -- to logs anyway.) + _robotLogUpdated = + _robotLogUpdated r || Seq.length (_robotLog r) /= Seq.length newLog + } + +-- | Has the 'robotLog' been updated since the last time it was +-- viewed? +robotLogUpdated :: Lens' Robot Bool +robotLogUpdated = lens _robotLogUpdated (\r x -> r {_robotLogUpdated = x}) + +instance ToSample Robot where + toSamples _ = SD.singleSample sampleBase + where + sampleBase :: Robot + sampleBase = + instantiateRobot (Just $ C.initMachine [tmQ| move |]) 0 $ + mkRobot + Nothing + "base" + "The starting robot." + Nothing + zero + defaultRobotDisplay + Nothing + [] + [] + False + False + emptyExceptions + 0 + +mkMachine :: Maybe TSyntax -> C.CESK +mkMachine Nothing = C.Out VUnit C.emptyStore [] +mkMachine (Just t) = C.initMachine t + +-- | Instantiate a robot template to make it into a concrete robot, by +-- providing a robot ID. Concrete robots also require a location; +-- if the robot template didn't have a location already, just set +-- the location to (0,0) by default. If you want a different location, +-- set it via 'trobotLocation' before calling 'instantiateRobot'. +-- +-- If a machine is not supplied (i.e. 'Nothing'), will fallback to any +-- program specified in the template robot. +instantiateRobot :: Maybe C.CESK -> RID -> TRobot -> Robot +instantiateRobot maybeMachine i r = + r + { _robotID = i + , _robotLocation = fromMaybe defaultCosmicLocation $ _robotLocation r + , _activityCounts = emptyActivityCount + , _machine = fromMaybe (mkMachine $ _machine r) maybeMachine + , _robotLog = Seq.empty + , _robotLogUpdated = False + } + +(.=?) :: (Ae.KeyValue e a, Ae.ToJSON v, Eq v) => Ae.Key -> v -> v -> Maybe a +(.=?) n v defaultVal = if defaultVal /= v then Just $ n Ae..= v else Nothing + +(.==) :: (Ae.KeyValue e a, Ae.ToJSON v) => Ae.Key -> v -> Maybe a +(.==) n v = Just $ n Ae..= v + +instance Ae.ToJSON Robot where + toJSON r = + Ae.object $ + catMaybes + [ "id" .== (r ^. robotID) + , "name" .== (r ^. robotEntity . entityDisplay) + , "description" .=? (r ^. robotEntity . entityDescription) $ mempty + , "loc" .== (r ^. robotLocation) + , "dir" .=? (r ^. robotEntity . entityOrientation) $ zero + , "display" .=? (r ^. robotDisplay) $ (defaultRobotDisplay & invisible .~ sys) + , "program" .== (r ^. machine) + , "devices" .=? (map (^. _2 . entityName) . elems $ r ^. equippedDevices) $ [] + , "inventory" .=? (map (_2 %~ view entityName) . elems $ r ^. robotInventory) $ [] + , "system" .=? sys $ False + , "heavy" .=? (r ^. robotHeavy) $ False + , "log" .=? (r ^. robotLog) $ mempty + , -- debug + "capabilities" .=? (r ^. robotCapabilities) $ mempty + , "logUpdated" .=? (r ^. robotLogUpdated) $ False + , "parent" .=? (r ^. robotParentID) $ Nothing + , "createdAt" .=? (r ^. robotCreatedAt) $ 0 + , "selfDestruct" .=? (r ^. selfDestruct) $ False + , "activity" .=? (r ^. activityCounts) $ emptyActivityCount + , "runningAtomic" .=? (r ^. runningAtomic) $ False + ] + where + sys = r ^. systemRobot + +-- | The time until which the robot is waiting, if any. +waitingUntil :: Robot -> Maybe TickNumber +waitingUntil robot = + case _machine robot of + C.Waiting time _ -> Just time + _ -> Nothing + +-- | Get the result of the robot's computation if it is finished. +getResult :: Robot -> Maybe Value +{-# INLINE getResult #-} +getResult = C.finalValue . view machine + +-- | Is the robot actively in the middle of a computation? +isActive :: Robot -> Bool +{-# INLINE isActive #-} +isActive = isNothing . getResult + +-- | "Active" robots include robots that are waiting; 'wantsToStep' is +-- true if the robot actually wants to take another step right now +-- (this is a /subset/ of active robots). +wantsToStep :: TickNumber -> Robot -> Bool +wantsToStep now robot + | not (isActive robot) = False + | otherwise = maybe True (now >=) (waitingUntil robot) diff --git a/src/swarm-engine/Swarm/Game/Scenario/Objective/WinCheck.hs b/src/swarm-engine/Swarm/Game/Scenario/Objective/WinCheck.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Scenario/Objective/WinCheck.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utilities to check whether conditions are met for a game win/loss. +module Swarm.Game.Scenario.Objective.WinCheck where + +import Control.Lens (andOf, view, (^.), (^..)) +import Data.Aeson (ToJSON) +import Data.BoolExpr qualified as BE +import Data.BoolExpr.Simplify qualified as Simplify +import Data.List (partition) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Graph (getDistinctConstants) +import Swarm.Game.Scenario.Objective.Logic as L +import Swarm.Util.Lens (concatFold) + +-- | We have "won" if all of the "unwinnable" or remaining "incomplete" objectives are "optional". +didWin :: ObjectiveCompletion -> Bool +didWin = andOf ((incompleteObjectives `concatFold` unwinnableObjectives) . objectiveOptional) + +-- | We have "lost" if any of the "unwinnable" objectives are not "optional". +didLose :: ObjectiveCompletion -> Bool +didLose = not . andOf (unwinnableObjectives . objectiveOptional) + +isPrereqsSatisfied :: ObjectiveCompletion -> Objective -> Bool +isPrereqsSatisfied completions = + maybe True f . view objectivePrerequisite + where + f = BE.evalBoolExpr getTruth . L.toBoolExpr . logic + + getTruth :: ObjectiveLabel -> Bool + getTruth label = Set.member label $ completions ^. completedIDs + +isUnwinnablePrereq :: Set ObjectiveLabel -> Prerequisite ObjectiveLabel -> Bool +isUnwinnablePrereq completed = + Simplify.cannotBeTrue . Simplify.replace boolMap . L.toBoolExpr + where + boolMap = M.fromList . map (,True) . Set.toList $ completed + +isUnwinnable :: ObjectiveCompletion -> Objective -> Bool +isUnwinnable completions obj = + maybe False (isUnwinnablePrereq (completions ^. completedIDs) . logic) $ obj ^. objectivePrerequisite + +-- | The first element of the returned tuple consists of "active" objectives, +-- the second element "inactive". +partitionActiveObjectives :: ObjectiveCompletion -> ([Objective], [Objective]) +partitionActiveObjectives oc = + partition (isPrereqsSatisfied oc) $ oc ^.. incompleteObjectives + +getActiveObjectives :: ObjectiveCompletion -> [Objective] +getActiveObjectives = + fst . partitionActiveObjectives + +-- | For debugging only (via Web API) +data PrereqSatisfaction = PrereqSatisfaction + { objective :: Objective + , deps :: Set (BE.Signed ObjectiveLabel) + , prereqsSatisfied :: Bool + } + deriving (Generic, ToJSON) + +instance ToSample PrereqSatisfaction where + toSamples _ = SD.noSamples + +-- | Used only by the web interface for debugging +getSatisfaction :: ObjectiveCompletion -> [PrereqSatisfaction] +getSatisfaction oc = map f $ oc ^.. allObjectives + where + f y = + PrereqSatisfaction + y + (maybe mempty (getDistinctConstants . logic) $ y ^. objectivePrerequisite) + (isPrereqsSatisfied oc y) diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types and records for updating and retrieving +-- the best scores for a scenario. +module Swarm.Game.Scenario.Scoring.Best where + +import Control.Arrow ((&&&)) +import Control.Lens hiding (from, (<.>)) +import Data.Aeson ( + genericParseJSON, + genericToEncoding, + genericToJSON, + ) +import Data.Function (on) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Time (ZonedTime, zonedTimeToUTC) +import Data.Yaml as Y +import GHC.Generics (Generic) +import Swarm.Game.Scenario.Scoring.CodeSize +import Swarm.Game.Scenario.Scoring.ConcreteMetrics +import Swarm.Game.Scenario.Scoring.GenericMetrics +import Swarm.Util.Lens (makeLensesNoSigs) + +-- * Some orphan ZonedTime instances + +instance Eq ZonedTime where + (==) = (==) `on` zonedTimeToUTC + +instance Ord ZonedTime where + (<=) = (<=) `on` zonedTimeToUTC + +-- * High scores by various criteria + +data BestByCriteria + = BestByTime + | BestByTicks + | BestByCharCount + | BestByAstSize + deriving (Eq, Ord, Bounded, Enum, Show) + +describeCriteria :: BestByCriteria -> Text +describeCriteria = \case + BestByTime -> "time" + BestByTicks -> "ticks" + BestByCharCount -> "char count" + BestByAstSize -> "AST size" + +data ProgressStats = ProgressStats + { _scenarioStarted :: ZonedTime + -- ^ Time when the scenario was started including time zone. + , _scenarioAttemptMetrics :: AttemptMetrics + } + deriving (Eq, Ord, Show, Read, Generic) + +makeLenses ''ProgressStats + +instance FromJSON ProgressStats where + parseJSON = genericParseJSON scenarioOptions + +instance ToJSON ProgressStats where + toEncoding = genericToEncoding scenarioOptions + toJSON = genericToJSON scenarioOptions + +type ProgressMetric = Metric ProgressStats + +-- * High scores by various criteria + +data BestRecords = BestRecords + { _scenarioBestByTime :: ProgressMetric + , _scenarioBestByTicks :: ProgressMetric + , _scenarioBestByCharCount :: ProgressMetric + , _scenarioBestByAstSize :: ProgressMetric + } + deriving (Eq, Ord, Read, Generic) + +instance Show BestRecords where + show (BestRecords a b c d) = + unlines $ + map + angleBracket + [ show a + , show b + , show c + , show d + ] + where + angleBracket :: String -> String + angleBracket x = "<" <> x <> ">" + +emptyBest :: ZonedTime -> BestRecords +emptyBest t = BestRecords x x x x + where + x = Metric Attempted $ ProgressStats t emptyAttemptMetric + +updateBest :: ProgressMetric -> BestRecords -> BestRecords +updateBest newPlayMetric (BestRecords oldA oldB oldC oldD) = + BestRecords + (bestTime oldA scenarioElapsed) + (bestTime oldB scenarioElapsedTicks) + (bestSize oldC sourceTextLength) + (bestSize oldD astSize) + where + f x y = chooseBetter y newPlayMetric x + bestTime x y = f x (Just . view (scenarioAttemptMetrics . scenarioDurationMetrics . y)) + bestSize x y = f x (fmap y . view (scenarioAttemptMetrics . scenarioCodeMetrics)) + +makeLensesNoSigs ''BestRecords + +-- | The best status of the scenario, measured in real world time. +scenarioBestByTime :: Lens' BestRecords ProgressMetric + +-- | The best status of the scenario, measured in game ticks. +scenarioBestByTicks :: Lens' BestRecords ProgressMetric + +-- | The best code size of the scenario, measured in character count. +scenarioBestByCharCount :: Lens' BestRecords ProgressMetric + +-- | The best code size of the scenario, measured in AST size. +scenarioBestByAstSize :: Lens' BestRecords ProgressMetric + +instance FromJSON BestRecords where + parseJSON = genericParseJSON scenarioOptions + +instance ToJSON BestRecords where + toEncoding = genericToEncoding scenarioOptions + toJSON = genericToJSON scenarioOptions + +-- | Uses the start time of the play-attempt to de-dupe +-- records that are from the same game. The start time should +-- be sufficient to uniquely identify a game. +getBestGroups :: + BestRecords -> + [(Metric ProgressStats, NonEmpty BestByCriteria)] +getBestGroups = + rearrangeTuples . M.toList . bestToMap + where + groupByStartTime = NE.groupAllWith $ view scenarioStarted . getMetric . snd + rearrangeTuples = map (snd . NE.head &&& NE.map fst) . groupByStartTime + + bestToMap :: BestRecords -> Map BestByCriteria ProgressMetric + bestToMap (BestRecords t1 t2 s1 s2) = + M.fromList $ durationElements <> mapMaybe (traverse ensurePresent) codeSizeElements + where + durationElements = + [ (BestByTime, t1) + , (BestByTicks, t2) + ] + codeSizeElements = + [ (BestByCharCount, s1) + , (BestByAstSize, s2) + ] + + ensurePresent x = + (getMetric x ^. 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 new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs @@ -0,0 +1,40 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types and utilities to compute code size +-- in terms of textual length and AST nodes. +module Swarm.Game.Scenario.Scoring.CodeSize where + +import Control.Monad (guard) +import Data.Aeson +import Data.Data (Data) +import GHC.Generics (Generic) +import Swarm.Language.Syntax + +data CodeSizeDeterminators = CodeSizeDeterminators + { initialCode :: Maybe TSyntax + , hasUsedREPL :: Bool + } + deriving (Show) + +data ScenarioCodeMetrics = ScenarioCodeMetrics + { sourceTextLength :: Int + , astSize :: Int + } + deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON) + +codeMetricsFromSyntax :: + Data a => + Syntax' a -> + ScenarioCodeMetrics +codeMetricsFromSyntax s@(Syntax' srcLoc _ _ _) = + ScenarioCodeMetrics (charCount srcLoc) (measureAstSize s) + where + charCount :: SrcLoc -> Int + charCount NoLoc = 0 + charCount (SrcLoc start end) = end - start + +codeSizeFromDeterminator :: CodeSizeDeterminators -> Maybe ScenarioCodeMetrics +codeSizeFromDeterminator (CodeSizeDeterminators maybeInitialCode usedRepl) = do + guard $ not usedRepl + codeMetricsFromSyntax <$> maybeInitialCode diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Data types and instances for specific scoring methods +module Swarm.Game.Scenario.Scoring.ConcreteMetrics where + +import Control.Lens hiding (from, (<.>)) +import Data.Aeson +import Data.Char (toLower) +import Data.Time (NominalDiffTime) +import GHC.Generics (Generic) +import Swarm.Game.Scenario.Scoring.CodeSize +import Swarm.Game.Tick (TickNumber (..)) + +scenarioOptions :: Options +scenarioOptions = + defaultOptions + { fieldLabelModifier = map toLower . drop (length ("_scenario" :: String)) + } + +data DurationMetrics = DurationMetrics + { _scenarioElapsed :: NominalDiffTime + -- ^ Time elapsed until winning the scenario. + , _scenarioElapsedTicks :: TickNumber + -- ^ Ticks elapsed until winning the scenario. + } + deriving (Eq, Ord, Show, Read, Generic) + +makeLenses ''DurationMetrics + +emptyDurationMetric :: DurationMetrics +emptyDurationMetric = DurationMetrics 0 $ TickNumber 0 + +instance FromJSON DurationMetrics where + parseJSON = genericParseJSON scenarioOptions + +instance ToJSON DurationMetrics where + toEncoding = genericToEncoding scenarioOptions + toJSON = genericToJSON scenarioOptions + +data AttemptMetrics = AttemptMetrics + { _scenarioDurationMetrics :: DurationMetrics + , _scenarioCodeMetrics :: Maybe ScenarioCodeMetrics + -- ^ Size of the user's program. + } + deriving (Eq, Ord, Show, Read, Generic) + +emptyAttemptMetric :: AttemptMetrics +emptyAttemptMetric = AttemptMetrics emptyDurationMetric Nothing + +makeLenses ''AttemptMetrics + +instance FromJSON AttemptMetrics where + parseJSON = genericParseJSON scenarioOptions + +instance ToJSON AttemptMetrics where + toEncoding = genericToEncoding scenarioOptions + toJSON = genericToJSON scenarioOptions diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs @@ -0,0 +1,59 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Data types and functions applicable across different +-- scoring methods. +module Swarm.Game.Scenario.Scoring.GenericMetrics where + +import Data.Aeson +import Data.Ord (Down (Down)) +import GHC.Generics (Generic) +import Swarm.Util (maxOn) +import Swarm.Util.JSON (optionsUntagged) + +-- | This is a subset of the "ScenarioStatus" type +-- that excludes the "NotStarted" case. +data Progress + = Attempted + | Completed + deriving (Eq, Ord, Show, Read, Generic) + +instance FromJSON Progress where + parseJSON = genericParseJSON optionsUntagged + +instance ToJSON Progress where + toJSON = genericToJSON optionsUntagged + +data Metric a = Metric Progress a + deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON) + +getMetric :: Metric a -> a +getMetric (Metric _ x) = x + +-- | This encodes the notion of "more play is better" +-- for incomplete games (rationale: more play = more fun), +-- whereas "smaller inputs are better" for completed games. +-- +-- Since 'Maybe' has its own 'Ord' instance where +-- @Nothing < Just x@ regardless of @x@, when we want to +-- choose the minimum value we @fmap Down@ to ensure that +-- the 'Just' is selected while inverting the ordering of +-- the inner member. +chooseBetter :: + Ord a => + -- | criteria; record field extractor + (b -> Maybe a) -> + -- | x + Metric b -> + -- | y + Metric b -> + Metric b +chooseBetter criteria (Metric Attempted x) (Metric Attempted y) = + Metric Attempted $ maxOn criteria x y +chooseBetter criteria (Metric Completed x) (Metric Completed y) = + Metric Completed $ maxOn (fmap Down . criteria) x y +-- Having exhausted the possibilities where either both +-- are Completed or both are Attempted, now we can just +-- choose the Completed one. +chooseBetter _ x@(Metric Completed _) _ = x +chooseBetter _ _ y@(Metric Completed _) = y diff --git a/src/swarm-engine/Swarm/Game/Scenario/Status.hs b/src/swarm-engine/Swarm/Game/Scenario/Status.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Scenario/Status.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- High-level status of scenario play. +-- Representation of progress, logic for updating. +module Swarm.Game.Scenario.Status where + +import Control.Lens hiding (from, (<.>)) +import Data.Aeson ( + genericParseJSON, + genericToEncoding, + genericToJSON, + ) +import Data.Function (on) +import Data.Time (ZonedTime, diffUTCTime, zonedTimeToUTC) +import Data.Yaml as Y +import GHC.Generics (Generic) +import Swarm.Game.Scenario +import Swarm.Game.Scenario.Scoring.Best +import Swarm.Game.Scenario.Scoring.CodeSize +import Swarm.Game.Scenario.Scoring.ConcreteMetrics +import Swarm.Game.Scenario.Scoring.GenericMetrics +import Swarm.Game.Tick (TickNumber) +import Swarm.Game.World.Gen (Seed) +import Swarm.Util.Lens (makeLensesNoSigs) + +-- | These launch parameters are used in a number of ways: +-- +-- * Serializing the seed/script path for saves +-- * Holding parse status from form fields, including error info +-- * Carrying fully-validated launch parameters. +-- +-- Type parameters are utilized to support all of these use cases. +data ParameterizableLaunchParams code f = LaunchParams + { seedVal :: f (Maybe Seed) + , initialCode :: f (Maybe code) + } + +type SerializableLaunchParams = ParameterizableLaunchParams FilePath Identity +deriving instance Eq SerializableLaunchParams +deriving instance Ord SerializableLaunchParams +deriving instance Show SerializableLaunchParams +deriving instance Read SerializableLaunchParams +deriving instance Generic SerializableLaunchParams +deriving instance FromJSON SerializableLaunchParams +deriving instance ToJSON SerializableLaunchParams + +-- | A 'ScenarioStatus' stores the status of a scenario along with +-- appropriate metadata: 'NotStarted', or 'Played'. +-- The 'Played' status has two sub-states: 'Attempted' or 'Completed'. +data ScenarioStatus + = NotStarted + | Played + SerializableLaunchParams + ProgressMetric + BestRecords + deriving (Eq, Ord, Show, Read, Generic) + +instance FromJSON ScenarioStatus where + parseJSON = genericParseJSON scenarioOptions + +instance ToJSON ScenarioStatus where + 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) + +getLaunchParams :: ScenarioStatus -> SerializableLaunchParams +getLaunchParams = \case + NotStarted -> emptyLaunchParams + Played x _ _ -> x + +-- | 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 + , _scenarioStatus :: ScenarioStatus + } + deriving (Eq, Ord, Show, Read, Generic) + +instance FromJSON ScenarioInfo where + parseJSON = genericParseJSON scenarioOptions + +instance ToJSON ScenarioInfo where + toEncoding = genericToEncoding scenarioOptions + toJSON = genericToJSON scenarioOptions + +type ScenarioInfoPair = (Scenario, ScenarioInfo) + +makeLensesNoSigs ''ScenarioInfo + +-- | The path of the scenario, relative to @data/scenarios@. +scenarioPath :: Lens' ScenarioInfo FilePath + +-- | The status of the scenario. +scenarioStatus :: Lens' ScenarioInfo ScenarioStatus + +-- | Update the current 'ScenarioInfo' record when quitting a game. +-- +-- Note that when comparing \"best\" times, shorter is not always better! +-- As long as the scenario is not completed (e.g. some do not have win condition) +-- we consider having fun /longer/ to be better. +updateScenarioInfoOnFinish :: + CodeSizeDeterminators -> + ZonedTime -> + TickNumber -> + Bool -> + ScenarioInfo -> + ScenarioInfo +updateScenarioInfoOnFinish + csd + z + ticks + completed + si@(ScenarioInfo p prevPlayState) = case prevPlayState of + Played launchParams (Metric _ (ProgressStats start _currentPlayMetrics)) prevBestRecords -> + ScenarioInfo p $ + Played launchParams newPlayMetric $ + updateBest newPlayMetric prevBestRecords + where + el = (diffUTCTime `on` zonedTimeToUTC) z start + cs = codeSizeFromDeterminator csd + newCompletionFlag = if completed then Completed else Attempted + newPlayMetric = + Metric newCompletionFlag $ + ProgressStats start $ + AttemptMetrics (DurationMetrics el ticks) cs + _ -> si diff --git a/src/swarm-engine/Swarm/Game/Scenario/Topography/Navigation/Util.hs b/src/swarm-engine/Swarm/Game/Scenario/Topography/Navigation/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Scenario/Topography/Navigation/Util.hs @@ -0,0 +1,44 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Navigation.Util where + +import Control.Lens (view) +import Data.Function (on) +import Data.Int (Int32) +import Linear (V2) +import Swarm.Game.Location +import Swarm.Game.Robot +import Swarm.Game.Universe (Cosmic, planar) +import Swarm.Language.Syntax.Direction + +-- | +-- Computes the relative offset vector between a 'Robot' and a 'Location' +-- (presumed to be in the same subworld, though the contrary will +-- not result in failure), then re-interpret that vector based on the +-- 'Robot'\'s current orientation. +-- +-- If the robot is not oriented in a cardinal direction, returns 'Nothing'. +-- +-- = Re-orientation semantics +-- +-- Given a displacement vector @(x, y)@ where: +-- +-- * positive @x@-coordinate represents @east@ +-- * negative @x@-coordinate represents @west@ +-- * positive @y@-coordinate represents @north@ +-- * negative @y@-coordinate represents @south@ +-- +-- the re-interpreted vector @(x', y')@ becomes: +-- +-- * positive @x'@-coordinate represents @right@ +-- * negative @x'@-coordinate represents @left@ +-- * positive @y'@-coordinate represents @forward@ +-- * negative @y'@-coordinate represents @back@ +orientationBasedRelativePosition :: Robot -> Cosmic Location -> Maybe (V2 Int32) +orientationBasedRelativePosition selfRobot otherLocation = + (`applyTurn` relativeCoords) <$> maybeSelfDirRelativeToNorth + where + maybeSelfDirection = view robotOrientation selfRobot >>= toAbsDirection + maybeSelfDirRelativeToNorth = DRelative . DPlanar . relativeTo DNorth <$> maybeSelfDirection + + relativeCoords = ((.-.) `on` view planar) otherLocation (view robotLocation selfRobot) 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 new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs @@ -0,0 +1,215 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Saving and loading info about scenarios (status, path, etc.) as +-- well as loading recursive scenario collections. +module Swarm.Game.ScenarioInfo ( + -- * Scenario info + ScenarioStatus (..), + _NotStarted, + ScenarioInfo (..), + scenarioPath, + scenarioStatus, + CodeSizeDeterminators (CodeSizeDeterminators), + ScenarioInfoPair, + + -- * Scenario collection + ScenarioCollection (..), + scenarioCollectionToList, + flatten, + scenarioItemByPath, + normalizeScenarioPath, + ScenarioItem (..), + scenarioItemName, + _SISingle, + + -- ** Tutorials + tutorialsDirname, + getTutorials, + + -- * Loading and saving scenarios + loadScenarios, + loadScenarioInfo, + saveScenarioInfo, +) where + +import Control.Algebra (Has) +import Control.Carrier.Lift (runM) +import Control.Carrier.Throw.Either (runThrow) +import Control.Effect.Accum (Accum, add) +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.IO.Class (MonadIO (liftIO)) +import Data.Char (isSpace) +import Data.Either (partitionEithers) +import Data.Either.Extra (fromRight') +import Data.List (intercalate, isPrefixOf, stripPrefix, (\\)) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +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.Game.Scenario +import Swarm.Game.Scenario.Scoring.CodeSize +import Swarm.Game.Scenario.Status +import Swarm.Util.Effect (warn, withThrow) +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), ()) +import Witch (into) + +-- ---------------------------------------------------------------------------- +-- 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) + +-- | Retrieve the name of a scenario item. +scenarioItemName :: ScenarioItem -> Text +scenarioItemName (SISingle (s, _ss)) = s ^. scenarioMetadata . scenarioName +scenarioItemName (SICollection name _) = name + +-- | A scenario collection is a tree of scenarios, keyed by name, +-- together with an optional order. +-- +-- /Invariant:/ every item in the +-- 'scOrder' exists as a key in the 'scMap'. +data ScenarioCollection = SC + { scOrder :: Maybe [FilePath] + , scMap :: Map FilePath ScenarioItem + } + deriving (Show) + +-- | Access and modify 'ScenarioItem's in collection based on their path. +scenarioItemByPath :: FilePath -> Traversal' ScenarioCollection ScenarioItem +scenarioItemByPath path = ixp ps + where + ps = splitDirectories path + ixp :: (Applicative f) => [String] -> (ScenarioItem -> f ScenarioItem) -> ScenarioCollection -> f ScenarioCollection + 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 + where + inner si = case si of + SISingle {} -> pure si + SICollection n' col -> SICollection n' <$> ixp xs f col + +-- | Subdirectory of the scenarios directory where tutorials are stored. +tutorialsDirname :: FilePath +tutorialsDirname = "Tutorials" + +-- | Extract just the collection of tutorial scenarios from the entire +-- scenario collection. +getTutorials :: ScenarioCollection -> ScenarioCollection +getTutorials sc = case M.lookup tutorialsDirname (scMap sc) of + Just (SICollection _ c) -> c + _ -> error $ "No tutorials exist: " ++ show sc + +-- | Canonicalize a scenario path, making it usable as a unique key. +normalizeScenarioPath :: + (MonadIO m) => + ScenarioCollection -> + FilePath -> + m FilePath +normalizeScenarioPath col p = + let path = p -<.> "yaml" + in if isJust $ col ^? scenarioItemByPath path + 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 + 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 + +flatten :: ScenarioItem -> [ScenarioInfoPair] +flatten (SISingle p) = [p] +flatten (SICollection _ c) = concatMap flatten $ scenarioCollectionToList c + +-- | Load all the scenarios from the scenarios data directory. +loadScenarios :: + (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => + ScenarioInputs -> + m ScenarioCollection +loadScenarios scenarioInputs = do + res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios" + case res of + Left err -> do + warn err + return $ SC mempty mempty + Right dataDir -> loadScenarioDir scenarioInputs 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) + +-- | Recursively load all scenarios from a particular directory, and also load +-- the 00-ORDER file (if any) giving the order for the scenarios. +loadScenarioDir :: + (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => + ScenarioInputs -> + 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 + + forM_ (NE.nonEmpty dangling) $ + warn + . OrderFileWarning (dirName orderFileName) + . DanglingFiles + Nothing -> pure () + + -- 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 + + -- Whether the directory or file should be included in the scenario catalog. + isCatalogEntry d f = do + isDir <- doesDirectoryExist $ d f + return $ + if isDir + then not $ "_" `isPrefixOf` f + else takeExtensions f == ".yaml" + +-- | How to transform scenario path to save path. +scenarioPathToSavePath :: FilePath -> FilePath -> FilePath +scenarioPathToSavePath path swarmData = swarmData Data.List.intercalate "_" (splitDirectories path) + +-- | Load saved info about played scenario from XDG data directory. +loadScenarioInfo :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + FilePath -> + m ScenarioInfo +loadScenarioInfo p = do + path <- sendIO $ normalizeScenarioPath (SC Nothing mempty) 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 + +-- | Save info about played scenario to XDG data directory. +saveScenarioInfo :: + FilePath -> + ScenarioInfo -> + IO () +saveScenarioInfo path si = do + infoPath <- scenarioPathToSavePath path <$> getSwarmSavePath True + encodeFile infoPath si + +-- | Load a scenario item (either a scenario, or a subdirectory +-- containing a collection of scenarios) from a particular path. +loadScenarioItem :: + ( Has (Throw SystemFailure) sig m + , Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + ScenarioInputs -> + FilePath -> + m ScenarioItem +loadScenarioItem scenarioInputs path = do + isDir <- sendIO $ doesDirectoryExist path + let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path + case isDir of + True -> SICollection collectionName <$> loadScenarioDir scenarioInputs path + False -> do + s <- loadScenarioFile scenarioInputs path + eitherSi <- runThrow @SystemFailure (loadScenarioInfo path) + case eitherSi of + Right si -> return $ SISingle (s, si) + Left warning -> do + warn warning + return $ SISingle (s, ScenarioInfo path NotStarted) + +------------------------------------------------------------ +-- Some lenses + prisms +------------------------------------------------------------ + +makePrisms ''ScenarioItem +makePrisms ''ScenarioStatus diff --git a/src/swarm-engine/Swarm/Game/State.hs b/src/swarm-engine/Swarm/Game/State.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/State.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Game-related state and utilities +-- +-- Definition of the record holding all the game-related state, and various related +-- utility functions. +module Swarm.Game.State ( + -- * Game state record + GameState, + creativeMode, + winCondition, + winSolution, + + -- ** Launch parameters + LaunchParams, + ValidatedLaunchParams, + + -- *** Subrecord accessors + temporal, + robotNaming, + recipesInfo, + messageInfo, + gameControls, + randomness, + discovery, + landscape, + robotInfo, + pathCaching, + + -- ** GameState initialization + initGameState, + CodeToRun (..), + Sha1 (..), + SolutionSource (..), + parseCodeFile, + + -- * Utilities + robotsAtLocation, + robotsInArea, + baseRobot, + baseEnv, + baseStore, + messageNotifications, + currentScenarioPath, + needsRedraw, + replWorking, + recalcViewCenterAndRedraw, + viewingRegion, + focusedRobot, + RobotRange (..), + focusedRange, + getRadioRange, + clearFocusedRobotLogUpdated, + emitMessage, + messageIsRecent, + messageIsFromNearby, + getRunCodePath, + buildWorldTuples, + genMultiWorld, + genRobotTemplates, + entityAt, + contentAt, + zoomWorld, + zoomRobots, +) where + +import Control.Carrier.State.Lazy qualified as Fused +import Control.Effect.Lens +import Control.Effect.Lift +import Control.Effect.State (State) +import Control.Effect.Throw +import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) +import Control.Monad (forM, join) +import Data.Aeson (ToJSON) +import Data.Digest.Pure.SHA (sha1, showDigest) +import Data.Foldable (toList) +import Data.Function (on) +import Data.Int (Int32) +import Data.IntMap qualified as IM +import Data.IntSet qualified as IS +import Data.Map qualified as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Sequence (Seq ((:<|))) +import Data.Sequence qualified as Seq +import Data.Text (Text) +import Data.Text qualified as T (drop, take) +import Data.Text.IO qualified as TIO +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TL +import GHC.Generics (Generic) +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.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Step.Path.Type +import Swarm.Game.Terrain +import Swarm.Game.Tick (addTicks) +import Swarm.Game.Universe as U +import Swarm.Game.World qualified as W +import Swarm.Game.World.Coords +import Swarm.Language.Pipeline (processTermEither) +import Swarm.Language.Syntax (SrcLoc (..), TSyntax, sLoc) +import Swarm.Language.Value (Env) +import Swarm.Log +import Swarm.Util (uniq) +import Swarm.Util.Lens (makeLensesNoSigs) + +newtype Sha1 = Sha1 String + deriving (Show, Eq, Ord, Generic, ToJSON) + +data SolutionSource + = ScenarioSuggested + | -- | Includes the SHA1 of the program text + -- for the purpose of corroborating solutions + -- on a leaderboard. + PlayerAuthored FilePath Sha1 + +data CodeToRun = CodeToRun SolutionSource TSyntax + +getRunCodePath :: CodeToRun -> Maybe FilePath +getRunCodePath (CodeToRun solutionSource _) = case solutionSource of + ScenarioSuggested -> Nothing + PlayerAuthored fp _ -> Just fp + +parseCodeFile :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + FilePath -> + m CodeToRun +parseCodeFile filepath = do + contents <- sendIO $ TIO.readFile filepath + pt <- either (throwError . CustomFailure) return (processTermEither contents) + + let srcLoc = pt ^. sLoc + strippedText = stripSrc srcLoc contents + programBytestring = TL.encodeUtf8 $ TL.fromStrict strippedText + sha1Hash = showDigest $ sha1 programBytestring + return $ CodeToRun (PlayerAuthored filepath $ Sha1 sha1Hash) pt + where + stripSrc :: SrcLoc -> Text -> Text + stripSrc (SrcLoc start end) txt = T.drop start $ T.take end txt + stripSrc NoLoc txt = txt + +------------------------------------------------------------ +-- The main GameState record type +------------------------------------------------------------ + +-- | The main record holding the state for the game itself (as +-- distinct from the UI). See the lenses below for access to its +-- fields. +data GameState = GameState + { _creativeMode :: Bool + , _temporal :: TemporalState + , _winCondition :: WinCondition + , _winSolution :: Maybe TSyntax + , _robotInfo :: Robots + , _pathCaching :: PathCaching + , _discovery :: Discovery + , _randomness :: Randomness + , _recipesInfo :: Recipes + , _currentScenarioPath :: Maybe FilePath + , _landscape :: Landscape + , _needsRedraw :: Bool + , _gameControls :: GameControls + , _messageInfo :: Messages + } + +makeLensesNoSigs ''GameState + +------------------------------------------------------------ +-- Lenses +------------------------------------------------------------ + +-- | Is the user in creative mode (i.e. able to do anything without restriction)? +creativeMode :: Lens' GameState Bool + +-- | Aspects of the temporal state of the game +temporal :: Lens' GameState TemporalState + +-- | How to determine whether the player has won. +winCondition :: Lens' GameState WinCondition + +-- | How to win (if possible). This is useful for automated testing +-- and to show help to cheaters (or testers). +winSolution :: Lens' GameState (Maybe TSyntax) + +-- | Get a list of all the robots at a particular location. +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) + . view (robotInfo . robotsByLocation) + $ gs + +-- | Registry for caching output of the @path@ command +pathCaching :: Lens' GameState PathCaching + +-- | 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 + where + rm = rs ^. robotMap + rl = rs ^. robotsByLocation + rids = + concatMap IS.elems $ + getElemsInArea o d $ + M.findWithDefault mempty subworldName rl + +-- | The base robot, if it exists. +baseRobot :: Traversal' GameState Robot +baseRobot = robotInfo . robotMap . ix 0 + +-- | The base robot environment. +baseEnv :: Traversal' GameState Env +baseEnv = baseRobot . machine . suspendedEnv + +-- | The base robot store, or the empty store if there is no base robot. +baseStore :: Getter GameState Store +baseStore = to $ \g -> case g ^? baseRobot . machine of + Nothing -> emptyStore + Just m -> m ^. store + +-- | Inputs for randomness +randomness :: Lens' GameState Randomness + +-- | Discovery state of entities, commands, recipes +discovery :: Lens' GameState Discovery + +-- | Collection of recipe info +recipesInfo :: Lens' GameState Recipes + +-- | The filepath of the currently running scenario. +-- +-- This is useful as an index to the scenarios collection, +-- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'. +currentScenarioPath :: Lens' GameState (Maybe FilePath) + +-- | Info about the lay of the land +landscape :: Lens' GameState Landscape + +-- | Info about robots +robotInfo :: Lens' GameState Robots + +-- | Whether the world view needs to be redrawn. +needsRedraw :: Lens' GameState Bool + +-- | Controls, including REPL and key mapping +gameControls :: Lens' GameState GameControls + +-- | Message info +messageInfo :: Lens' GameState Messages + +------------------------------------------------------------ +-- Utilities +------------------------------------------------------------ + +-- | Get the notification list of messages from the point of view of focused robot. +messageNotifications :: Getter GameState (Notifications LogEntry) +messageNotifications = to getNotif + where + getNotif gs = + Notifications + { _notificationsCount = length new + , _notificationsShouldAlert = not (null new) + , _notificationsContent = allUniq + } + where + allUniq = uniq $ toList allMessages + 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) + 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 + -- other they have to get from log + latestMsg = messageIsRecent gs + closeMsg = messageIsFromNearby (gs ^. robotInfo . viewCenter) + generatedBy rid logEntry = case logEntry ^. leSource of + RobotLog _ rid' _ -> rid == rid' + _ -> False + + focusedOrLatestClose mq = + (Seq.take 1 . Seq.reverse . Seq.filter closeMsg $ Seq.takeWhileR latestMsg mq) + <> Seq.filter (generatedBy (gs ^. robotInfo . focusedRobotID)) mq + +messageIsRecent :: GameState -> LogEntry -> Bool +messageIsRecent gs e = addTicks 1 (e ^. leTime) >= gs ^. temporal . ticks + +-- | Reconciles the possibilities of log messages being +-- omnipresent and robots being in different worlds +messageIsFromNearby :: Cosmic Location -> LogEntry -> Bool +messageIsFromNearby l e = case e ^. leSource of + SystemLog -> True + RobotLog _ _ loc -> f loc + where + f logLoc = case cosmoMeasure manhattan l logLoc of + InfinitelyFar -> False + Measurable x -> x <= hearingDistance + +-- | Recalculate the view center (and cache the result in the +-- 'viewCenter' field) based on the current 'viewCenterRule'. If +-- the 'viewCenterRule' specifies a robot which does not exist, +-- simply leave the current 'viewCenter' as it is. Set 'needsRedraw' +-- if the view center changes. +recalcViewCenterAndRedraw :: GameState -> GameState +recalcViewCenterAndRedraw g = + g + & robotInfo .~ newRobotInfo + & (if ((/=) `on` (^. viewCenter)) oldRobotInfo newRobotInfo then needsRedraw .~ True else id) + where + oldRobotInfo = g ^. robotInfo + newRobotInfo = recalcViewCenter oldRobotInfo + +-- | Given a width and height, compute the region, centered on the +-- 'viewCenter', that should currently be in view. +viewingRegion :: Cosmic Location -> (Int32, Int32) -> Cosmic BoundsRectangle +viewingRegion (Cosmic sw (Location cx cy)) (w, h) = + Cosmic sw (Coords (rmin, cmin), Coords (rmax, cmax)) + where + (rmin, rmax) = over both (+ (-cy - h `div` 2)) (0, h - 1) + (cmin, cmax) = over both (+ (cx - w `div` 2)) (0, w - 1) + +-- | Find out which robot has been last specified by the +-- 'viewCenterRule', if any. +focusedRobot :: GameState -> Maybe Robot +focusedRobot g = g ^. robotInfo . robotMap . at (g ^. robotInfo . focusedRobotID) + +-- | Type for describing how far away a robot is from the base, which +-- determines what kind of communication can take place. +data RobotRange + = -- | Close; communication is perfect. + Close + | -- | Mid-range; communication is possible but lossy. + MidRange Double + | -- | Far; communication is not possible. + Far + deriving (Eq, Ord) + +-- | Check how far away the focused robot is from the base. @Nothing@ +-- is returned if there is no focused robot; otherwise, return a +-- 'RobotRange' value as follows. +-- +-- * If we are in creative or scroll-enabled mode, the focused robot is +-- always considered 'Close'. +-- * Otherwise, there is a "minimum radius" and "maximum radius". +-- +-- * If the robot is within the minimum radius, it is 'Close'. +-- * If the robot is between the minimum and maximum radii, it +-- is 'MidRange', with a 'Double' value ranging linearly from +-- 0 to 1 proportional to the distance from the minimum to +-- maximum radius. For example, @MidRange 0.5@ would indicate +-- a robot exactly halfway between the minimum and maximum +-- radii. +-- * If the robot is beyond the maximum radius, it is 'Far'. +-- +-- * By default, the minimum radius is 16, and maximum is 64. +-- * Device augmentations +-- +-- * If the focused robot has an @antenna@ installed, it doubles +-- both radii. +-- * If the base has an @antenna@ installed, it also doubles both radii. +focusedRange :: GameState -> Maybe RobotRange +focusedRange g = checkRange <$ maybeFocusedRobot + where + maybeBaseRobot = g ^. robotInfo . robotMap . at 0 + maybeFocusedRobot = focusedRobot g + + checkRange = case r of + InfinitelyFar -> Far + Measurable r' -> computedRange r' + + computedRange r' + | g ^. creativeMode || g ^. landscape . worldScrollable || r' <= minRadius = Close + | r' > maxRadius = Far + | otherwise = MidRange $ (r' - minRadius) / (maxRadius - minRadius) + + -- Euclidean distance from the base to the view center. + r = case maybeBaseRobot of + -- if the base doesn't exist, we have bigger problems + Nothing -> InfinitelyFar + Just br -> cosmoMeasure euclidean (g ^. robotInfo . viewCenter) (br ^. robotLocation) + + (minRadius, maxRadius) = getRadioRange maybeBaseRobot maybeFocusedRobot + +-- | Get the min/max communication radii given possible augmentations on each end +getRadioRange :: Maybe Robot -> Maybe Robot -> (Double, Double) +getRadioRange maybeBaseRobot maybeTargetRobot = + (minRadius, maxRadius) + where + -- See whether the base or focused robot have antennas installed. + baseInv, focInv :: Maybe Inventory + baseInv = view equippedDevices <$> maybeBaseRobot + focInv = view equippedDevices <$> maybeTargetRobot + + gain :: Maybe Inventory -> (Double -> Double) + gain (Just inv) + | countByName "antenna" inv > 0 = (* 2) + gain _ = id + + -- Range radii. Default thresholds are 16, 64; each antenna + -- boosts the signal by 2x. + minRadius, maxRadius :: Double + (minRadius, maxRadius) = over both (gain baseInv . gain focInv) (16, 64) + +-- | Clear the 'robotLogUpdated' flag of the focused robot. +clearFocusedRobotLogUpdated :: (Has (State Robots) sig m) => m () +clearFocusedRobotLogUpdated = do + n <- use focusedRobotID + robotMap . ix n . robotLogUpdated .= False + +maxMessageQueueSize :: Int +maxMessageQueueSize = 1000 + +-- | Add a message to the message queue. +emitMessage :: (Has (State GameState) sig m) => LogEntry -> m () +emitMessage msg = messageInfo . messageQueue %= (|> msg) . dropLastIfLong + where + tooLong s = Seq.length s >= maxMessageQueueSize + dropLastIfLong whole@(_oldest :<| newer) = if tooLong whole then newer else whole + dropLastIfLong emptyQueue = emptyQueue + +------------------------------------------------------------ +-- Initialization +------------------------------------------------------------ + +type LaunchParams a = ParameterizableLaunchParams CodeToRun a + +-- | In this stage in the UI pipeline, both fields +-- have already been validated, and "Nothing" means +-- that the field is simply absent. +type ValidatedLaunchParams = LaunchParams Identity + +-- | Create an initial, fresh game state record when starting a new scenario. +initGameState :: GameStateConfig -> GameState +initGameState gsc = + GameState + { _creativeMode = False + , _temporal = initTemporalState + , _winCondition = NoWinCondition + , _winSolution = Nothing + , _robotInfo = initRobots gsc + , _pathCaching = emptyPathCache + , _discovery = initDiscovery + , _randomness = initRandomness + , _recipesInfo = initRecipeMaps gsc + , _currentScenarioPath = Nothing + , _landscape = initLandscape gsc + , _needsRedraw = False + , _gameControls = initGameControls + , _messageInfo = initMessages + } + +-- | Get the entity (if any) at a given location. +entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity) +entityAt (Cosmic subworldName loc) = + join <$> zoomWorld subworldName (W.lookupEntityM @Int (locToCoords loc)) + +contentAt :: + (Has (State GameState) sig m) => + Cosmic Location -> + m (TerrainType, Maybe Entity) +contentAt (Cosmic subworldName loc) = do + tm <- use $ landscape . terrainAndEntities . terrainMap + val <- zoomWorld subworldName $ do + (terrIdx, maybeEnt) <- W.lookupContentM (locToCoords loc) + let terrObj = terrIdx `IM.lookup` terrainByIndex tm + return (maybe BlankT terrainName terrObj, maybeEnt) + return $ fromMaybe (BlankT, Nothing) val + +-- | Perform an action requiring a 'Robots' state component in a +-- larger context with a 'GameState'. +zoomRobots :: + (Has (State GameState) sig m) => + Fused.StateC Robots Identity b -> + m b +zoomRobots n = do + ri <- use robotInfo + do + let (ri', a) = run $ Fused.runState ri n + robotInfo .= ri' + return a + +-- | Perform an action requiring a 'W.World' state component in a +-- larger context with a 'GameState'. +zoomWorld :: + (Has (State GameState) sig m) => + SubworldName -> + Fused.StateC (W.World Int Entity) Identity b -> + m (Maybe b) +zoomWorld swName n = do + mw <- use $ landscape . multiWorld + forM (M.lookup swName mw) $ \w -> do + let (w', a) = run (Fused.runState w n) + landscape . multiWorld %= M.insert swName w' + return a diff --git a/src/swarm-engine/Swarm/Game/State/Initialize.hs b/src/swarm-engine/Swarm/Game/State/Initialize.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/State/Initialize.hs @@ -0,0 +1,223 @@ +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Game-related state and utilities +-- +-- Definition of the record holding all the game-related state, and various related +-- utility functions. +module Swarm.Game.State.Initialize ( + scenarioToGameState, + pureScenarioToGameState, +) where + +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 Data.IntMap qualified as IM +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (isNothing) +import Data.Set qualified as S +import Data.Text (Text) +import Linear (V2 (..)) +import Swarm.Game.CESK (finalValue, initMachine) +import Swarm.Game.Device (getCapabilitySet, getMap) +import Swarm.Game.Entity +import Swarm.Game.Land +import Swarm.Game.Recipe ( + catRecipeMap, + inRecipeMap, + outRecipeMap, + ) +import Swarm.Game.Robot +import Swarm.Game.Robot.Concrete +import Swarm.Game.Scenario +import Swarm.Game.Scenario.Objective (initCompletion) +import Swarm.Game.Scenario.Status +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.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.World.Gen (Seed) +import Swarm.Language.Capability (constCaps) +import Swarm.Language.Syntax (allConst) +import Swarm.Language.Types +import Swarm.Util (binTuples, (?)) +import System.Clock qualified as Clock +import System.Random (mkStdGen) + +-- | Create an initial game state corresponding to the given scenario. +scenarioToGameState :: + Scenario -> + ValidatedLaunchParams -> + GameStateConfig -> + IO GameState +scenarioToGameState 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 + +pureScenarioToGameState :: + Scenario -> + Seed -> + Clock.TimeSpec -> + Maybe CodeToRun -> + GameStateConfig -> + GameState +pureScenarioToGameState scenario theSeed now toRun gsc = + preliminaryGameState + & discovery . structureRecognition .~ recognizer + where + sLandscape = scenario ^. scenarioLandscape + + recognizer = + runIdentity $ + Fused.evalState preliminaryGameState $ + mkRecognizer (sLandscape ^. scenarioStructures) + + gs = initGameState gsc + preliminaryGameState = + gs + & robotInfo %~ setRobotInfo baseID robotList' + & creativeMode .~ scenario ^. scenarioOperation . scenarioCreative + & winCondition .~ theWinCondition + & winSolution .~ scenario ^. scenarioOperation . scenarioSolution + & discovery . availableCommands .~ Notifications 0 False initialCommands + & discovery . knownEntities .~ sLandscape ^. scenarioKnown + & discovery . tagMembers .~ buildTagMap em + & randomness . seed .~ theSeed + & randomness . randGen .~ mkStdGen theSeed + & recipesInfo %~ modifyRecipesInfo + & landscape .~ mkLandscape sLandscape worldTuples theSeed + & gameControls . initiallyRunCode .~ 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 + True -> REPLWorking PolyUnit Nothing + & temporal . robotStepsPerTick .~ ((scenario ^. scenarioOperation . scenarioStepsPerTick) ? defaultRobotStepsPerTick) + + robotList' = (robotCreatedAt .~ now) <$> robotList + + modifyRecipesInfo oldRecipesInfo = + oldRecipesInfo + & recipesOut %~ addRecipesWith outRecipeMap + & recipesIn %~ addRecipesWith inRecipeMap + & recipesCat %~ addRecipesWith catRecipeMap + + TerrainEntityMaps _ em = sLandscape ^. scenarioTerrainAndEntities + 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 + + robotListRaw = + zipWith (instantiateRobot Nothing) [baseID ..] robotsByBasePrecedence + + robotList = + robotListRaw + -- If the --run flag was used, use it to replace the CESK machine of the + -- robot whose id is 0, i.e. the first robot listed in the scenario. + -- Note that this *replaces* any program the base robot otherwise + -- would have run (i.e. any program specified in the program: field + -- of the scenario description). + & ix baseID + . machine + %~ case initialCodeToRun of + Nothing -> id + Just t -> const $ initMachine t + -- 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)) + & ix baseID + . equippedDevices + %~ case scenario ^. scenarioOperation . scenarioCreative of + False -> id + True -> const (fromList devices) + + running = case robotList of + [] -> False + (base : _) -> isNothing (finalValue (base ^. machine)) + + -- Initial list of available commands = all commands enabled by + -- devices in inventory or equipped; and commands that require no + -- capability. + allCapabilities r = + inventoryCapabilities (r ^. equippedDevices) + <> inventoryCapabilities (r ^. robotInventory) + initialCaps = getCapabilitySet $ mconcat $ map allCapabilities robotList + initialCommands = + filter + (maybe True (`S.member` initialCaps) . constCaps) + allConst + + worldTuples = buildWorldTuples sLandscape + + theWinCondition = + maybe + NoWinCondition + (WinConditions Ongoing . initCompletion . NE.toList) + (NE.nonEmpty (scenario ^. scenarioOperation . scenarioObjectives)) + + 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 + return $ + StructureRecognizer + (mkAutomatons structDefs) + fs + [IntactStaticPlacement $ map mkLogEntry foundIntact] + where + 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) + +buildTagMap :: EntityMap -> Map Text (NonEmpty EntityName) +buildTagMap em = + binTuples expanded + where + expanded = concatMap (\(k, vs) -> [(v, k) | v <- S.toList vs]) tagsByEntity + tagsByEntity = map (view entityName &&& view entityTags) $ entityDefinitionOrder em diff --git a/src/swarm-engine/Swarm/Game/State/Robot.hs b/src/swarm-engine/Swarm/Game/State/Robot.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/State/Robot.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Robot-specific subrecords and utilities used by 'Swarm.Game.State.GameState' +module Swarm.Game.State.Robot ( + -- * Types + ViewCenterRule (..), + Robots, + + -- * Robot naming + RobotNaming, + nameGenerator, + gensym, + robotNaming, + + -- * Initialization + initRobots, + setRobotInfo, + + -- * Accessors + robotMap, + robotsByLocation, + robotsWatching, + activeRobots, + waitingRobots, + currentTickWakeableBots, + viewCenterRule, + viewCenter, + focusedRobotID, + + -- * Utilities + wakeWatchingRobots, + sleepUntil, + sleepForever, + wakeUpRobotsDoneSleeping, + deleteRobot, + removeRobotFromLocationMap, + activateRobot, + addRobot, + addRobotToLocation, + addTRobot, + addTRobot', + + -- ** View + modifyViewCenter, + unfocus, + recalcViewCenter, +) where + +import Control.Arrow (Arrow ((&&&))) +import Control.Effect.Lens +import Control.Effect.State (State) +import Control.Effect.Throw (Has) +import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) +import Control.Monad (forM_, void) +import Data.Aeson (FromJSON, ToJSON) +import Data.IntMap (IntMap) +import Data.IntMap qualified as IM +import Data.IntSet (IntSet) +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.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.Util.Lens (makeLensesExcluding) + +-- | The 'ViewCenterRule' specifies how to determine the center of the +-- world viewport. +data ViewCenterRule + = -- | The view should be centered on an absolute position. + VCLocation (Cosmic Location) + | -- | The view should be centered on a certain robot. + VCRobot RID + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + +makePrisms ''ViewCenterRule + +data RobotNaming = RobotNaming + { _nameGenerator :: NameGenerator + , _gensym :: Int + } + +makeLensesExcluding ['_nameGenerator] ''RobotNaming + +--- | Read-only list of words, for use in building random robot names. +nameGenerator :: Getter RobotNaming NameGenerator +nameGenerator = to _nameGenerator + +-- | A counter used to generate globally unique IDs. +gensym :: Lens' RobotNaming Int + +data Robots = Robots + { _robotMap :: IntMap Robot + , -- A set of robots to consider for the next game tick. It is guaranteed to + -- be a subset of the keys of 'robotMap'. It may contain waiting or idle + -- robots. But robots that are present in 'robotMap' and not in 'activeRobots' + -- are guaranteed to be either waiting or idle. + _activeRobots :: IntSet + , -- A set of probably waiting robots, indexed by probable wake-up time. It + -- may contain robots that are in fact active or idle, as well as robots + -- that do not exist anymore. Its only guarantee is that once a robot name + -- with its wake up time is inserted in it, it will remain there until the + -- wake-up time is reached, at which point it is removed via + -- '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] + , _currentTickWakeableBots :: [RID] + , _robotsByLocation :: Map SubworldName (Map 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 + , _robotNaming :: RobotNaming + , _viewCenterRule :: ViewCenterRule + , _viewCenter :: Cosmic Location + , _focusedRobotID :: RID + } + +-- We want to access active and waiting robots via lenses inside +-- this module but to expose it as a Getter to protect invariants. +makeLensesFor + [ ("_activeRobots", "internalActiveRobots") + , ("_waitingRobots", "internalWaitingRobots") + ] + ''Robots + +makeLensesExcluding ['_viewCenter, '_viewCenterRule, '_focusedRobotID, '_activeRobots, '_waitingRobots] ''Robots + +-- | All the robots that currently exist in the game, indexed by ID. +robotMap :: Lens' Robots (IntMap Robot) + +-- | The names of the robots that are currently not sleeping. +activeRobots :: Getter Robots IntSet +activeRobots = internalActiveRobots + +-- | 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 = internalWaitingRobots + +-- | Get a list of all the robots that are \"watching\" by location. +currentTickWakeableBots :: Lens' Robots [RID] + +-- | The names of all robots that currently exist in the game, indexed by +-- location (which we need both for /e.g./ the @salvage@ command as +-- well as for actually drawing the world). Unfortunately there is +-- no good way to automatically keep this up to date, since we don't +-- just want to completely rebuild it every time the 'robotMap' +-- changes. Instead, we just make sure to update it every time the +-- 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)) + +-- | Get a list of all the robots that are \"watching\" by location. +robotsWatching :: Lens' Robots (Map (Cosmic Location) IntSet) + +-- | State and data for assigning identifiers to robots +robotNaming :: Lens' Robots RobotNaming + +-- | The current center of the world view. Note that this cannot be +-- modified directly, since it is calculated automatically from the +-- 'viewCenterRule'. To modify the view center, either set the +-- 'viewCenterRule', or use 'modifyViewCenter'. +viewCenter :: Getter Robots (Cosmic Location) +viewCenter = to _viewCenter + +-- | The current robot in focus. +-- +-- It is only a 'Getter' because this value should be updated only when +-- the 'viewCenterRule' is specified to be a robot. +-- +-- Technically it's the last robot ID specified by 'viewCenterRule', +-- but that robot may not be alive anymore - to be safe use 'focusedRobot'. +focusedRobotID :: Getter Robots RID +focusedRobotID = to _focusedRobotID + +-- * Utilities + +initRobots :: GameStateConfig -> Robots +initRobots gsc = + Robots + { _robotMap = IM.empty + , _activeRobots = IS.empty + , _waitingRobots = M.empty + , _currentTickWakeableBots = mempty + , _robotsByLocation = M.empty + , _robotsWatching = mempty + , _robotNaming = + RobotNaming + { _nameGenerator = nameParts gsc + , _gensym = 0 + } + , _viewCenterRule = VCRobot 0 + , _viewCenter = defaultCosmicLocation + , _focusedRobotID = 0 + } + +-- | The current rule for determining the center of the world view. +-- It updates also, 'viewCenter' and 'focusedRobot' to keep +-- everything synchronized. +viewCenterRule :: Lens' Robots ViewCenterRule +viewCenterRule = lens getter setter + where + getter :: Robots -> ViewCenterRule + getter = _viewCenterRule + + -- The setter takes care of updating 'viewCenter' and 'focusedRobot' + -- So none of these fields get out of sync. + setter :: Robots -> ViewCenterRule -> Robots + setter g rule = + case rule of + VCLocation loc -> g {_viewCenterRule = rule, _viewCenter = loc} + VCRobot rid -> + let robotcenter = g ^? robotMap . ix rid . robotLocation + in -- retrieve the loc of the robot if it exists, Nothing otherwise. + -- sometimes, lenses are amazing... + case robotcenter of + Nothing -> g + Just loc -> g {_viewCenterRule = rule, _viewCenter = loc, _focusedRobotID = rid} + +-- | Add a concrete instance of a robot template to the game state: +-- First, generate a unique ID number for it. Then, add it to the +-- main robot map, the active robot set, and to to the index of +-- robots by location. +addTRobot :: (Has (State Robots) sig m) => CESK -> TRobot -> m () +addTRobot m r = void $ addTRobot' m r + +-- | Like addTRobot, but return the newly instantiated robot. +addTRobot' :: (Has (State Robots) sig m) => CESK -> TRobot -> m Robot +addTRobot' initialMachine r = do + rid <- robotNaming . gensym <+= 1 + let newRobot = instantiateRobot (Just initialMachine) rid r + addRobot newRobot + return newRobot + +-- | Add a robot to the game state, adding it to the main robot map, +-- the active robot set, and to to the index of robots by +-- location. +addRobot :: (Has (State Robots) sig m) => Robot -> m () +addRobot r = do + robotMap %= IM.insert rid r + addRobotToLocation rid $ r ^. robotLocation + internalActiveRobots %= IS.insert rid + where + rid = r ^. robotID + +-- | Helper function for updating the "robotsByLocation" bookkeeping +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)) + +-- | 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 :) + +-- | Takes a robot out of the 'activeRobots' set. +sleepForever :: (Has (State Robots) sig m) => RID -> m () +sleepForever rid = internalActiveRobots %= IS.delete rid + +-- | Adds a robot to the 'activeRobots' set. +activateRobot :: (Has (State Robots) sig m) => RID -> m () +activateRobot rid = internalActiveRobots %= IS.insert rid + +-- | Removes robots whose wake up time matches the current game ticks count +-- from the 'waitingRobots' queue and put them back in the 'activeRobots' set +-- if they still exist in the keys of 'robotMap'. +-- +-- = Mutations +-- +-- This function modifies: +-- +-- * 'wakeLog' +-- * 'robotsWatching' +-- * 'internalWaitingRobots' +-- * '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 + + -- Limit ourselves to the robots that have not expired in their sleep + newlyAlive = IS.intersection robotIdSet wakeableRIDsSet + + internalActiveRobots %= IS.union newlyAlive + + -- These robots' wake times may have been moved "forward" + -- by 'wakeWatchingRobots'. + clearWatchingRobots wakeableRIDsSet + +-- | Clear the "watch" state of all of the +-- awakened robots +clearWatchingRobots :: + (Has (State Robots) sig m) => + IntSet -> + m () +clearWatchingRobots rids = do + robotsWatching %= M.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. +-- +-- NOTE: Clearing 'TickNumber' map entries from 'internalWaitingRobots' +-- upon wakeup is handled by 'wakeUpRobotsDoneSleeping' +wakeWatchingRobots :: (Has (State Robots) sig m) => RID -> TickNumber -> Cosmic Location -> m () +wakeWatchingRobots myID currentTick loc = do + waitingMap <- use waitingRobots + rMap <- use robotMap + watchingMap <- use robotsWatching + + -- The bookkeeping updates to robot waiting + -- states are prepared in 4 steps... + + let -- Step 1: Identify the robots that are watching this location. + botsWatchingThisLoc :: [Robot] + botsWatchingThisLoc = + mapMaybe (`IM.lookup` rMap) $ + IS.toList $ + M.findWithDefault mempty 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 + + -- 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 + 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 + + -- Step 4: Re-add the watching bots to be awakened ASAP: + wakeableBotIds = map fst wakeTimes + + -- It is crucial that only robots with a larger RID than the current robot + -- be scheduled for the *same* tick, since within a given tick we iterate over + -- robots in increasing order of RID. + -- See note in 'iterateRobots'. + (currTickWakeable, nextTickWakeable) = partition (> myID) wakeableBotIds + wakeTimeGroups = + [ (currentTick, currTickWakeable) + , (addTicks 1 currentTick, nextTickWakeable) + ] + newInsertions = M.filter (not . null) $ M.fromList wakeTimeGroups + + -- Contract: This must be emptied immediately + -- in 'iterateRobots' + currentTickWakeableBots .= currTickWakeable + + -- NOTE: There are two "sources of truth" for the waiting state of robots: + -- 1. In the GameState via "internalWaitingRobots" + -- 2. In each robot, via the CESK machine state + + -- 1. Update the game state + internalWaitingRobots .= M.unionWith (<>) filteredWaiting newInsertions + + -- 2. Update the machine of each robot + forM_ wakeTimeGroups $ \(newWakeTime, wakeableBots) -> + forM_ wakeableBots $ \rid -> + robotMap . at rid . _Just . machine %= \case + Waiting _ c -> Waiting newWakeTime c + x -> x + +deleteRobot :: (Has (State Robots) sig m) => RID -> m () +deleteRobot rn = do + internalActiveRobots %= IS.delete rn + mrobot <- robotMap . at rn <<.= Nothing + mrobot `forM_` \robot -> do + -- Delete the robot from the index of robots by location. + removeRobotFromLocationMap (robot ^. robotLocation) rn + +-- | Makes sure empty sets don't hang around in the +-- 'robotsByLocation' map. We don't want a key with an +-- empty set at every location any robot has ever +-- visited! +removeRobotFromLocationMap :: + (Has (State Robots) sig m) => + Cosmic Location -> + 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 + +setRobotInfo :: RID -> [Robot] -> Robots -> Robots +setRobotInfo baseID robotList rState = + (setRobotList robotList rState) {_focusedRobotID = baseID} + & viewCenterRule .~ VCRobot baseID + +setRobotList :: [Robot] -> Robots -> Robots +setRobotList robotList rState = + rState + & robotMap .~ IM.fromList (map (view robotID &&& id) robotList) + & robotsByLocation .~ M.map (groupRobotsByPlanarLocation . NE.toList) (groupRobotsBySubworld 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) + +-- | Modify the 'viewCenter' by applying an arbitrary function to the +-- current value. Note that this also modifies the 'viewCenterRule' +-- to match. After calling this function the 'viewCenterRule' will +-- specify a particular location, not a robot. +modifyViewCenter :: (Cosmic Location -> Cosmic Location) -> Robots -> Robots +modifyViewCenter update rInfo = + rInfo + & case rInfo ^. viewCenterRule of + VCLocation l -> viewCenterRule .~ VCLocation (update l) + VCRobot _ -> viewCenterRule .~ VCLocation (update (rInfo ^. viewCenter)) + +-- | "Unfocus" by modifying the view center rule to look at the +-- current location instead of a specific robot, and also set the +-- focused robot ID to an invalid value. In classic mode this +-- causes the map view to become nothing but static. +unfocus :: Robots -> Robots +unfocus = (\ri -> ri {_focusedRobotID = -1000}) . modifyViewCenter id + +-- | Recalculate the view center (and cache the result in the +-- 'viewCenter' field) based on the current 'viewCenterRule'. If +-- the 'viewCenterRule' specifies a robot which does not exist, +-- simply leave the current 'viewCenter' as it is. +recalcViewCenter :: Robots -> Robots +recalcViewCenter rInfo = + rInfo + { _viewCenter = newViewCenter + } + where + newViewCenter = + fromMaybe (rInfo ^. viewCenter) $ + applyViewCenterRule (rInfo ^. viewCenterRule) (rInfo ^. robotMap) + +-- | Given a current mapping from robot names to robots, apply a +-- 'ViewCenterRule' to derive the location it refers to. The result +-- is 'Maybe' because the rule may refer to a robot which does not +-- exist. +applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location) +applyViewCenterRule (VCLocation l) _ = Just l +applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation diff --git a/src/swarm-engine/Swarm/Game/State/Runtime.hs b/src/swarm-engine/Swarm/Game/State/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/State/Runtime.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Runtime state and utility functions +module Swarm.Game.State.Runtime ( + RuntimeState, + + -- ** Lenses + webPort, + upstreamRelease, + eventLog, + scenarios, + appData, + stdGameConfigInputs, + + -- ** Utility + initScenarioInputs, + initRuntimeState, + initGameStateConfig, +) +where + +import Control.Effect.Accum +import Control.Effect.Lift +import Control.Effect.Throw +import Control.Lens +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.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.Util.Lens (makeLensesNoSigs) +import Swarm.Version (NewReleaseFailure (..)) + +data RuntimeState = RuntimeState + { _webPort :: Maybe Port + , _upstreamRelease :: Either NewReleaseFailure String + , _eventLog :: Notifications LogEntry + , _scenarios :: ScenarioCollection + , _stdGameConfigInputs :: GameStateConfig + , _appData :: Map Text Text + } + +initScenarioInputs :: + ( Has (Throw SystemFailure) sig m + , Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + m ScenarioInputs +initScenarioInputs = do + tem <- loadEntitiesAndTerrain + worlds <- loadWorlds tem + return $ ScenarioInputs worlds tem + +initGameStateInputs :: + ( Has (Throw SystemFailure) sig m + , Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + m GameStateInputs +initGameStateInputs = do + scenarioInputs <- initScenarioInputs + recipes <- loadRecipes $ initEntityTerrain scenarioInputs ^. entityMap + return $ GameStateInputs scenarioInputs recipes + +initGameStateConfig :: + ( Has (Throw SystemFailure) sig m + , Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + m GameStateConfig +initGameStateConfig = do + gsi <- initGameStateInputs + appDataMap <- readAppData + nameGen <- initNameGenerator appDataMap + return $ GameStateConfig appDataMap nameGen gsi + +initRuntimeState :: + ( Has (Throw SystemFailure) sig m + , Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + m RuntimeState +initRuntimeState = do + gsc <- initGameStateConfig + scenarios <- loadScenarios $ gsiScenarioInputs $ initState gsc + + return $ + RuntimeState + { _webPort = Nothing + , _upstreamRelease = Left (NoMainUpstreamRelease []) + , _eventLog = mempty + , _scenarios = scenarios + , _appData = initAppDataMap gsc + , _stdGameConfigInputs = gsc + } + +makeLensesNoSigs ''RuntimeState + +-- | The port on which the HTTP debug service is running. +webPort :: Lens' RuntimeState (Maybe Port) + +-- | The upstream release version. +upstreamRelease :: Lens' RuntimeState (Either NewReleaseFailure String) + +-- | A log of runtime events. +-- +-- This logging is separate from the logging done during game-play. +-- 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 + +-- | Free-form data loaded from the @data@ directory, for things like +-- the logo, about page, tutorial story, etc. +appData :: Lens' RuntimeState (Map Text Text) diff --git a/src/swarm-engine/Swarm/Game/State/Substate.hs b/src/swarm-engine/Swarm/Game/State/Substate.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/State/Substate.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Subrecord definitions that belong to 'Swarm.Game.State.GameState' +module Swarm.Game.State.Substate ( + GameStateConfig (..), + REPLStatus (..), + WinStatus (..), + WinCondition (..), + ObjectiveCompletion, + _NoWinCondition, + _WinConditions, + Announcement (..), + RunStatus (..), + Step (..), + SingleStep (..), + + -- ** GameState fields + + -- *** Randomness state + Randomness, + initRandomness, + seed, + randGen, + + -- *** Temporal state + TemporalState, + initTemporalState, + gameStep, + runStatus, + ticks, + robotStepsPerTick, + paused, + + -- *** Recipes + Recipes, + initRecipeMaps, + recipesOut, + recipesIn, + recipesCat, + + -- *** Messages + Messages, + initMessages, + messageQueue, + lastSeenMessageTime, + announcementQueue, + + -- *** Controls + GameControls, + initGameControls, + initiallyRunCode, + replStatus, + replNextValueIndex, + inputHandler, + + -- *** Discovery + Discovery, + initDiscovery, + allDiscoveredEntities, + availableRecipes, + availableCommands, + knownEntities, + gameAchievements, + structureRecognition, + tagMembers, + + -- ** Notifications + Notifications (..), + notificationsCount, + notificationsShouldAlert, + notificationsContent, + + -- ** Utilities + defaultRobotStepsPerTick, + replActiveType, + replWorking, + toggleRunStatus, +) where + +import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) +import Data.Aeson (FromJSON, ToJSON) +import Data.IntMap (IntMap) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Sequence (Seq) +import Data.Set qualified as S +import Data.Text (Text) +import GHC.Generics (Generic) +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Game.Achievement.Attainment +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Entity +import Swarm.Game.Recipe ( + Recipe, + catRecipeMap, + inRecipeMap, + outRecipeMap, + ) +import Swarm.Game.Robot +import Swarm.Game.Scenario (GameStateInputs (..), StructureCells) +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.Types (Polytype) +import Swarm.Language.Value (Value) +import Swarm.Log +import Swarm.Util.Lens (makeLensesNoSigs) +import System.Random (StdGen, mkStdGen) + +-- * Subsidiary data types + +-- | A data type to represent the current status of the REPL. +data REPLStatus + = -- | The REPL is not doing anything actively at the moment. + -- We persist the last value and its type though. + REPLDone (Maybe (Polytype, Value)) + | -- | A command entered at the REPL is currently being run. The + -- 'Polytype' represents the type of the expression that was + -- entered. The @Maybe Value@ starts out as 'Nothing' and gets + -- filled in with a result once the command completes. + REPLWorking Polytype (Maybe Value) + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +data WinStatus + = -- | There are one or more objectives remaining that the player + -- has not yet accomplished. + Ongoing + | -- | The player has won. + -- The boolean indicates whether they have + -- already been congratulated. + Won Bool TickNumber + | -- | The player has completed certain "goals" that preclude + -- (via negative prerequisites) the completion of all of the + -- required goals. + -- The boolean indicates whether they have + -- already been informed. + Unwinnable Bool + deriving (Show, Generic, FromJSON, ToJSON) + +data WinCondition + = -- | There is no winning condition. + NoWinCondition + | -- | NOTE: It is possible to continue to achieve "optional" objectives + -- even after the game has been won (or deemed unwinnable). + WinConditions WinStatus ObjectiveCompletion + deriving (Show, Generic, FromJSON, ToJSON) + +makePrisms ''WinCondition + +instance ToSample WinCondition where + toSamples _ = + SD.samples + [ NoWinCondition + -- TODO: #1552 add simple objective sample + ] + +-- | A data type to keep track of the pause mode. +data RunStatus + = -- | The game is running. + Running + | -- | The user paused the game, and it should stay pause after visiting the help. + ManualPause + | -- | The game got paused while visiting the help, + -- and it should unpause after returning back to the game. + AutoPause + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +-- | Switch (auto or manually) paused game to running and running to manually paused. +-- +-- Note that this function is not safe to use in the app directly, because the UI +-- also tracks time between ticks---use 'Swarm.TUI.Controller.safeTogglePause' instead. +toggleRunStatus :: RunStatus -> RunStatus +toggleRunStatus s = if s == Running then ManualPause else Running + +-- | A data type to keep track of some kind of log or sequence, with +-- an index to remember which ones are "new", which ones have +-- "already been seen", and whether the user has yet been notified +-- of the fact that there are unseen notifications. +data Notifications a = Notifications + { _notificationsCount :: Int + , _notificationsShouldAlert :: Bool + , _notificationsContent :: [a] + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +instance Semigroup (Notifications a) where + Notifications count1 alert1 xs1 <> Notifications count2 alert2 xs2 = Notifications (count1 + count2) (alert1 || alert2) (xs1 <> xs2) + +instance Monoid (Notifications a) where + mempty = Notifications 0 False [] + +makeLenses ''Notifications + +data Recipes = Recipes + { _recipesOut :: IntMap [Recipe Entity] + , _recipesIn :: IntMap [Recipe Entity] + , _recipesCat :: IntMap [Recipe Entity] + } + +makeLensesNoSigs ''Recipes + +-- | All recipes the game knows about, indexed by outputs. +recipesOut :: Lens' Recipes (IntMap [Recipe Entity]) + +-- | All recipes the game knows about, indexed by inputs. +recipesIn :: Lens' Recipes (IntMap [Recipe Entity]) + +-- | All recipes the game knows about, indexed by requirement/catalyst. +recipesCat :: Lens' Recipes (IntMap [Recipe Entity]) + +data Messages = Messages + { _messageQueue :: Seq LogEntry + , _lastSeenMessageTime :: TickNumber + , _announcementQueue :: Seq Announcement + } + +makeLensesNoSigs ''Messages + +-- | A queue of global messages. +-- +-- Note that we put the newest entry to the right. +messageQueue :: Lens' Messages (Seq LogEntry) + +-- | Last time message queue has been viewed (used for notification). +lastSeenMessageTime :: Lens' Messages TickNumber + +-- | A queue of global announcements. +-- Note that this is distinct from the 'messageQueue', +-- which is for messages emitted by robots. +-- +-- Note that we put the newest entry to the right. +announcementQueue :: Lens' Messages (Seq Announcement) + +-- | Type for remembering which robots will be run next in a robot step mode. +-- +-- Once some robots have run, we need to store 'RID' to know which ones should go next. +-- At 'SBefore' no robots were run yet, so it is safe to transition to and from 'WorldTick'. +-- +-- @ +-- tick +-- ┌────────────────────────────────────┐ +-- │ │ +-- │ step │ +-- │ ┌────┐ │ +-- ▼ ▼ │ │ +-- ┌───────┐ step ┌───────┴───┐ step ┌────┴─────┐ +-- │SBefore├──────►│SSingle RID├──────►│SAfter RID│ +-- └──┬────┘ └───────────┘ └────┬─────┘ +-- │ ▲ player ▲ │ +-- ▼ │ switch └───────────────────┘ +-- ┌────┴────┐ view RID > oldRID +-- │WorldTick│ +-- └─────────┘ +-- @ +data SingleStep + = -- | Run the robots from the beginning until the focused robot (noninclusive). + SBefore + | -- | Run a single step of the focused robot. + SSingle RID + | -- | Run robots after the (previously) focused robot and finish the tick. + SAfter RID + +-- | Game step mode - we use the single step mode when debugging robot 'CESK' machine. +data Step = WorldTick | RobotStep SingleStep + +data TemporalState = TemporalState + { _gameStep :: Step + , _runStatus :: RunStatus + , _ticks :: TickNumber + , _robotStepsPerTick :: Int + } + +makeLensesNoSigs ''TemporalState + +-- | How to step the game: 'WorldTick' or 'RobotStep' for debugging the 'CESK' machine. +gameStep :: Lens' TemporalState Step + +-- | The current 'RunStatus'. +runStatus :: Lens' TemporalState RunStatus + +-- | Whether the game is currently paused. +paused :: Getter TemporalState Bool +paused = to (\s -> s ^. runStatus /= Running) + +-- | The number of ticks elapsed since the game started. +ticks :: Lens' TemporalState TickNumber + +-- | The maximum number of CESK machine steps a robot may take during +-- a single tick. +robotStepsPerTick :: Lens' TemporalState Int + +data GameControls = GameControls + { _replStatus :: REPLStatus + , _replNextValueIndex :: Integer + , _inputHandler :: Maybe (Text, Value) + , _initiallyRunCode :: Maybe TSyntax + } + +makeLensesNoSigs ''GameControls + +-- | The current status of the REPL. +replStatus :: Lens' GameControls REPLStatus + +-- | The index of the next @it{index}@ value +replNextValueIndex :: Lens' GameControls Integer + +-- | 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) + +data Discovery = Discovery + { _allDiscoveredEntities :: Inventory + , _availableRecipes :: Notifications (Recipe Entity) + , _availableCommands :: Notifications Const + , _knownEntities :: S.Set EntityName + , _gameAchievements :: Map GameplayAchievement Attainment + , _structureRecognition :: StructureRecognizer StructureCells Entity + , _tagMembers :: Map Text (NonEmpty EntityName) + } + +makeLensesNoSigs ''Discovery + +-- | The list of entities that have been discovered. +allDiscoveredEntities :: Lens' Discovery Inventory + +-- | The list of available recipes. +availableRecipes :: Lens' Discovery (Notifications (Recipe Entity)) + +-- | The list of available commands. +availableCommands :: Lens' Discovery (Notifications Const) + +-- | The names of entities that should be considered \"known\", that is, +-- robots know what they are without having to scan them. +knownEntities :: 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) + +-- | Map from tags to entities that possess that tag +tagMembers :: Lens' Discovery (Map Text (NonEmpty EntityName)) + +data Randomness = Randomness + { _seed :: Seed + , _randGen :: StdGen + } + +makeLensesNoSigs ''Randomness + +-- | The initial seed that was used for the random number generator, +-- and world generation. +seed :: Lens' Randomness Seed + +-- | Pseudorandom generator initialized at start. +randGen :: Lens' Randomness StdGen + +-- * Utilities + +-- | Whether the repl is currently working. +replWorking :: Getter GameControls Bool +replWorking = to (\s -> matchesWorking $ s ^. replStatus) + where + matchesWorking REPLDone {} = False + matchesWorking REPLWorking {} = True + +-- | Either the type of the command being executed, or of the last command +replActiveType :: Getter REPLStatus (Maybe Polytype) +replActiveType = to getter + where + getter (REPLDone (Just (typ, _))) = Just typ + getter (REPLWorking typ _) = Just typ + getter _ = Nothing + +-- | By default, robots may make a maximum of 100 CESK machine steps +-- during one game tick. +defaultRobotStepsPerTick :: Int +defaultRobotStepsPerTick = 100 + +-- * Record initialization + +initTemporalState :: TemporalState +initTemporalState = + TemporalState + { _gameStep = WorldTick + , _runStatus = Running + , _ticks = TickNumber 0 + , _robotStepsPerTick = defaultRobotStepsPerTick + } + +initGameControls :: GameControls +initGameControls = + GameControls + { _replStatus = REPLDone Nothing + , _replNextValueIndex = 0 + , _inputHandler = Nothing + , _initiallyRunCode = Nothing + } + +initMessages :: Messages +initMessages = + Messages + { _messageQueue = Empty + , _lastSeenMessageTime = TickNumber (-1) + , _announcementQueue = mempty + } + +initDiscovery :: Discovery +initDiscovery = + Discovery + { _availableRecipes = mempty + , _availableCommands = mempty + , _allDiscoveredEntities = empty + , _knownEntities = 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 [] + , _tagMembers = mempty + } + +initRandomness :: Randomness +initRandomness = + Randomness + { _seed = 0 + , _randGen = mkStdGen 0 + } + +initRecipeMaps :: GameStateConfig -> Recipes +initRecipeMaps gsc = + Recipes + { _recipesOut = outRecipeMap recipeList + , _recipesIn = inRecipeMap recipeList + , _recipesCat = catRecipeMap recipeList + } + where + recipeList = gsiRecipes $ initState gsc diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -0,0 +1,866 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Stepping robot CESK machines +-- +-- Facilities for stepping the robot CESK machines, /i.e./ the actual +-- interpreter for the Swarm language. +-- +-- == Note on the IO: +-- +-- The only reason we need @IO@ is so that robots can run programs +-- loaded from files, via the 'Swarm.Language.Syntax.Run' command. +-- This could be avoided by using a hypothetical @import@ command instead and parsing +-- the required files at the time of declaration. +-- 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) +import Control.Effect.Error +import Control.Effect.Lens +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.Functor (void) +import Data.IntMap qualified as IM +import Data.IntSet qualified as IS +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Sequence ((><)) +import Data.Sequence qualified as Seq +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Linear (zero) +import Prettyprinter (pretty) +import Swarm.Effect as Effect (Time, getNow) +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.Exception +import Swarm.Game.Land +import Swarm.Game.Robot +import Swarm.Game.Robot.Activity +import Swarm.Game.Robot.Concrete +import Swarm.Game.Robot.Walk (emptyExceptions) +import Swarm.Game.Scenario.Objective qualified as OB +import Swarm.Game.Scenario.Objective.WinCheck qualified as WC +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Step.Const +import Swarm.Game.Step.RobotStepState +import Swarm.Game.Step.Util +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.Typed (Typed (..)) +import Swarm.Language.Value +import Swarm.Log +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) + +-- | The main function to do one game tick. +-- +-- Note that the game may be in 'RobotStep' mode and not finish +-- the tick. Use the return value to check whether a full tick happened. +gameTick :: HasGameStepState sig m => m Bool +gameTick = do + time <- use $ temporal . ticks + zoomRobots $ wakeUpRobotsDoneSleeping time + active <- use $ robotInfo . activeRobots + focusedRob <- use $ robotInfo . focusedRobotID + + ticked <- + use (temporal . gameStep) >>= \case + WorldTick -> do + runRobotIDs active + temporal . ticks %= addTicks 1 + pure True + RobotStep ss -> singleStep ss focusedRob active + + -- See if the base is finished with a computation, and if so, record + -- the result in the game state so it can be displayed by the REPL; + -- 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 () + + -- Possibly update the view center. + modify recalcViewCenterAndRedraw + + when ticked $ do + -- On new tick see if the winning condition for the current objective is met. + wc <- use winCondition + case wc of + WinConditions winState oc -> do + g <- get @GameState + em <- use $ landscape . terrainAndEntities . entityMap + hypotheticalWinCheck em g winState oc + _ -> pure () + return ticked + +-- | Finish a game tick in progress and set the game to 'WorldTick' mode afterwards. +-- +-- Use this function if you need to unpause the game. +finishGameTick :: HasGameStepState sig m => m () +finishGameTick = + use (temporal . gameStep) >>= \case + WorldTick -> pure () + RobotStep SBefore -> temporal . gameStep .= WorldTick + RobotStep _ -> void gameTick >> finishGameTick + +-- | Insert the robot back to robot map. +-- Will selfdestruct or put the robot to sleep if it has that set. +insertBackRobot :: Has (State GameState) sig m => RID -> Robot -> m () +insertBackRobot rn rob = do + time <- use $ temporal . ticks + zoomRobots $ + if rob ^. selfDestruct + then deleteRobot rn + else do + robotMap %= IM.insert rn rob + case waitingUntil rob of + Just wakeUpTime + -- if w=2 t=1 then we do not needlessly put robot to waiting queue + | wakeUpTime <= addTicks 2 time -> return () + | otherwise -> sleepUntil rn wakeUpTime + Nothing -> + unless (isActive rob) (sleepForever rn) + +-- | GameState with support for IO and Time effect +type HasGameStepState sig m = (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) + +-- | Run a set of robots - this is used to run robots before/after the focused one. +-- +-- Note that during the iteration over the supplied robot IDs, it is possible +-- that a robot that may have been present in 'robotMap' at the outset +-- of the iteration to be removed before the iteration comes upon it. +-- This is why we must perform a 'robotMap' lookup at each iteration, rather +-- than looking up elements from 'robotMap' in bulk up front with something like +-- 'restrictKeys'. +-- +-- = Invariants +-- +-- * Every tick, every active robot shall have exactly one opportunity to run. +-- * The sequence in which robots are chosen to run is by increasing order of 'RID'. +runRobotIDs :: HasGameStepState sig m => IS.IntSet -> m () +runRobotIDs robotNames = do + time <- use $ temporal . ticks + flip (iterateRobots time) robotNames $ \rn -> do + mr <- uses (robotInfo . robotMap) (IM.lookup rn) + forM_ mr (stepOneRobot rn) + where + stepOneRobot :: HasGameStepState sig m => RID -> Robot -> m () + stepOneRobot rn rob = tickRobot rob >>= insertBackRobot rn + +-- | +-- Runs the given robots in increasing order of 'RID'. +-- +-- Running a given robot _may_ cause another robot +-- with a higher 'RID' to be inserted into the runnable set. +-- +-- Note that the behavior we desire is described precisely by a +-- . +-- +-- A priority queue allows O(1) access to the lowest priority item. However, +-- /splitting/ the min item from rest of the queue is still an O(log N) operation, +-- and therefore is not any better than the 'minView' function from 'IntSet'. +-- +-- Tail-recursive. +iterateRobots :: HasGameStepState sig m => TickNumber -> (RID -> m ()) -> IS.IntSet -> m () +iterateRobots time f runnableBots = + forM_ (IS.minView runnableBots) $ \(thisRobotId, remainingBotIDs) -> do + f thisRobotId + + -- We may have awakened new robots in the current robot's iteration, + -- so we add them to the list + poolAugmentation <- do + -- NOTE: We could use 'IS.split thisRobotId activeRIDsThisTick' + -- to ensure that we only insert RIDs greater than 'thisRobotId' + -- into the queue. + -- However, we already ensure in 'wakeWatchingRobots' that only + -- robots with a larger RID are scheduled for the current tick; + -- robots with smaller RIDs will be scheduled for the next tick. + robotsToAdd <- use $ robotInfo . currentTickWakeableBots + if null robotsToAdd + then return id + else do + zoomRobots $ wakeUpRobotsDoneSleeping time + robotInfo . currentTickWakeableBots .= [] + return $ IS.union $ IS.fromList robotsToAdd + + iterateRobots time f $ poolAugmentation remainingBotIDs + +-- | This is a helper function to do one robot step or run robots before/after. +singleStep :: HasGameStepState sig m => SingleStep -> RID -> IS.IntSet -> m Bool +singleStep ss focRID robotSet = do + let (preFoc, focusedActive, postFoc) = IS.splitMember focRID robotSet + case ss of + ---------------------------------------------------------------------------- + -- run robots from the beginning until focused robot + SBefore -> do + runRobotIDs preFoc + temporal . gameStep .= RobotStep (SSingle focRID) + -- also set ticks of focused robot + steps <- use $ temporal . robotStepsPerTick + robotInfo . robotMap . ix focRID . activityCounts . tickStepBudget .= steps + -- continue to focused robot if there were no previous robots + -- DO NOT SKIP THE ROBOT SETUP above + if IS.null preFoc + then singleStep (SSingle focRID) focRID robotSet + else return False + ---------------------------------------------------------------------------- + -- run single step of the focused robot (may skip if inactive) + SSingle rid | not focusedActive -> do + singleStep (SAfter rid) rid postFoc -- skip inactive focused robot + SSingle rid -> do + mOldR <- uses (robotInfo . robotMap) (IM.lookup focRID) + case mOldR of + Nothing | rid == focRID -> do + debugLog "The debugged robot does not exist! Exiting single step mode." + runRobotIDs postFoc + temporal . gameStep .= WorldTick + temporal . ticks %= addTicks 1 + return True + Nothing | otherwise -> do + debugLog "The previously debugged robot does not exist!" + singleStep SBefore focRID postFoc + Just oldR -> do + -- if focus changed we need to finish the previous robot + newR <- (if rid == focRID then stepRobot else tickRobotRec) oldR + insertBackRobot focRID newR + if rid == focRID + then do + when (newR ^. activityCounts . tickStepBudget == 0) $ + temporal . gameStep .= RobotStep (SAfter focRID) + return False + else do + -- continue to newly focused + singleStep SBefore focRID postFoc + ---------------------------------------------------------------------------- + -- run robots after the focused robot + SAfter rid | focRID <= rid -> do + -- This state takes care of two possibilities: + -- 1. normal - rid == focRID and we finish the tick + -- 2. changed focus and the newly focused robot has previously run + -- so we just finish the tick the same way + runRobotIDs postFoc + temporal . gameStep .= RobotStep SBefore + temporal . ticks %= addTicks 1 + return True + SAfter rid | otherwise -> do + -- go to single step if new robot is focused + let (_pre, postRID) = IS.split rid robotSet + singleStep SBefore focRID postRID + where + h = hypotheticalRobot (Out VUnit emptyStore []) 0 + debugLog txt = do + m <- evalState @Robot h $ createLogEntry RobotError Debug txt + emitMessage m + +-- | An accumulator for folding over the incomplete +-- objectives to evaluate for their completion +data CompletionsWithExceptions = CompletionsWithExceptions + { exceptions :: [Text] + , completions :: ObjectiveCompletion + , completionAnnouncementQueue :: [OB.Objective] + -- ^ Upon completion, an objective is enqueued. + -- It is dequeued when displayed on the UI. + } + +-- | Execute the win condition check *hypothetically*: i.e. in a +-- fresh CESK machine, using a copy of the current game state. +-- +-- The win check is performed only on "active" goals; that is, +-- the goals that are currently unmet and have had all of their +-- prerequisites satisfied. +-- Note that it may be possible, while traversing through the +-- goal list, for one goal to be met earlier in the list that +-- happens to be a prerequisite later in the traversal. This +-- is why: +-- 1) We must not pre-filter the goals to be traversed based +-- on satisfied prerequisites (i.e. we cannot use the +-- "getActiveObjectives" function). +-- 2) The traversal order must be "reverse topological" order, so +-- that prerequisites are evaluated before dependent goals. +-- 3) The iteration needs to be a "fold", so that state is updated +-- after each element. +hypotheticalWinCheck :: + (Has (State GameState) sig m, Has Effect.Time sig m, Has (Lift IO) sig m) => + EntityMap -> + GameState -> + WinStatus -> + ObjectiveCompletion -> + m () +hypotheticalWinCheck em g ws oc = do + -- We can fully and accurately evaluate the new state of the objectives DAG + -- in a single pass, so long as we visit it in reverse topological order. + -- + -- N.B. The "reverse" is essential due to the re-population of the + -- "incomplete" goal list by cons-ing. + finalAccumulator <- + foldM foldFunc initialAccumulator $ + reverse incompleteGoals + + ts <- use $ temporal . ticks + let newWinState = case ws of + Ongoing -> getNextWinState ts $ completions finalAccumulator + _ -> ws + + winCondition .= WinConditions newWinState (completions finalAccumulator) + + case newWinState of + Unwinnable _ -> grantAchievement LoseScenario + _ -> return () + + messageInfo . announcementQueue %= (>< Seq.fromList (map ObjectiveCompleted $ completionAnnouncementQueue finalAccumulator)) + + mapM_ handleException $ exceptions finalAccumulator + where + getNextWinState ts completedObjs + | WC.didWin completedObjs = Won False ts + | WC.didLose completedObjs = Unwinnable False + | otherwise = Ongoing + + (withoutIncomplete, incompleteGoals) = OB.extractIncomplete oc + initialAccumulator = CompletionsWithExceptions [] withoutIncomplete [] + + -- All of the "incomplete" goals have been emptied from the initial accumulator, and + -- these are what we iterate over with the fold. + -- Each iteration, we either place the goal back into the "incomplete" bucket, or + -- we determine that it has been met or impossible and place it into the "completed" + -- or "unwinnable" bucket, respectively. + foldFunc (CompletionsWithExceptions exnTexts currentCompletions announcements) obj = do + v <- + if WC.isPrereqsSatisfied currentCompletions obj + then runThrow @Exn . evalState @GameState g $ evalT $ obj ^. OB.objectiveCondition + else return $ Right $ VBool False + return $ case simplifyResult v of + Left exnText -> + CompletionsWithExceptions + (exnText : exnTexts) + -- Push back the incomplete goal that had been popped for inspection + (OB.addIncomplete obj currentCompletions) + announcements + Right boolResult -> + CompletionsWithExceptions + exnTexts + -- Either restore the goal to the incomplete list from which it was popped + -- or move it to the complete (or unwinnable) bucket. + (modifyCompletions obj currentCompletions) + (modifyAnnouncements announcements) + where + (modifyCompletions, modifyAnnouncements) + | boolResult = (OB.addCompleted, (obj :)) + | WC.isUnwinnable currentCompletions obj = (OB.addUnwinnable, id) + | otherwise = (OB.addIncomplete, id) + + simplifyResult = \case + Left exn -> Left $ formatExn em exn + Right (VBool x) -> Right x + Right val -> + Left $ + 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 + handleException exnText = do + m <- evalState @Robot h $ createLogEntry RobotError Critical exnText + emitMessage m + where + h = hypotheticalRobot (Out VUnit emptyStore []) 0 + +evalT :: + ( Has Effect.Time sig m + , Has (Throw Exn) sig m + , Has (State GameState) sig m + , Has (Lift IO) sig m + ) => + TSyntax -> + m Value +evalT = evaluateCESK . initMachine + +-- | Create a special robot to check some hypothetical, for example the win condition. +-- +-- Use ID (-1) so it won't conflict with any robots currently in the robot map. +hypotheticalRobot :: CESK -> TimeSpec -> Robot +hypotheticalRobot m = + instantiateRobot (Just m) (-1) + . mkRobot + Nothing + "hypothesis" + mempty + Nothing + zero + defaultRobotDisplay + Nothing + [] + [] + True + False + emptyExceptions + +evaluateCESK :: + ( Has Effect.Time sig m + , Has (Throw Exn) sig m + , Has (State GameState) sig m + , Has (Lift IO) sig m + ) => + CESK -> + m Value +evaluateCESK cesk = do + createdAt <- getNow + let r = hypotheticalRobot cesk createdAt + zoomRobots $ addRobot r -- Add the special robot to the robot map, so it can look itself up if needed + evalState r . runCESK $ cesk + +runCESK :: + ( Has Effect.Time sig m + , Has (Lift IO) sig m + , Has (Throw Exn) sig m + , Has (State GameState) sig m + , Has (State Robot) sig m + ) => + CESK -> + m Value +runCESK (Up exn _ []) = throwError exn +runCESK cesk = case finalValue cesk of + Just v -> return v + Nothing -> stepCESK cesk >>= runCESK + +------------------------------------------------------------ +-- Debugging +------------------------------------------------------------ + +-- | Print a showable value via the robot's log. +-- +-- Useful for debugging. +traceLogShow :: (Has (State GameState) sig m, Has (State Robot) sig m, Show a) => a -> m () +traceLogShow = void . traceLog Logged Info . from . show + +------------------------------------------------------------ +-- Stepping robots +------------------------------------------------------------ + +-- | Run a robot for one tick, which may consist of up to +-- 'robotStepsPerTick' CESK machine steps and at most one tangible +-- command execution, whichever comes first. +tickRobot :: HasGameStepState sig m => Robot -> m Robot +tickRobot r = do + steps <- use $ temporal . robotStepsPerTick + tickRobotRec (r & activityCounts . tickStepBudget .~ steps) + +-- | Recursive helper function for 'tickRobot', which checks if the +-- robot is actively running and still has steps left, and if so +-- runs it for one step, then calls itself recursively to continue +-- stepping the robot. +tickRobotRec :: HasGameStepState sig m => Robot -> m Robot +tickRobotRec r = do + time <- use $ temporal . ticks + case wantsToStep time r && (r ^. runningAtomic || r ^. activityCounts . tickStepBudget > 0) of + True -> stepRobot r >>= tickRobotRec + False -> return r + +-- | Single-step a robot by decrementing its 'tickStepBudget' counter and +-- running its CESK machine for one step. +stepRobot :: HasGameStepState sig m => Robot -> m Robot +stepRobot r = do + (r', cesk') <- runState (r & activityCounts . tickStepBudget -~ 1) (stepCESK (r ^. machine)) + t <- use $ temporal . ticks + + isCreative <- use creativeMode + let shouldTrackActivity = isCreative || not (r' ^. systemRobot) + + return $ + applyWhen shouldTrackActivity (maintainActivityWindow t) $ + r' + & machine .~ cesk' + & activityCounts . lifetimeStepCount +~ 1 + where + maintainActivityWindow t bot = + bot & (activityCounts . activityWindow %~ WC.insert t) + +data SKpair = SKpair Store Cont + +-- | Performs some side-effectful computation +-- for an "FImmediate" Frame. +-- Aborts processing the continuation stack +-- if an error is encountered. +-- +-- Compare to "withExceptions". +processImmediateFrame :: + (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => + Value -> + SKpair -> + -- | the unreliable computation + ErrorC Exn m () -> + m CESK +processImmediateFrame v (SKpair s k) unreliableComputation = do + wc <- runError unreliableComputation + case wc of + Left exn -> return $ Up exn s k + Right () -> stepCESK $ Out v s k + +-- | The main CESK machine workhorse. Given a robot, look at its CESK +-- machine state and figure out a single next step. +stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => CESK -> m CESK +stepCESK cesk = case cesk of + ------------------------------------------------------------ + -- Evaluation + + -- We wake up robots whose wake-up time has been reached. If it hasn't yet + -- then stepCESK is a no-op. + Waiting wakeupTime cesk' -> do + time <- use $ temporal . ticks + if wakeupTime <= time + then stepCESK cesk' + else return cesk + Out v s (FImmediate cmd wf rf : k) -> + processImmediateFrame v (SKpair s k) $ + updateWorldAndRobots cmd wf rf + -- Now some straightforward cases. These all immediately turn + -- into values. + In TUnit _ s k -> return $ Out VUnit s k + In (TDir d) _ s k -> return $ Out (VDir d) s k + 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 + -- 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 + In (TRequire {}) 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 + -- Normally it's not possible to have a TRobot value in surface + -- syntax, but the salvage command generates a program that needs to + -- refer directly to the salvaging robot. + In (TRobot rid) _ s k -> return $ Out (VRobot rid) s k + -- Function constants of arity 0 are evaluated immediately + -- (e.g. parent, self). Any other constant is turned into a VCApp, + -- which is waiting for arguments and/or an FExec frame. + In (TConst c) _ s k + | arity c == 0 && not (isCmd c) -> evalConst c [] s k + | otherwise -> return $ Out (VCApp c []) s k + -- To evaluate a variable, just look it up in the context. + In (TVar x) e s k -> withExceptions s k $ do + v <- + lookupValue x e + `isJustOr` Fatal (T.unwords ["Undefined variable", x, "encountered while running the interpreter."]) + + -- Now look up any indirections and make sure it's not a blackhole. + case resolveValue s v of + Left loc -> throwError $ Fatal $ T.append "Reference to unknown memory cell " (from (show loc)) + Right VBlackhole -> throwError InfiniteLoop + Right v' -> return $ Out v' s k + + -- To evaluate a pair, start evaluating the first component. + In (TPair t1 t2) e s k -> return $ In t1 e s (FSnd t2 e : k) + -- Once that's done, evaluate the second component. + Out v1 s (FSnd t2 e : k) -> return $ In t2 e s (FFst v1 : k) + -- Finally, put the results together into a pair value. + 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 + -- 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) + -- 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 + -- arguments, eventually dispatching to evalConst for function + -- constants. + Out v2 s (FApp (VCApp c args) : k) + | not (isCmd c) + && arity c == length args + 1 -> + evalConst c (reverse (v2 : args)) s k + | otherwise -> return $ Out (VCApp c (v2 : args)) s k + Out _ s (FApp _ : _) -> badMachineState s "FApp of non-function" + -- Start evaluating a record. If it's empty, we're done. Otherwise, focus + -- on the first field and record the rest in a FRcd frame. + In (TRcd m) e s k -> return $ case M.assocs m of + [] -> Out (VRcd M.empty) s k + ((x, t) : fs) -> In (fromMaybe (TVar x) t) e s (FRcd e [] x fs : k) + -- When we finish evaluating the last field, return a record value. + Out v s (FRcd _ done x [] : k) -> return $ Out (VRcd (M.fromList ((x, v) : done))) s k + -- Otherwise, save the value of the field just evaluated and move on + -- to focus on evaluating the next one. + Out v s (FRcd e done x ((y, t) : rest) : k) -> + return $ In (fromMaybe (TVar y) t) e s (FRcd e ((x, v) : done) y rest : k) + -- Evaluate a record projection: evaluate the record and remember we + -- need to do the projection later. + In (TProj t x) e s k -> return $ In t e s (FProj x : k) + -- Do a record projection + Out v s (FProj x : k) -> case v of + VRcd m -> case M.lookup x m of + Nothing -> badMachineState s $ T.unwords ["Record projection for variable", x, "that does not exist"] + Just xv -> return $ Out xv s k + _ -> 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 -> + 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 + -- First, allocate a cell for it in the store with the initial + -- value of Blackhole. + let (loc, s') = allocate VBlackhole s + -- Now evaluate the definition with the variable bound to an + -- indirection to the new cell, and push an FUpdate stack frame to + -- update the cell with the value once we're done evaluating it, + -- followed by an FLet frame to evaluate the body of the let. + return $ In t1 (addValueBinding x (VIndir loc) e) s' (FUpdate loc : FLet x ((,) <$> mty <*> mreq) t2 e : k) + -- Once we've finished with the let-binding, we switch to evaluating + -- the body in a suitably extended environment. + Out v1 s (FLet x mtr t2 e : k) -> do + let e' = case mtr of + Nothing -> addValueBinding x v1 e + Just (ty, req) -> addBinding x (Typed v1 ty req) e + 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 + -- 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 + -- Simple (non-memoized) delay expressions immediately turn into + -- VDelay values, awaiting application of 'Force'. + In (TDelay t) e s k -> return $ Out (VDelay t e) s k + -- If we see an update frame, it means we're supposed to set the value + -- of a particular cell to the value we just finished computing. + Out v s (FUpdate loc : k) -> return $ Out v (setStore loc v s) k + -- 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 + ------------------------------------------------------------ + -- Execution + + -- Executing a 'requirements' command generates an appropriate log message + -- listing the requirements of the given expression. + Out (VRequirements src t e) s (FExec : k) -> do + em <- use $ landscape . terrainAndEntities . entityMap + let reqCtx = e ^. envReqs + tdCtx = e ^. envTydefs + + R.Requirements caps devs inv = R.requirements tdCtx reqCtx t + + devicesForCaps, requiredDevices :: Set (Set Text) + -- possible devices to provide each required capability + devicesForCaps = S.map (S.fromList . map (^. entityName) . (`devicesForCap` em)) caps + -- outright required devices + requiredDevices = S.map S.singleton devs + + deviceSets :: Set (Set Text) + deviceSets = + -- Union together all required device sets, and remove any + -- device sets which are a superset of another set. For + -- example, if (grabber OR fast grabber OR harvester) is + -- required but (grabber OR fast grabber) is also required + -- then we might as well remove the first set, since + -- satisfying the second device set will automatically + -- satisfy the first. + removeSupersets $ devicesForCaps `S.union` requiredDevices + + reqLog = + prettyText $ + BulletList + (pretty $ T.unwords ["Requirements for", bquote src <> ":"]) + ( filter + (not . null . bulletListItems) + [ BulletList + "Equipment:" + (T.intercalate " OR " . S.toList <$> S.toList deviceSets) + , BulletList + "Inventory:" + ((\(item, n) -> item <> " " <> parens (showT n)) <$> M.assocs inv) + ] + ) + + _ <- traceLog Logged Info reqLog + return $ Out VUnit s k + + -- To execute a constant application, delegate to the 'evalConst' + -- function. Set tickStepBudget to 0 if the command is supposed to take + -- a tick, so the robot won't take any more steps this tick. + Out (VCApp c args) s (FExec : k) -> do + when (isTangible c) $ activityCounts . tickStepBudget .= 0 + evalConst c (reverse args) s k + + -- Reset the runningAtomic flag when we encounter an FFinishAtomic frame. + Out v s (FFinishAtomic : k) -> do + runningAtomic .= False + return $ Out v s k + + -- To execute a bind expression, evaluate and execute the first + -- command, and remember the second for execution later. + Out (VBind mx mty mreq c1 c2 e) s (FExec : k) -> return $ In c1 e s (FExec : FBind mx ((,) <$> mty <*> mreq) c2 e : k) + Out _ s (FBind Nothing _ t2 e : k) -> return $ In t2 e s (FExec : k) + Out v s (FBind (Just x) mtr t2 e : k) -> do + let e' = case mtr of + Nothing -> addValueBinding x v e + Just (ty, reqs) -> addBinding x (Typed v ty reqs) e + return $ In t2 e' s (FExec : k) + -- To execute a suspend instruction, evaluate its argument and then + -- suspend. + Out (VSuspend t e) s (FExec : k) -> return $ In t e s (FSuspend e : k) + -- Once we've finished, enter the Suspended state. + Out v s (FSuspend e : k) -> return $ Suspended v e s k + -- Any other type of value wiwth an FExec frame is an error (should + -- never happen). + Out _ s (FExec : _) -> badMachineState s "FExec frame with non-executable value" + ------------------------------------------------------------ + -- Suspension + ------------------------------------------------------------ + + -- If we're suspended and see the env restore frame, we can discard + -- it: it was only there in case an exception was thrown. + Suspended v e s (FRestoreEnv _ : k) -> return $ Suspended v e s k + -- We can also sometimes get a redundant FExec; discard it. + Suspended v e s (FExec : k) -> return $ Suspended v e s k + -- If we're suspended but we were on the LHS of a bind, switch to + -- evaluating that, except with the environment from the suspension + -- instead of the environment stored in the FBind frame, as if the + -- RHS of the bind had been grafted in right where the suspend was, + -- i.e. the binds were reassociated. For example + -- + -- (x; z <- y; suspend z); q; r + -- + -- should be equivalent to + -- + -- x; z <- y; q; r + -- + Suspended _ e s (FBind Nothing _ t2 _ : k) -> return $ In t2 e s (FExec : k) + Suspended v e s (FBind (Just x) mtr t2 _ : k) -> do + let e' = case mtr of + Nothing -> addValueBinding x v e + Just (ty, reqs) -> addBinding x (Typed v ty reqs) e + return $ In t2 e' s (FExec : k) + -- Otherwise, if we're suspended with nothing else left to do, + -- return the machine unchanged (but throw away the rest of the + -- continuation stack). + Suspended v e s _ -> return $ Suspended v e s [] + ------------------------------------------------------------ + -- Exception handling + ------------------------------------------------------------ + + -- First, if we were running a try block but evaluation completed normally, + -- just ignore the try block and continue. + Out v s (FTry {} : k) -> return $ Out v s k + -- Also ignore restore frames when returning normally. + Out v s (FRestoreEnv {} : k) -> return $ Out v s k + -- If raising an exception up the stack and we reach the top, handle + -- it appropriately. + Up exn s [] -> handleException exn s Nothing + -- If we are raising an exception up the stack and we see an + -- FRestoreEnv frame, log the exception, switch into a suspended state, + -- and discard the rest of the stack. + Up exn s (FRestoreEnv e : _) -> handleException exn s (Just e) + -- If an atomic block threw an exception, we should terminate it. + Up exn s (FFinishAtomic : k) -> do + runningAtomic .= False + return $ Up exn s k + -- If we are raising a catchable exception up the continuation + -- stack and come to a Try frame, force and then execute the associated catch + -- block. + Up exn s (FTry c : k) + | isCatchable exn -> return $ Out c s (FApp (VCApp Force []) : FExec : k) + -- Otherwise, keep popping from the continuation stack. + Up exn s (_ : k) -> return $ Up exn s k + -- Finally, if we're done evaluating and the continuation stack is + -- empty, return the machine unchanged. + done@(Out _ _ []) -> return done + where + badMachineState s msg = + let msg' = + T.unlines + [ T.append "Bad machine state in stepRobot: " msg + , prettyText cesk + ] + in return $ Up (Fatal msg') s [] + + isCatchable = \case + Fatal {} -> False + Incapable {} -> False + InfiniteLoop {} -> False + _ -> True + + handleException exn s menv = do + case exn of + CmdFailed _ _ (Just a) -> do + grantAchievement a + _ -> return () + + -- If an exception rises all the way to the top level without being + -- handled, turn it into an error message. + -- + -- 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 + em <- use $ landscape . terrainAndEntities . entityMap + when h $ void $ traceLog RobotError (exnSeverity exn) (formatExn em exn) + return $ case menv of + Nothing -> Out VExc s [] + Just env -> Suspended VExc env s [] + +-- | Execute the given program *hypothetically*: i.e. in a fresh +-- CESK machine, using *copies* of the current store, robot +-- and game state. We discard the state afterwards so any +-- modifications made by prog do not persist. Note we also +-- set the copied robot to be a "system" robot so it is +-- capable of executing any commands; the As command +-- already requires "God" capability. +runChildProg :: + (HasRobotStepState sig m, Has Effect.Time sig m, Has (Lift IO) sig m) => + Store -> + Robot -> + Value -> + m Value +runChildProg s r prog = do + g <- get @GameState + evalState @Robot (r & systemRobot .~ True) . evalState @GameState g $ + runCESK (Out prog s [FApp (VCApp Force []), FExec]) + +-- | Execute a constant, catching any exception thrown and returning +-- it via a CESK machine state. +evalConst :: + (Has (State GameState) sig m, Has (State Robot) sig m, Has Effect.Time sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK +evalConst c vs s k = do + res <- runError $ execConst runChildProg c vs s k + case res of + Left exn -> return $ Up exn s k + Right cek' -> return cek' diff --git a/src/swarm-engine/Swarm/Game/Step/Arithmetic.hs b/src/swarm-engine/Swarm/Game/Step/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Arithmetic.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- 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) +import Data.Function (on) +import Data.Map qualified as M +import Data.Text qualified as T +import Swarm.Game.Exception +import Swarm.Game.Step.Util +import Swarm.Language.Syntax +import Swarm.Language.Value +import Witch (From (from)) +import Prelude hiding (Applicative (..), lookup) + +------------------------------------------------------------ +-- Comparison +------------------------------------------------------------ + +-- | Evaluate the application of a comparison operator. Returns +-- @Nothing@ if the application does not make sense. +evalCmp :: Has (Throw Exn) sig m => Const -> Value -> Value -> m Bool +evalCmp c v1 v2 = decideCmp c $ compareValues v1 v2 + where + decideCmp = \case + Eq -> fmap (== EQ) + Neq -> fmap (/= EQ) + Lt -> fmap (== LT) + Gt -> fmap (== GT) + Leq -> fmap (/= GT) + Geq -> fmap (/= LT) + _ -> const . throwError . Fatal . T.append "evalCmp called on bad constant " . from $ show c + +-- | Compare two values, returning an 'Ordering' if they can be +-- compared, or @Nothing@ if they cannot. +compareValues :: Has (Throw Exn) sig m => Value -> Value -> m Ordering +compareValues v1 = case v1 of + VUnit -> \case VUnit -> return EQ; v2 -> incompatCmp VUnit v2 + VInt n1 -> \case VInt n2 -> return (compare n1 n2); v2 -> incompatCmp v1 v2 + VText t1 -> \case VText t2 -> return (compare t1 t2); v2 -> incompatCmp v1 v2 + VDir d1 -> \case VDir d2 -> return (compare d1 d2); v2 -> incompatCmp v1 v2 + VBool b1 -> \case VBool b2 -> return (compare b1 b2); v2 -> incompatCmp v1 v2 + VRobot r1 -> \case VRobot r2 -> return (compare r1 r2); v2 -> incompatCmp v1 v2 + VInj s1 v1' -> \case + VInj s2 v2' -> + case compare s1 s2 of + EQ -> compareValues v1' v2' + o -> return o + v2 -> incompatCmp v1 v2 + VPair v11 v12 -> \case + VPair v21 v22 -> + (<>) <$> compareValues v11 v21 <*> compareValues v12 v22 + v2 -> incompatCmp v1 v2 + VRcd m1 -> \case + VRcd m2 -> mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2 + v2 -> incompatCmp v1 v2 + VKey kc1 -> \case + VKey kc2 -> return (compare kc1 kc2) + v2 -> incompatCmp v1 v2 + VClo {} -> incomparable v1 + VCApp {} -> incomparable v1 + VBind {} -> incomparable v1 + VDelay {} -> incomparable v1 + VRef {} -> incomparable v1 + VIndir {} -> incomparable v1 + VRequirements {} -> incomparable v1 + VSuspend {} -> incomparable v1 + VExc {} -> incomparable v1 + VBlackhole {} -> incomparable v1 + +-- | Values with different types were compared; this should not be +-- possible since the type system should catch it. +incompatCmp :: Has (Throw Exn) sig m => Value -> Value -> m a +incompatCmp v1 v2 = + throwError $ + Fatal $ + T.unwords ["Incompatible comparison of ", prettyValue v1, "and", prettyValue v2] + +-- | Values were compared of a type which cannot be compared +-- (e.g. functions, etc.). +incomparable :: Has (Throw Exn) sig m => Value -> Value -> m a +incomparable v1 v2 = + throwError $ + cmdExn + Lt + ["Comparison is undefined for ", prettyValue v1, "and", prettyValue v2] + +------------------------------------------------------------ +-- Arithmetic +------------------------------------------------------------ + +-- | Evaluate the application of an arithmetic operator, returning +-- an exception in the case of a failing operation, or in case we +-- incorrectly use it on a bad 'Const' in the library. +evalArith :: Has (Throw Exn) sig m => Const -> Integer -> Integer -> m Integer +evalArith = \case + Add -> ok (+) + Sub -> ok (-) + Mul -> ok (*) + Div -> safeDiv + Exp -> safeExp + c -> \_ _ -> throwError $ Fatal $ T.append "evalArith called on bad constant " (from (show c)) + where + ok f x y = return $ f x y + +-- | Perform an integer division, but return @Nothing@ for division by +-- zero. +safeDiv :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer +safeDiv _ 0 = throwError $ cmdExn Div $ pure "Division by zero" +safeDiv a b = return $ a `div` b + +-- | Perform exponentiation, but return @Nothing@ if the power is negative. +safeExp :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer +safeExp a b + | b < 0 = throwError $ cmdExn Exp $ pure "Negative exponent" + | otherwise = return $ a ^ b diff --git a/src/swarm-engine/Swarm/Game/Step/Combustion.hs b/src/swarm-engine/Swarm/Game/Step/Combustion.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Combustion.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Some entities are "combustible". A command, 'Swarm.Language.Syntax.Ignite', will +-- initiate combustion on such an entity. +-- Furthermore, combustion can spread to (4-)adjacent entities, depending +-- on the 'ignition' property of that entity. +-- +-- Short-lived robots are used to illustrate the combusting entity as +-- 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, (%=), (+=), (.=), (<+=), (<>=)) +import Control.Monad (forM_, when) +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Linear (zero) +import Swarm.Effect as Effect (Time, getNow) +import Swarm.Game.CESK (initMachine) +import Swarm.Game.Display +import Swarm.Game.Entity hiding (empty, lookup, singleton, union) +import Swarm.Game.Entity qualified as E +import Swarm.Game.Land +import Swarm.Game.Location +import Swarm.Game.Robot +import Swarm.Game.Robot.Walk (emptyExceptions) +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.Step.RobotStepState +import Swarm.Game.Step.Util +import Swarm.Game.Step.Util.Inspect +import Swarm.Game.Universe +import Swarm.Language.Pipeline.QQ (tmQ) +import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction (Direction) +import Swarm.Language.Text.Markdown qualified as Markdown +import Swarm.Util hiding (both) +import System.Clock (TimeSpec) +import Prelude hiding (Applicative (..), lookup) + +igniteCommand :: (HasRobotStepState sig m, Has Effect.Time sig m) => Const -> Direction -> m () +igniteCommand c d = do + (loc, me) <- lookInDirection d + -- Ensure there is an entity here. + e <- + me `isJustOrFail` ["There is nothing here to", verb <> "."] + + -- Ensure it can be ignited. + (e `hasProperty` Combustible) + `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."] + + -- Remove the entity from the world. + updateEntityAt loc (const Nothing) + flagRedraw + + -- Start burning process + let selfCombustibility = (e ^. entityCombustion) ? defaultCombustibility + createdAt <- getNow + combustionDurationRand <- addCombustionBot e selfCombustibility createdAt loc + forM_ (getNeighborLocs loc) $ igniteNeighbor createdAt combustionDurationRand + where + verb = "ignite" + verbed = "ignited" + + holdsOrFail = holdsOrFail' c + isJustOrFail = isJustOrFail' c + +-- | Construct a "combustion robot" from entity and position +-- and add it to the world. +-- It has low priority and will be covered +-- by placed entities. +-- The "combustion bot" represents the burning of a single +-- entity; propagating the fire to neighbors is handled upstream, +-- within the 'Swarm.Language.Syntax.Ignite' command. +addCombustionBot :: + Has (State GameState) sig m => + Entity -> + Combustibility -> + TimeSpec -> + Cosmic Location -> + m Integer +addCombustionBot inputEntity combustibility ts loc = do + em <- use $ landscape . terrainAndEntities . entityMap + let botInventory = fromMaybe [] $ do + e <- (`lookupEntityName` em) =<< maybeCombustionProduct + return $ pure (1, e) + combustionDurationRand <- uniform durationRange + let combustionProg = combustionProgram combustionDurationRand combustibility + zoomRobots + . addTRobot (initMachine combustionProg) + $ mkRobot + Nothing + "fire" + (Markdown.fromText $ T.unwords ["A burning", (inputEntity ^. entityName) <> "."]) + (Just loc) + zero + ( defaultEntityDisplay '*' + & displayAttr .~ AWorld "fire" + & displayPriority .~ 0 + ) + Nothing + [] + botInventory + True + False + emptyExceptions + ts + return combustionDurationRand + where + Combustibility _ durationRange maybeCombustionProduct = combustibility + +-- | A system program for a "combustion robot", to burn an entity +-- after it is ignited. +-- +-- For efficiency, we determine a priori (i.e. the instant +-- the combustion robot is spawned) whether any neighbors will eventually +-- be burned, based on probabilities. +-- +-- Note that it is possible that new neighbors may be introduced while +-- combustion is in progress. Although it may be more realistic to subject +-- these to possible combustion as well, we do not bother. +-- +-- Though if we did actually want to do that, some options are: +-- +-- 1. Create sub-partitions (of say, 10-tick duration) of the combustion duration +-- to re-evaluate opportunities to light adjacent entities on fire. +-- 2. Use the 'Swarm.Language.Syntax.Watch' command to observe for changes to adjacent entities. +-- Note that if we "wake" from our 'Swarm.Language.Syntax.Wait' due to the 'Swarm.Language.Syntax.Watch' being triggered, +-- we would need to maintain bookkeeping of how much time is left. +-- 3. Spawn more robots whose sole purpose is to observe for changes to neighbor +-- 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) = + [tmQ| + wait $int:combustionDuration; + if ($int:invQuantity > 0) { + try { + place $str:combustionProduct; + } {}; + } {}; + selfdestruct + |] + where + (invQuantity, combustionProduct) = case maybeCombustionProduct of + 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. +igniteNeighbor :: + Has (State GameState) sig m => + TimeSpec -> + Integer -> + Cosmic Location -> + m () +igniteNeighbor creationTime sourceDuration loc = do + maybeEnt <- entityAt loc + forM_ maybeEnt igniteEntity + where + igniteEntity e = + when (e `hasProperty` Combustible) $ do + threshold <- uniform (0, 1) + when (probabilityOfIgnition >= threshold) $ do + ignitionDelayRand <- uniform (0, 1) + let ignitionDelay = + floor + . min (fromIntegral sourceDuration) + . negate + $ log ignitionDelayRand / rate + zoomRobots $ addIgnitionBot ignitionDelay e creationTime loc + where + neighborCombustibility = (e ^. entityCombustion) ? defaultCombustibility + rate = E.ignition neighborCombustibility + probabilityOfIgnition = 1 - exp (negate $ rate * fromIntegral sourceDuration) + +-- | Construct an invisible "ignition robot" and add it to the world. +-- Its sole purpose is to delay the 'Swarm.Language.Syntax.Ignite' command for a neighbor +-- that has been a priori determined that it shall be ignited. +addIgnitionBot :: + Has (State Robots) sig m => + Integer -> + Entity -> + TimeSpec -> + Cosmic Location -> + m () +addIgnitionBot ignitionDelay inputEntity ts loc = + addTRobot (initMachine (ignitionProgram ignitionDelay)) $ + mkRobot + Nothing + "firestarter" + (Markdown.fromText $ T.unwords ["Delayed ignition of", (inputEntity ^. entityName) <> "."]) + (Just loc) + zero + ( defaultEntityDisplay '*' + & invisible .~ True + ) + Nothing + [] + [] + True + False + emptyExceptions + ts + +-- Triggers the ignition of the entity underfoot with some delay. +ignitionProgram :: Integer -> TSyntax +ignitionProgram waitTime = + [tmQ| + wait $int:waitTime; + try { + ignite down; + noop; + } {}; + selfdestruct + |] diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -0,0 +1,1779 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Robot command logic +-- +-- 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 +import Control.Effect.Lens +import Control.Effect.Lift +import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) +import Control.Monad (filterM, forM, forM_, guard, msum, unless, when) +import Data.Bifunctor (second) +import Data.Bool (bool) +import Data.Char (chr, ord) +import Data.Either (partitionEithers, rights) +import Data.Foldable (asum, for_, traverse_) +import Data.Foldable.Extra (findM, firstJustM) +import Data.Function (on) +import Data.Functor (void) +import Data.Int (Int32) +import Data.IntMap qualified as IM +import Data.IntSet qualified as IS +import Data.List (find, sortOn) +import Data.List qualified as L +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Map.NonEmpty qualified as NEM +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) +import Data.Ord (Down (Down)) +import Data.Sequence qualified as Seq +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Data.Tuple (swap) +import Linear (V2 (..), perp, zero) +import Swarm.Effect as Effect (Time, getNow) +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.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.Recognition.Registry (foundByName) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Step.Arithmetic +import Swarm.Game.Step.Combustion qualified as Combustion +import Swarm.Game.Step.Flood +import Swarm.Game.Step.Path.Finding +import Swarm.Game.Step.Path.Type +import Swarm.Game.Step.Path.Walkability +import Swarm.Game.Step.RobotStepState +import Swarm.Game.Step.Util +import Swarm.Game.Step.Util.Command +import Swarm.Game.Step.Util.Inspect +import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Tick +import Swarm.Game.Universe +import Swarm.Game.Value +import Swarm.Language.Capability +import Swarm.Language.Key (parseKeyComboFull) +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.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) + +-- | How to handle failure, for example when moving to blocked location +data RobotFailure = ThrowExn | Destroy | IgnoreFail + +-- | How to handle different types of failure when moving/teleporting +-- to a location. +type MoveFailureHandler = MoveFailureMode -> RobotFailure + +-- | Whether to remove the entity in the world inside the 'doGrab' function +-- or leave it to be done by other code. +data GrabRemoval = DeferRemoval | PerformRemoval + deriving (Eq) + +-- | Interpret the execution (or evaluation) of a constant application +-- to some values. +execConst :: + (HasRobotStepState sig m, Has Effect.Time sig m, Has (Lift IO) sig m) => + -- | Need to pass this function as an argument to avoid module import cycle + -- The supplied function invokes 'runCESK', which lives in "Swarm.Game.Step". + (Store -> Robot -> Value -> m Value) -> + Const -> + [Value] -> + Store -> + Cont -> + m CESK +execConst runChildProg c vs s k = do + -- First, ensure the robot is capable of executing/evaluating this constant. + ensureCanExecute c + + -- Increment command count regardless of success + when (isTangible c) $ + activityCounts . tangibleCommandCount += 1 + + activityCounts . commandsHistogram %= M.insertWith (+) c 1 + + -- Now proceed to actually carry out the operation. + case c of + Noop -> return $ mkReturn () + Return -> case vs of + [v] -> return $ Out v s k + _ -> badConst + Wait -> case vs of + [VInt d] -> do + time <- use $ temporal . ticks + purgeFarAwayWatches + return $ Waiting (addTicks (fromIntegral d) time) (mkReturn ()) + _ -> badConst + Selfdestruct -> do + destroyIfNotBase $ \case False -> Just AttemptSelfDestructBase; _ -> Nothing + flagRedraw + return $ mkReturn () + Move -> do + orientation <- use robotOrientation + moveInDirection $ orientation ? zero + Backup -> do + orientation <- use robotOrientation + moveInDirection $ applyTurn (DRelative $ DPlanar DBack) $ orientation ? zero + Volume -> case vs of + [VInt limit] -> do + when (limit > globalMaxVolume) $ + throwError $ + CmdFailed + Volume + ( T.unwords + [ "Can only measure up to" + , T.pack $ show globalMaxVolume + , "cells." + ] + ) + Nothing + + robotLoc <- use robotLocation + maybeResult <- floodFill robotLoc $ fromIntegral limit + return $ mkReturn maybeResult + _ -> badConst + Path -> case vs of + [VInj hasLimit limitVal, VInj findEntity goalVal] -> do + maybeLimit <- + if hasLimit + then case limitVal of + VInt d -> return $ Just d + _ -> badConst + else return Nothing + goal <- + if findEntity + then case goalVal of + VText eName -> return $ EntityTarget eName + _ -> badConst + else case goalVal of + VPair (VInt x) (VInt y) -> + return $ + LocationTarget $ + Location (fromIntegral x) (fromIntegral y) + _ -> badConst + robotLoc <- use robotLocation + result <- pathCommand $ PathfindingParameters maybeLimit robotLoc goal + return $ mkReturn result + _ -> badConst + Push -> do + -- Figure out where we're going + loc <- use robotLocation + orientation <- use robotOrientation + let applyHeading = (`offsetBy` (orientation ? zero)) + nextLoc = applyHeading loc + placementLoc = applyHeading nextLoc + + -- 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!"] + + 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 () + + updateRobotLocation loc nextLoc + return $ mkReturn () + Stride -> case vs of + [VInt d] -> do + when (d > fromIntegral maxStrideRange) $ + throwError $ + CmdFailed + Stride + ( T.unwords + [ "Can only stride up to" + , T.pack $ show maxStrideRange + , "units." + ] + ) + Nothing + + -- Figure out where we're going + loc <- use robotLocation + orientation <- use robotOrientation + let heading = orientation ? zero + + -- Excludes the base location. + let locsInDirection :: [Cosmic Location] + locsInDirection = + take (min (fromIntegral d) maxStrideRange) $ + drop 1 $ + iterate (`offsetBy` heading) loc + + failureMaybes <- mapM checkMoveFailure locsInDirection + let maybeFirstFailure = asum failureMaybes + + applyMoveFailureEffect maybeFirstFailure $ \case + PathBlockedBy _ -> ThrowExn + PathLiquid _ -> Destroy + + let maybeLastLoc = do + guard $ null maybeFirstFailure + listToMaybe $ reverse locsInDirection + + forM_ maybeLastLoc $ updateRobotLocation loc + + return $ mkReturn () + _ -> 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 () + _ -> badConst + Grab -> mkReturn <$> doGrab Grab' PerformRemoval + Harvest -> mkReturn <$> doGrab Harvest' PerformRemoval + Sow -> case vs of + [VText name] -> do + loc <- use robotLocation + + -- Make sure there's nothing already here + nothingHere <- isNothing <$> entityAt loc + nothingHere `holdsOrFail` ["There is already an entity here."] + + -- Make sure the robot has the thing in its inventory + e <- hasInInventoryOrFail name + + (terrainHere, _) <- contentAt loc + doPlantSeed terrainHere loc e + + -- Remove it from the inventory + robotInventory %= delete e + + return $ mkReturn () + _ -> badConst + Ignite -> case vs of + [VDir d] -> do + Combustion.igniteCommand c d + return $ mkReturn () + _ -> badConst + Swap -> case vs of + [VText name] -> do + loc <- use robotLocation + -- Make sure the robot has the thing in its inventory + e <- hasInInventoryOrFail name + -- Grab without removing from the world + newE <- doGrab Swap' DeferRemoval + + -- Place the entity and remove it from the inventory + updateEntityAt loc (const (Just e)) + robotInventory %= delete e + + when (e == newE) $ + grantAchievementForRobot SwapSame + + return $ mkReturn newE + _ -> badConst + Turn -> case vs of + [VDir d] -> do + when (isCardinal d) $ hasCapabilityFor COrient (TDir d) + robotOrientation . _Just %= applyTurn d + flagRedraw + + inst <- use equippedDevices + when (d == DRelative DDown && countByName "compass" inst == 0) $ do + grantAchievementForRobot GetDisoriented + + return $ mkReturn () + _ -> badConst + Place -> case vs of + [VText name] -> do + loc <- use robotLocation + + -- Make sure there's nothing already here + nothingHere <- isNothing <$> entityAt loc + nothingHere `holdsOrFail` ["There is already an entity here."] + + -- 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)) + robotInventory %= delete e + + flagRedraw + return $ mkReturn () + _ -> badConst + Ping -> case vs of + [VRobot otherID] -> do + maybeOtherRobot <- robotWithID otherID + selfRobot <- get + return $ mkReturn $ displacementVector selfRobot maybeOtherRobot + where + displacementVector :: Robot -> Maybe Robot -> Maybe (V2 Int32) + displacementVector selfRobot maybeOtherRobot = do + otherRobot <- maybeOtherRobot + let dist = (cosmoMeasure euclidean `on` view robotLocation) selfRobot otherRobot + (_minRange, maxRange) = getRadioRange (Just selfRobot) (Just otherRobot) + d <- getFiniteDistance dist + guard $ d <= maxRange + orientationBasedRelativePosition selfRobot $ view robotLocation otherRobot + _ -> badConst + Give -> case vs of + [VRobot otherID, VText itemName] -> do + -- Make sure the other robot exists and is close + _other <- getRobotWithinTouch otherID + + item <- ensureItem itemName "give" + + -- Giving something to ourself should be a no-op. We need + -- this as a special case since it will not work to modify + -- ourselves in the robotMap --- after performing a tick we + -- return a modified Robot which gets put back in the + -- robotMap, overwriting any changes to this robot made + -- directly in the robotMap during the tick. + myID <- use robotID + focusedID <- use $ robotInfo . focusedRobotID + if otherID /= myID + then do + -- Make the exchange + robotInfo . robotMap . at otherID . _Just . robotInventory %= insert item + robotInventory %= delete item + + -- Flag the UI for a redraw if we are currently showing either robot's inventory + when (focusedID == myID || focusedID == otherID) flagRedraw + else grantAchievementForRobot GaveToSelf + + return $ mkReturn () + _ -> badConst + Equip -> case vs of + [VText itemName] -> do + item <- ensureItem itemName "equip" + myID <- use robotID + focusedID <- use $ robotInfo . focusedRobotID + -- Don't do anything if the robot already has the device. + already <- use (equippedDevices . to (`E.contains` item)) + unless already $ do + equippedDevices %= insert item + robotInventory %= delete item + + -- Flag the UI for a redraw if we are currently showing our inventory + when (focusedID == myID) flagRedraw + + return $ mkReturn () + _ -> badConst + Unequip -> case vs of + [VText itemName] -> do + item <- ensureEquipped itemName + myID <- use robotID + focusedID <- use $ robotInfo . focusedRobotID + equippedDevices %= delete item + robotInventory %= insert item + -- Flag the UI for a redraw if we are currently showing our inventory + when (focusedID == myID) flagRedraw + return $ mkReturn () + _ -> badConst + Make -> case vs of + [VText name] -> do + inv <- use robotInventory + ins <- use equippedDevices + em <- use $ landscape . terrainAndEntities . entityMap + e <- + lookupEntityName name em + `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."] + + outRs <- use $ recipesInfo . recipesOut + + creative <- use creativeMode + let create l = l <> ["You can use 'create \"" <> name <> "\"' instead." | creative] + + -- Only consider recipes where the number of things we are trying to make + -- is greater in the outputs than in the inputs. This prevents us from doing + -- silly things like making copper pipes when the user says "make furnace". + let recipes = filter increase (recipesFor outRs e) + increase r = countIn (r ^. recipeOutputs) > countIn (r ^. recipeInputs) + countIn xs = maybe 0 fst (find ((== e) . snd) xs) + not (null recipes) + `holdsOrFail` create ["There is no known recipe for making", indefinite name <> "."] + + let displayMissingCount mc = \case + MissingInput -> from (show mc) + MissingCatalyst -> "not equipped" + displayMissingIngredient (MissingIngredient mk mc me) = + " - " <> me ^. entityName <> " (" <> displayMissingCount mc mk <> ")" + displayMissingIngredients xs = L.intercalate ["OR"] (map displayMissingIngredient <$> xs) + + -- Try recipes and make a weighted random choice among the + -- ones we have ingredients for. + let (badRecipes, goodRecipes) = partitionEithers . map (make (inv, ins)) $ recipes + chosenRecipe <- weightedChoice (^. _3 . recipeWeight) goodRecipes + (invTaken, changeInv, recipe) <- + chosenRecipe + `isJustOrFail` create + [ "You don't have the ingredients to make" + , indefinite name <> "." + , "Missing:\n" <> T.unlines (displayMissingIngredients badRecipes) + ] + + -- take recipe inputs from inventory and add outputs after recipeTime + robotInventory .= invTaken + traverse_ (updateDiscoveredEntities . snd) (recipe ^. recipeOutputs) + -- Grant CraftedBitcoin achievement + when (name == "bitcoin") $ + grantAchievementForRobot CraftedBitcoin + + finishCookingRecipe recipe VUnit [] (map (uncurry AddEntity) changeInv) + _ -> badConst + Has -> case vs of + [VText name] -> do + inv <- use robotInventory + return . mkReturn . (> 0) $ countByName name inv + _ -> badConst + Equipped -> case vs of + [VText name] -> do + inv <- use equippedDevices + return . mkReturn . (> 0) $ countByName name inv + _ -> badConst + Count -> case vs of + [VText name] -> do + inv <- use robotInventory + return . mkReturn $ countByName name inv + _ -> badConst + Scout -> case vs of + [VDir d] -> do + rMap <- use $ robotInfo . robotMap + myLoc <- use robotLocation + heading <- deriveHeading d + botsByLocs <- use $ robotInfo . robotsByLocation + selfRid <- use robotID + + -- Includes the base location, so we exclude the base robot later. + let locsInDirection :: [Cosmic Location] + locsInDirection = take maxScoutRange $ iterate (`offsetBy` heading) myLoc + + let hasOpaqueEntity = + fmap (maybe False (`hasProperty` E.Opaque)) . entityAt + + let hasVisibleBot :: Cosmic Location -> Bool + hasVisibleBot = any botIsVisible . IS.toList . excludeSelf . botsHere + where + excludeSelf = (`IS.difference` IS.singleton selfRid) + botsHere (Cosmic swName loc) = + M.findWithDefault mempty loc $ + M.findWithDefault mempty swName botsByLocs + botIsVisible = maybe False canSee . (`IM.lookup` rMap) + canSee = not . (^. robotDisplay . invisible) + + -- A robot on the same cell as an opaque entity is considered hidden. + -- Returns (Just Bool) if the result is conclusively visible or opaque, + -- or Nothing if we don't have a conclusive answer yet. + let isConclusivelyVisible :: Bool -> Cosmic Location -> Maybe Bool + isConclusivelyVisible isOpaque loc + | isOpaque = Just False + | hasVisibleBot loc = Just True + | otherwise = Nothing + + let isConclusivelyVisibleM loc = do + opaque <- hasOpaqueEntity loc + return $ isConclusivelyVisible opaque loc + + -- This ensures that we only evaluate locations until + -- a conclusive result is obtained, so we don't always + -- have to inspect the maximum range of the command. + result <- firstJustM isConclusivelyVisibleM locsInDirection + let foundBot = fromMaybe False result + return $ mkReturn foundBot + _ -> badConst + Whereami -> do + loc <- use robotLocation + return $ mkReturn $ loc ^. planar + Waypoint -> case vs of + [VText name, VInt idx] -> 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) + _ -> badConst + Structure -> case vs of + [VText name, VInt idx] -> do + registry <- use $ discovery . structureRecognition . foundStructures + let maybeFoundStructures = M.lookup name $ foundByName registry + mkOutput mapNE = (NE.length xs, bottomLeftCorner) + 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 + _ -> badConst + Floorplan -> case vs of + [VText name] -> do + structureTemplates <- use $ discovery . structureRecognition . automatons . originalStructureDefinitions + let maybeStructure = M.lookup name structureTemplates + structureDef <- + maybeStructure + `isJustOr` cmdExn Floorplan (pure $ T.unwords ["Unknown structure", quote name]) + return . mkReturn . getAreaDimensions $ entityProcessedGrid structureDef + _ -> badConst + HasTag -> case vs of + [VText eName, VText tName] -> do + em <- use $ landscape . terrainAndEntities . entityMap + e <- + lookupEntityName eName em + `isJustOrFail` ["I've never heard of", indefiniteQ eName <> "."] + return $ mkReturn $ tName `S.member` (e ^. entityTags) + _ -> badConst + TagMembers -> case vs of + [VText tagName, VInt idx] -> 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) + _ -> badConst + Detect -> case vs of + [VText name, VRect x1 y1 x2 y2] -> do + loc <- use robotLocation + let locs = rectCells x1 y1 x2 y2 + -- sort offsets by (Manhattan) distance so that we return the closest occurrence + let sortedOffsets = sortOn (\(V2 x y) -> abs x + abs y) locs + let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc + firstOne <- findM f sortedOffsets + return $ mkReturn firstOne + _ -> badConst + Resonate -> case vs of + [VText name, VRect x1 y1 x2 y2] -> doResonate (maybe False $ isEntityNamed name) x1 y1 x2 y2 + _ -> badConst + Density -> case vs of + [VRect x1 y1 x2 y2] -> doResonate isJust x1 y1 x2 y2 + _ -> badConst + Sniff -> case vs of + [VText name] -> do + firstFound <- findNearest name + return $ mkReturn $ maybe (-1) fst firstFound + _ -> badConst + Watch -> case vs of + [VDir d] -> do + (loc, _me) <- lookInDirection d + addWatchedLocation loc + return $ mkReturn () + _ -> badConst + Surveil -> case vs of + [VPair (VInt x) (VInt y)] -> do + Cosmic swName _ <- use robotLocation + let loc = Cosmic swName $ Location (fromIntegral x) (fromIntegral y) + addWatchedLocation loc + return $ mkReturn () + _ -> badConst + Chirp -> case vs of + [VText name] -> do + firstFound <- findNearest name + mh <- use robotOrientation + inst <- use equippedDevices + let processDirection entityDir = + if countByName "compass" inst >= 1 + then Just $ DAbsolute entityDir + else case mh >>= toDirection of + Just (DAbsolute robotDir) -> + Just . DRelative . DPlanar $ entityDir `relativeTo` robotDir + _ -> Nothing -- This may happen if the robot is facing "down" + d = fromMaybe (DRelative DDown) $ do + entLoc <- firstFound + guard $ snd entLoc /= zero + processDirection . nearestDirection . snd $ entLoc + return $ mkReturn d + _ -> badConst + Heading -> do + mh <- use robotOrientation + -- In general, (1) entities might not have an orientation, and + -- (2) even if they do, orientation is a general vector, which + -- might not correspond to a cardinal direction. We could make + -- 'heading' return a @Maybe Dir@ (/i.e./ @Unit + Dir@), or return a + -- vector of type @Int * Int@, but those would both be annoying + -- for players in the vast majority of cases. We rather choose + -- to just return the direction 'down' in any case where we don't + -- otherwise have anything reasonable to return. + return . mkReturn . fromMaybe (DRelative DDown) $ mh >>= toDirection + Time -> do + TickNumber t <- use $ temporal . ticks + return $ Out (VInt $ fromIntegral t) s k + Drill -> case vs of + [VDir d] -> doDrill d + _ -> badConst + Use -> case vs of + [VText deviceName, VDir d] -> do + ins <- use equippedDevices + equippedEntity <- ensureEquipped deviceName + let verbPhrase = T.unwords ["use", deviceName, "on"] + applyDevice ins verbPhrase d equippedEntity + _ -> badConst + Blocked -> do + loc <- use robotLocation + orientation <- use robotOrientation + let nextLoc = loc `offsetBy` (orientation ? zero) + me <- entityAt nextLoc + return $ mkReturn $ maybe False (`hasProperty` Unwalkable) me + Scan -> case vs of + [VDir d] -> do + (_loc, me) <- lookInDirection d + for_ me $ \e -> do + robotInventory %= insertCount 0 e + updateDiscoveredEntities e + -- Flag the world for a redraw since scanning something may + -- change the way it is drawn (if the base is doing the + -- scanning) + flagRedraw + return $ mkReturn me + _ -> badConst + Knows -> case vs of + [VText name] -> do + inv <- use robotInventory + ins <- use equippedDevices + let allKnown = inv `E.union` ins + let knows = case E.lookupByName name allKnown of + [] -> False + _ -> True + return $ mkReturn knows + _ -> badConst + Upload -> case vs of + [VRobot otherID] -> do + -- Make sure the other robot exists and is close + _other <- getRobotWithinTouch otherID + + -- Upload knowledge of everything in our inventory + inv <- use robotInventory + forM_ (elems inv) $ \(_, e) -> + robotInfo . robotMap . at otherID . _Just . robotInventory %= insertCount 0 e + + -- Upload our log + rlog <- use robotLog + robotInfo . robotMap . at otherID . _Just . robotLog <>= rlog + + -- Flag the world for redraw since uploading may change the + -- base's knowledge and hence how entities are drawn (if they + -- go from unknown to known). + flagRedraw + + return $ mkReturn () + _ -> badConst + Random -> case vs of + [VInt hi] -> do + n <- uniform (0, hi - 1) + return $ mkReturn n + _ -> badConst + Atomic -> goAtomic + Instant -> goAtomic + As -> case vs of + [VRobot rid, prog] -> do + r <- robotWithID rid >>= (`isJustOrFail` ["There is no actor with ID", from (show rid)]) + v <- runChildProg s r prog + + -- Return the value returned by the hypothetical command. + return $ Out v s k + _ -> badConst + RobotNamed -> case vs of + [VText rname] -> do + r <- robotWithName rname >>= (`isJustOrFail` ["There is no robot named", rname]) + return $ mkReturn r + _ -> badConst + RobotNumbered -> case vs of + [VInt rid] -> do + r <- + robotWithID (fromIntegral rid) + >>= (`isJustOrFail` ["There is no robot with number", from (show rid)]) + return $ mkReturn r + _ -> badConst + Say -> case vs of + [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' + robotsAround <- + zoomRobots $ + if isPrivileged + then use $ robotMap . to IM.elems + else gets $ robotsInArea loc hearingDistance + mapM_ addToRobotLog robotsAround + return $ mkReturn () + _ -> badConst + Listen -> do + gs <- get @GameState + loc <- use robotLocation + rid <- use robotID + isPrivileged <- isPrivilegedBot + mq <- use $ messageInfo . messageQueue + let isClose e = isPrivileged || messageIsFromNearby loc e + notMine e = case e ^. leSource of + SystemLog {} -> False + RobotLog _ lrid _ -> rid /= lrid + limitLast = \case + _s Seq.:|> l -> Just $ l ^. leText + _ -> Nothing + mm = limitLast . Seq.filter (liftA2 (&&) notMine isClose) $ Seq.takeWhileR (messageIsRecent gs) mq + return $ + maybe + (In (TConst Listen) mempty s (FExec : k)) -- continue listening + (\m -> Out (VText m) s k) -- return found message + mm + Log -> case vs of + [VText msg] -> do + void $ traceLog Logged Info msg + return $ mkReturn () + _ -> badConst + View -> case vs of + [VRobot rid] -> do + -- Only the base can actually change the view in the UI. Other robots can + -- execute this command but it does nothing (at least for now). + rn <- use robotID + when (rn == 0) $ + robotWithID rid >>= \case + -- If the robot does not exist... + Nothing -> do + cr <- use creativeMode + ws <- use $ landscape . worldScrollable + case cr || ws of + -- If we are in creative mode or allowed to scroll, then we are allowed + -- to learn that the robot doesn't exist. + True -> throwError $ cmdExn c ["There is no actor with ID", from (show rid), "to view."] + -- Otherwise, "unfocus" from any robot, which + -- means the world view will turn to static. The + -- point is that there's no way to tell the difference + -- between this situation and the situation where the + -- robot exists but is too far away. + False -> robotInfo %= unfocus + + -- If it does exist, set it as the view center. + Just _ -> robotInfo . viewCenterRule .= VCRobot rid + + return $ mkReturn () + _ -> badConst + Appear -> case vs of + [VText app, VInj hasAttr mattr] -> do + -- Set the robot's display character(s) + case into @String app of + [dc] -> do + robotDisplay . defaultChar .= dc + robotDisplay . orientationMap .= M.empty + [dc, nc, ec, sc, wc] -> do + robotDisplay . defaultChar .= dc + robotDisplay + . orientationMap + .= M.fromList + [ (DNorth, nc) + , (DEast, ec) + , (DSouth, sc) + , (DWest, wc) + ] + _other -> + raise + Appear + [ quote app + , "is not a valid appearance string." + , "'appear' must be given a string with exactly 1 or 5 characters." + ] + + -- Possibly set the display attribute + case (hasAttr, mattr) of + (True, VText attr) -> robotDisplay . displayAttr .= readAttribute attr + _ -> return () + + flagRedraw + return $ mkReturn () + _ -> badConst + Create -> case vs of + [VText name] -> do + em <- use $ landscape . terrainAndEntities . entityMap + e <- + lookupEntityName name em + `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."] + + robotInventory %= insert e + updateDiscoveredEntities e + + return $ mkReturn () + _ -> badConst + Halt -> case vs of + [VRobot targetID] -> do + myID <- use robotID + case myID == targetID of + -- To halt ourselves, just return a cancelled CESK machine. + -- It will be reinstalled as our current machine; then, + -- based on the fact that our CESK machine is done we will + -- be put to sleep and the REPL will be reset if we are the + -- base robot. + True -> return $ cancel $ mkReturn () + False -> do + -- Make sure the other robot exists and is close enough. + target <- getRobotWithinTouch targetID + -- Make sure either we are privileged, OR the target robot + -- is NOT. In other words unprivileged bots should not be + -- able to halt privileged ones. + omni <- isPrivilegedBot + case omni || not (target ^. systemRobot) of + True -> zoomRobots $ do + -- Cancel its CESK machine, and put it to sleep. + robotMap . at targetID . _Just . machine %= cancel + sleepForever targetID + return $ mkReturn () + False -> throwError $ cmdExn c ["You are not authorized to halt that robot."] + _ -> badConst + Ishere -> case vs of + [VText name] -> do + loc <- use robotLocation + me <- entityAt loc + let here = maybe False (isEntityNamed name) me + return $ mkReturn here + _ -> badConst + Isempty -> do + loc <- use robotLocation + me <- entityAt loc + return $ mkReturn $ isNothing me + Self -> do + rid <- use robotID + return $ Out (VRobot rid) s k + Parent -> do + mp <- use robotParentID + rid <- use robotID + return $ Out (VRobot (fromMaybe rid mp)) s k + Base -> return $ Out (VRobot 0) s k + Meet -> do + loc <- use robotLocation + rid <- use robotID + g <- get @GameState + let neighbor = + find ((/= rid) . (^. robotID)) -- pick one other than ourself + . sortOn ((manhattan `on` view planar) loc . (^. robotLocation)) -- prefer closer + $ 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 + return $ mkReturn neighborIDs + Whoami -> case vs of + [] -> do + name <- use robotName + return $ mkReturn name + _ -> badConst + Setname -> case vs of + [VText name] -> do + robotName .= name + return $ mkReturn () + _ -> badConst + Force -> case vs of + [VDelay t e] -> return $ In t e s k + _ -> badConst + If -> case vs of + -- Use the boolean to pick the correct branch, and apply @force@ to it. + [VBool b, thn, els] -> return $ Out (bool els thn b) s (FApp (VCApp Force []) : k) + _ -> badConst + Inl -> case vs of + [v] -> return $ Out (VInj False v) s k + _ -> badConst + Inr -> case vs of + [v] -> return $ Out (VInj True v) s k + _ -> badConst + 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 + _ -> badConst + Try -> case vs of + [c1, c2] -> return $ Out c1 s (FApp (VCApp Force []) : FExec : FTry c2 : k) + _ -> badConst + Undefined -> return $ Up (User "undefined") s k + Fail -> case vs of + [VText msg] -> return $ Up (User msg) s k + _ -> badConst + Key -> case vs of + [VText ktxt] -> case runParser parseKeyComboFull "" ktxt of + Right kc -> return $ Out (VKey kc) s k + Left _ -> return $ Up (CmdFailed Key (T.unwords ["Unknown key", quote ktxt]) Nothing) s k + _ -> badConst + InstallKeyHandler -> case vs of + [VText hint, handler] -> do + gameControls . inputHandler .= Just (hint, handler) + return $ mkReturn () + _ -> badConst + Reprogram -> case vs of + [VRobot childRobotID, VDelay cmd env] -> do + r <- get + isPrivileged <- isPrivilegedBot + + -- check if robot exists + childRobot <- + robotWithID childRobotID + >>= (`isJustOrFail` ["There is no actor with ID", from (show childRobotID) <> "."]) + + -- check that current robot is not trying to reprogram self + myID <- use robotID + (childRobotID /= myID) + `holdsOrFail` ["You cannot make a robot reprogram itself."] + + -- check if robot has completed executing it's current command + _ <- + finalValue (childRobot ^. machine) + `isJustOrFail` ["You cannot reprogram a robot that is actively running a program."] + + -- check if childRobot is at the correct distance + -- a robot can program adjacent robots + -- privileged bots ignore distance checks + loc <- use robotLocation + + isNearbyOrExempt isPrivileged loc (childRobot ^. robotLocation) + `holdsOrFail` ["You can only reprogram an adjacent robot."] + + -- Figure out if we can supply what the target robot requires, + -- and if so, what is needed. + (toEquip, toGive) <- + checkRequirements + env + (r ^. robotInventory) + (childRobot ^. robotInventory) + (childRobot ^. equippedDevices) + cmd + "The target robot" + FixByObtainDevice + + -- Update other robot's CESK machine. The child robot + -- inherits the parent robot's environment + store. + zoomRobots $ do + robotMap . at childRobotID . _Just . machine .= In cmd env s [FExec] + + -- Provision the target robot with any required devices and + -- inventory that are lacking. + provisionChild childRobotID (fromList . S.toList $ toEquip) toGive + + -- Finally, re-activate the reprogrammed target robot. + zoomRobots $ activateRobot childRobotID + + return $ mkReturn () + _ -> badConst + Build -> case vs of + -- NOTE, pattern-matching on a VDelay here means we are + -- /relying/ on the fact that 'Build' can only be given a + -- /non-memoized/ delayed value. If it were given a memoized + -- delayed value we would see a VRef instead of a VDelay. If + -- and Try are generalized to handle any type of delayed value, + -- but Build and Reprogram still assume they are given a VDelay + -- and not a VRef. In the future, if we enable memoized delays + -- by default, or allow the user to explicitly request + -- memoization via double braces or something similar, this will + -- have to be generalized. The difficulty is that we do a + -- capability check on the delayed program at runtime, just + -- before creating the newly built robot (see the call to + -- 'requirements' below); but if we have a VRef instead of a + -- VDelay, we may only be able to get a Value out of it instead + -- of a Term as we currently do, and capability checking a Value + -- is annoying and/or problematic. One solution might be to + -- annotate delayed expressions with their required capabilities + -- at typechecking time, and carry those along so they flow to + -- this point. Another solution would be to just bite the bullet + -- and figure out how to do capability checking on Values (which + -- would return the capabilities needed to *execute* them), + -- hopefully without duplicating too much code. + [VDelay cmd e] -> do + r <- get @Robot + pid <- use robotID + + (toEquip, toGive) <- + checkRequirements e (r ^. robotInventory) E.empty E.empty cmd "You" FixByObtainDevice + + -- Pick a random display name. + displayName <- randomName + createdAt <- getNow + isSystemRobot <- use systemRobot + + -- Construct the new robot and add it to the world. + let newDisplay = case r ^. robotDisplay . childInheritance of + Invisible -> defaultRobotDisplay & invisible .~ True + Inherit -> defaultRobotDisplay & inherit displayAttr (r ^. robotDisplay) + DefaultDisplay -> defaultRobotDisplay + newRobot <- + zoomRobots . addTRobot' (In cmd e s [FExec]) $ + mkRobot + (Just pid) + displayName + (Markdown.fromText $ "A robot built by the robot named " <> (r ^. robotName) <> ".") + (Just (r ^. robotLocation)) + ( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir) + ? north + ) + newDisplay + Nothing + [] + [] + isSystemRobot + False + emptyExceptions + createdAt + + -- Provision the new robot with the necessary devices and inventory. + provisionChild (newRobot ^. robotID) (fromList . S.toList $ toEquip) toGive + + -- Flag the world for a redraw and return the ID of the newly constructed robot. + flagRedraw + return $ mkReturn newRobot + _ -> badConst + Salvage -> case vs of + [] -> do + loc <- use robotLocation + let okToSalvage r = (r ^. robotID /= 0) && (not . isActive $ r) + mtarget <- gets (find okToSalvage . robotsAtLocation loc) + case mtarget of + Nothing -> return $ mkReturn () -- Nothing to salvage + Just target -> do + -- Copy the salvaged robot's equipped devices into its inventory, in preparation + -- for transferring it. + let salvageInventory = E.union (target ^. robotInventory) (target ^. equippedDevices) + robotInfo . robotMap . at (target ^. robotID) . traverse . robotInventory .= salvageInventory + + let salvageItems = concatMap (\(n, e) -> replicate n (e ^. entityName)) (E.elems salvageInventory) + numItems = length salvageItems + + -- Copy over the salvaged robot's log, if we have one + inst <- use equippedDevices + em <- use $ landscape . terrainAndEntities . entityMap + isPrivileged <- isPrivilegedBot + logger <- + lookupEntityName "logger" em + `isJustOr` Fatal "While executing 'salvage': there's no such thing as a logger!?" + when (isPrivileged || inst `E.contains` logger) $ robotLog <>= target ^. robotLog + + -- Immediately copy over any items the robot knows about + -- but has 0 of + let knownItems = map snd . filter ((== 0) . fst) . elems $ salvageInventory + robotInventory %= \i -> foldr (insertCount 0) i knownItems + + -- Now reprogram the robot being salvaged to 'give' each + -- item in its inventory to us, one at a time, then + -- self-destruct at the end. Make it a system robot so we + -- don't have to worry about capabilities. + robotInfo . robotMap . at (target ^. robotID) . traverse . systemRobot .= True + + ourID <- use @Robot robotID + + -- The program for the salvaged robot to run + let giveInventory = + foldr (TBind Nothing Nothing Nothing . giveItem) (TConst Selfdestruct) salvageItems + giveItem item = TApp (TApp (TConst Give) (TRobot ourID)) (TText item) + + -- Reprogram and activate the salvaged robot + zoomRobots $ do + robotMap + . at (target ^. robotID) + . traverse + . machine + .= In giveInventory mempty emptyStore [FExec] + + activateRobot $ target ^. robotID + + -- Now wait the right amount of time for it to finish. + time <- use $ temporal . ticks + return $ Waiting (addTicks (numItems + 1) time) (mkReturn ()) + _ -> badConst + -- run can take both types of text inputs + -- with and without file extension as in + -- "./path/to/file.sw" and "./path/to/file" + Run -> case vs of + [VText fileName] -> do + let filePath = into @String fileName + sData <- throwToMaybe @SystemFailure $ getDataFileNameSafe Script filePath + sDataSW <- throwToMaybe @SystemFailure $ getDataFileNameSafe Script (filePath <> ".sw") + mf <- sendIO $ mapM readFileMay $ [filePath, filePath <> ".sw"] <> catMaybes [sData, sDataSW] + + f <- msum mf `isJustOrFail` ["File not found:", fileName] + + mt <- + processTerm (into @Text f) `isRightOr` \err -> + cmdExn Run ["Error in", fileName, "\n", err] + + case mt of + Nothing -> return $ mkReturn () + Just t -> do + void $ traceLog CmdStatus Info "run: OK." + cesk <- use machine + return $ continue t cesk + _ -> badConst + Not -> case vs of + [VBool b] -> return $ Out (VBool (not b)) s k + _ -> badConst + Neg -> case vs of + [VInt n] -> return $ Out (VInt (-n)) s k + _ -> badConst + Eq -> returnEvalCmp + Neq -> returnEvalCmp + Lt -> returnEvalCmp + Gt -> returnEvalCmp + Leq -> returnEvalCmp + Geq -> returnEvalCmp + And -> case vs of + [VBool a, VBool b] -> return $ Out (VBool (a && b)) s k + _ -> badConst + Or -> case vs of + [VBool a, VBool b] -> return $ Out (VBool (a || b)) s k + _ -> badConst + Add -> returnEvalArith + Sub -> returnEvalArith + Mul -> returnEvalArith + Div -> returnEvalArith + Exp -> returnEvalArith + Format -> case vs of + [v] -> return $ mkReturn $ prettyValue v + _ -> badConst + Chars -> case vs of + [VText t] -> return $ mkReturn $ T.length t + _ -> badConst + Split -> case vs of + [VInt i, VText t] -> + let p = T.splitAt (fromInteger i) t + t2 = over both VText p + in return $ Out (uncurry VPair t2) s k + _ -> badConst + Concat -> case vs of + [VText v1, VText v2] -> return $ mkReturn $ v1 <> v2 + _ -> badConst + CharAt -> case vs of + [VInt i, VText t] + | i < 0 || i >= fromIntegral (T.length t) -> + raise CharAt ["Index", prettyValue (VInt i), "out of bounds for length", from @String $ show (T.length t)] + | otherwise -> return . mkReturn . ord . T.index t . fromIntegral $ i + _ -> badConst + ToChar -> case vs of + [VInt i] + | i < 0 || i > fromIntegral (ord (maxBound :: Char)) -> + raise ToChar ["Value", prettyValue (VInt i), "is an invalid character code"] + | otherwise -> + return . mkReturn . T.singleton . chr . fromIntegral $ i + _ -> badConst + AppF -> + let msg = "The operator '$' should only be a syntactic sugar and removed in elaboration:\n" + in throwError . Fatal $ msg <> badConstMsg + where + doDrill d = do + ins <- use equippedDevices + + let equippedDrills = extantElemsWithCapability CDrill ins + -- Heuristic: choose the drill with the more elaborate name. + -- E.g. "metal drill" vs. "drill" + preferredDrill = listToMaybe $ sortOn (Down . T.length . (^. entityName)) equippedDrills + + tool <- preferredDrill `isJustOr` Fatal "Drill is required but not equipped?!" + applyDevice ins "drill" d tool + + applyDevice ins verbPhrase d tool = do + (nextLoc, nextE) <- getDeviceTarget verbPhrase d + inRs <- use $ recipesInfo . recipesIn + + let recipes = filter isApplicableRecipe (recipesFor inRs nextE) + isApplicableRecipe = any ((== tool) . snd) . view recipeCatalysts + + not (null recipes) + `holdsOrFail` [ "There is no way to" + , verbPhrase + , indefinite (nextE ^. entityName) <> "." + ] + + inv <- use robotInventory + + -- add the targeted entity so it can be consumed by the recipe + let makeRecipe r = (,r) <$> make' (insert nextE inv, ins) r + chosenRecipe <- + weightedChoice (\((_, _), r) -> r ^. recipeWeight) $ + rights $ + map makeRecipe recipes + ((invTaken, outs), recipe) <- + chosenRecipe + `isJustOrFail` ["You don't have the ingredients to", verbPhrase, indefinite (nextE ^. entityName) <> "."] + + let (out, down) = L.partition ((`hasProperty` Pickable) . snd) outs + learn = map (LearnEntity . snd) down + gain = map (uncurry AddEntity) out + + newEnt <- case down of + [] -> pure Nothing + [(1, de)] -> pure $ Just de + _ -> throwError $ Fatal "Bad recipe:\n more than one unmovable entity produced." + let changeWorld = + ReplaceEntity + { updatedLoc = nextLoc + , originalEntity = nextE + , newEntity = newEnt + } + + -- take recipe inputs from inventory and add outputs after recipeTime + robotInventory .= invTaken + + let cmdOutput = asValue $ snd <$> listToMaybe out + finishCookingRecipe recipe cmdOutput [changeWorld] (learn <> gain) + + getDeviceTarget verb d = do + rname <- use robotName + + (nextLoc, nextME) <- lookInDirection d + nextE <- + nextME + `isJustOrFail` ["There is nothing to", verb, directionText, "robot", rname <> "."] + return (nextLoc, nextE) + where + directionText = case d of + DRelative DDown -> "under" + DRelative (DPlanar DForward) -> "ahead of" + DRelative (DPlanar DBack) -> "behind" + _ -> directionSyntax d <> " of" + + goAtomic :: HasRobotStepState sig m => m CESK + goAtomic = case vs of + -- To execute an atomic block, set the runningAtomic flag, + -- push an FFinishAtomic frame so that we unset the flag when done, and + -- proceed to execute the argument. + [cmd] -> do + runningAtomic .= True + return $ Out cmd s (FExec : FFinishAtomic : k) + _ -> badConst + + -- Case-insensitive matching on entity names + isEntityNamed :: T.Text -> Entity -> Bool + isEntityNamed n e = ((==) `on` T.toLower) (e ^. entityName) n + + badConst :: HasRobotStepState sig m => m a + badConst = throwError $ Fatal badConstMsg + + badConstMsg :: Text + badConstMsg = + T.unlines + [ "Bad application of execConst:" + , T.pack (show c) + , T.pack (show vs) + , prettyText (Out (VCApp c (reverse vs)) s k) + ] + + doResonate :: + (HasRobotStepState sig m, Has (Lift IO) sig m) => + (Maybe Entity -> Bool) -> + Integer -> + Integer -> + Integer -> + Integer -> + m CESK + doResonate p x1 y1 x2 y2 = do + loc <- use robotLocation + let offsets = rectCells x1 y1 x2 y2 + hits <- mapM (fmap (fromEnum . p) . entityAt . offsetBy loc) offsets + return $ Out (VInt $ fromIntegral $ sum hits) s k + + rectCells :: Integer -> Integer -> Integer -> Integer -> [V2 Int32] + rectCells x1 y1 x2 y2 = + rectCellsInt32 + (fromIntegral x1) + (fromIntegral y1) + (fromIntegral x2) + (fromIntegral y2) + + rectCellsInt32 :: Int32 -> Int32 -> Int32 -> Int32 -> [V2 Int32] + rectCellsInt32 x1 y1 x2 y2 = [V2 x y | x <- [xMin .. xMax], y <- [yMin .. yMax]] + where + (xMin, xMax) = sortPair (x1, x2) + (yMin, yMax) = sortPair (y1, y2) + + findNearest :: + HasRobotStepState sig m => + Text -> + m (Maybe (Int32, V2 Int32)) + findNearest name = do + loc <- use robotLocation + let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc . snd + findM f sortedOffsets + where + sortedOffsets :: [(Int32, V2 Int32)] + sortedOffsets = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange] + + -- Grow a list of locations in a diamond shape outward, such that the nearest cells + -- are searched first by construction, rather than having to sort. + genDiamondSides :: Int32 -> [(Int32, V2 Int32)] + genDiamondSides diameter = concat [f diameter x | x <- [0 .. diameter]] + where + -- Adds a single cell to each of the four sides of the diamond + f d x = map (d,) . take 4 . iterate perp $ V2 x (d - x) + + finishCookingRecipe :: + HasRobotStepState sig m => + Recipe e -> + Value -> + [WorldUpdate Entity] -> + [RobotUpdate] -> + m CESK + finishCookingRecipe r v wf rf = + if remTime <= 0 + then do + updateWorldAndRobots c wf rf + return $ Out v s k + else do + time <- use $ temporal . ticks + return . (if remTime <= 1 then id else Waiting (addTicks (fromIntegral remTime) time)) $ + Out v s (FImmediate c wf rf : k) + where + remTime = r ^. recipeTime + + ensureEquipped :: HasRobotStepState sig m => Text -> m Entity + ensureEquipped itemName = do + inst <- use equippedDevices + listToMaybe (lookupByName itemName inst) + `isJustOrFail` ["You don't have", indefinite itemName, "equipped."] + + ensureItem :: HasRobotStepState sig m => Text -> Text -> m Entity + ensureItem itemName action = do + -- First, make sure we know about the entity. + inv <- use robotInventory + inst <- use equippedDevices + item <- + asum (map (listToMaybe . lookupByName itemName) [inv, inst]) + `isJustOrFail` ["What is", indefinite itemName <> "?"] + + -- Next, check whether we have one. If we don't, add a hint about + -- 'create' in creative mode. + creative <- use creativeMode + let create l = l <> ["You can make one first with 'create \"" <> itemName <> "\"'." | creative] + + (E.lookup item inv > 0) + `holdsOrFail` create ["You don't have", indefinite itemName, "to", action <> "."] + + return item + + -- Check the required devices and inventory for running the given + -- command on a target robot. This function is used in common by + -- both 'Build' and 'Reprogram'. + -- + -- It is given as inputs the parent robot inventory, the inventory + -- and equipped devices of the child (these will be empty in the + -- case of 'Build'), and the command to be run (along with a few + -- inputs to configure any error messages to be generated). + -- + -- Throws an exception if it's not possible to set up the child + -- robot with the things it needs to execute the given program. + -- Otherwise, returns a pair consisting of the set of devices to be + -- equipped, and the inventory that should be transferred from + -- parent to child. + checkRequirements :: + HasRobotStepState sig m => + Env -> + Inventory -> + Inventory -> + Inventory -> + Term -> + Text -> + IncapableFix -> + m (Set Entity, Inventory) + checkRequirements e parentInventory childInventory childDevices cmd subject fixI = do + let reqCtx = e ^. envReqs + tdCtx = e ^. envTydefs + em <- use $ landscape . terrainAndEntities . entityMap + privileged <- isPrivilegedBot + let R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames = + R.requirements tdCtx reqCtx cmd + + -- Check that all required device names exist (fail with + -- an exception if not) and convert them to 'Entity' values. + (devs :: [Entity]) <- forM devNames $ \devName -> + E.lookupEntityName devName em `isJustOrFail` ["Unknown device required: " <> devName] + + -- Check that all required inventory entity names exist (fail with + -- an exception if not) and convert them to 'Entity' values, with + -- an associated count for each. + (reqInv :: Inventory) <- fmap E.fromElems . forM (M.assocs reqInvNames) $ \(eName, n) -> + (n,) + <$> ( E.lookupEntityName eName em + `isJustOrFail` ["Unknown entity required: " <> eName] + ) + + let -- List of possible devices per requirement. For the + -- requirements that stem from a required capability, we + -- remember the capability alongside the possible devices, to + -- help with later error message generation. + possibleDevices :: [(Maybe Capability, [Entity])] + possibleDevices = + map (Just &&& (`devicesForCap` em)) caps -- Possible devices for capabilities + ++ map ((Nothing,) . (: [])) devs -- Outright required devices + + -- A device is OK if it is available in the inventory of the + -- parent robot, or already equipped in the child robot. + deviceOK :: Entity -> Bool + deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d + + -- Partition each list of possible devices into a set of + -- available devices and a set of unavailable devices. + -- There's a problem if some capability is required but no + -- devices that provide it are available. In that case we can + -- print an error message, using the second set as a list of + -- suggestions. + partitionedDevices :: [(Set Entity, Set Entity)] + partitionedDevices = + map (Lens.over both S.fromList . L.partition deviceOK . snd) possibleDevices + + -- Devices equipped on the child, as a Set instead of an + -- Inventory for convenience. + alreadyEquipped :: Set Entity + alreadyEquipped = S.fromList . map snd . E.elems $ childDevices + + -- Figure out what is still missing of the required inventory: + -- the required inventory, less any inventory the child robot + -- already has. + missingChildInv = reqInv `E.difference` childInventory + + if privileged + then + return + ( -- When 'privileged', just equip ALL the devices + -- providing each required capability (because, why + -- not?). But don't re-equip any that are already + -- equipped. + S.unions (map (S.fromList . snd) possibleDevices) `S.difference` alreadyEquipped + , -- Conjure the necessary missing inventory out of thin + -- air. + missingChildInv + ) + else do + -- First, check that devices actually exist AT ALL to provide every + -- required capability. If not, we will generate an error message saying + -- something like "missing capability X but no device yet provides it". + let capsWithNoDevice = mapMaybe fst . filter (null . snd) $ possibleDevices + null capsWithNoDevice + `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 + let IncapableFixWords fVerb fNoun = formatIncapableFix fixI + null missingDevices + `holdsOrFail` ( singularSubjectVerb subject "do" + : "not have required " <> fNoun <> ", please" + : fVerb <> ":" + : (("\n - " <>) . formatDevices <$> missingDevices) + ) + + let minimalEquipSet = smallHittingSet (filter (S.null . S.intersection alreadyEquipped) (map fst partitionedDevices)) + + -- Check that we have enough in our inventory to cover the + -- required devices PLUS what's missing from the child + -- inventory. + + -- What do we need? + neededParentInv = + missingChildInv + `E.union` (fromList . S.toList $ minimalEquipSet) + + -- What are we missing? + missingParentInv = neededParentInv `E.difference` parentInventory + missingMap = + M.fromList + . filter ((> 0) . snd) + . map (swap . second (^. entityName)) + . E.elems + $ missingParentInv + + -- If we're missing anything, throw an error + E.isEmpty missingParentInv + `holdsOr` Incapable fixI (R.Requirements S.empty S.empty missingMap) cmd + + return (minimalEquipSet, missingChildInv) + + -- Destroy the current robot, as long as it is not the base robot. + -- + -- Depending on whether we destroy (True) or do not destroy + -- (False) the current robot, possibly grant an achievement. + -- + -- Note we cannot simply return a Boolean and grant achievements + -- at call sites, because in the case that we do not destroy the + -- base we actually throw an exception, so we do not return to the + -- original call site. + destroyIfNotBase :: + (HasRobotStepState sig m, Has (Lift IO) sig m) => + (Bool -> Maybe GameplayAchievement) -> + m () + destroyIfNotBase mAch = do + rid <- use robotID + holdsOrFailWithAchievement + (rid /= 0) + ["You consider destroying your base, but decide not to do it after all."] + (mAch False) + + selfDestruct .= True + maybe (return ()) grantAchievementForRobot (mAch True) + + moveInDirection :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Heading -> m CESK + moveInDirection orientation = do + -- Figure out where we're going + loc <- use robotLocation + let nextLoc = loc `offsetBy` orientation + checkMoveAhead nextLoc $ \case + PathBlockedBy _ -> ThrowExn + PathLiquid _ -> Destroy + updateRobotLocation loc nextLoc + return $ mkReturn () + + 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!"] + + -- Determine the move failure mode and apply the corresponding effect. + checkMoveAhead :: + (HasRobotStepState sig m, Has (Lift IO) sig m) => + Cosmic Location -> + MoveFailureHandler -> + m () + checkMoveAhead nextLoc failureHandler = do + maybeFailure <- checkMoveFailure nextLoc + applyMoveFailureEffect maybeFailure failureHandler + + getRobotWithinTouch :: HasRobotStepState sig m => RID -> m Robot + getRobotWithinTouch rid = do + cid <- use robotID + if cid == rid + then get @Robot + else do + mother <- robotWithID rid + other <- mother `isJustOrFail` ["There is no robot with ID", from (show rid) <> "."] + + let otherLoc = other ^. robotLocation + privileged <- isPrivilegedBot + myLoc <- use robotLocation + + -- Make sure it is either in the same location or we do not care + isNearbyOrExempt privileged myLoc otherLoc + `holdsOrFail` ["The robot with ID", from (show rid), "is not close enough."] + return other + + holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m () + holdsOrFail = holdsOrFail' c + + holdsOrFailWithAchievement :: (Has (Throw Exn) sig m) => Bool -> [Text] -> Maybe GameplayAchievement -> m () + holdsOrFailWithAchievement a ts mAch = case mAch of + Nothing -> holdsOrFail a ts + Just ach -> a `holdsOr` cmdExnWithAchievement c ts ach + + isJustOrFail :: (Has (Throw Exn) sig m) => Maybe a -> [Text] -> m a + isJustOrFail = isJustOrFail' c + + returnEvalCmp = case vs of + [v1, v2] -> (\b -> Out (VBool b) s k) <$> evalCmp c v1 v2 + _ -> badConst + returnEvalArith = case vs of + [VInt n1, VInt n2] -> (\r -> Out (VInt r) s k) <$> evalArith c n1 n2 + _ -> badConst + + -- Make sure the robot has the thing in its inventory + hasInInventoryOrFail :: HasRobotStepState sig m => Text -> m Entity + hasInInventoryOrFail eName = do + inv <- use robotInventory + e <- + listToMaybe (lookupByName eName inv) + `isJustOrFail` ["What is", indefinite eName <> "?"] + let cmd = T.toLower . T.pack . show $ c + (E.lookup e inv > 0) + `holdsOrFail` ["You don't have", indefinite eName, "to", cmd <> "."] + return e + + mkReturn :: Valuable a => a -> CESK + mkReturn x = Out (asValue x) s k + + doPlantSeed :: + (HasRobotStepState sig m, Has Effect.Time sig m) => + TerrainType -> + Cosmic Location -> + Entity -> + m () + doPlantSeed terrainHere loc e = do + when ((e `hasProperty` Growable) && isAllowedInBiome terrainHere e) $ do + let Growth maybeMaturesTo maybeSpread (GrowthTime (minT, maxT)) = + (e ^. entityGrowth) ? defaultGrowth + + em <- use $ landscape . terrainAndEntities . entityMap + let seedEntity = fromMaybe e $ (`lookupEntityName` em) =<< maybeMaturesTo + + createdAt <- getNow + let radius = maybe 1 spreadRadius maybeSpread + seedlingDensity = maybe 0 spreadDensity maybeSpread + -- See https://en.wikipedia.org/wiki/Triangular_number#Formula + seedlingArea = 1 + 2 * (radius * (radius + 1)) + seedlingCount = floor $ seedlingDensity * fromIntegral seedlingArea + + -- Grow a new entity from a seed. + addSeedBot + seedEntity + (minT, maxT) + seedlingCount + (fromIntegral radius) + loc + createdAt + where + isAllowedInBiome terr ent = + null biomeRestrictions + || terr `S.member` biomeRestrictions + where + biomeRestrictions = ent ^. entityBiomes + + -- The code for grab and harvest is almost identical, hence factored + -- out here. + -- Optionally defer removal from the world, for the case of the Swap command. + doGrab :: (HasRobotStepState sig m, Has Effect.Time sig m) => GrabbingCmd -> GrabRemoval -> m Entity + doGrab cmd removalDeferral = do + let verb = verbGrabbingCmd cmd + verbed = verbedGrabbingCmd cmd + + -- Ensure there is an entity here. + loc <- use robotLocation + (terrainHere, maybeEntityHere) <- contentAt loc + e <- maybeEntityHere `isJustOrFail` ["There is nothing here to", verb <> "."] + + -- Ensure it can be picked up. + omni <- isPrivilegedBot + (omni || e `hasProperty` Pickable) + `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."] + + -- Entities with 'infinite' property are not removed + unless (removalDeferral == DeferRemoval || e `hasProperty` Infinite) $ do + -- Remove the entity from the world. + updateEntityAt loc (const Nothing) + flagRedraw + + -- Possibly regrow the entity, if it is growable and the 'harvest' + -- command was used. + when (cmd == Harvest') $ + doPlantSeed terrainHere loc e + + -- Add the picked up item to the robot's inventory. If the + -- entity yields something different, add that instead. + e' <- case e ^. entityYields of + Nothing -> return e + Just yielded -> + -- NOTE: Using 'fromMaybe' here is a consequence of the inability + -- to validate the lookup at parse time. Compare to 'entityCapabilities' + -- (see summary of #1777). + fromMaybe e <$> uses (landscape . terrainAndEntities . entityMap) (lookupEntityName yielded) + + robotInventory %= insert e' + updateDiscoveredEntities e' + + -- Return the item obtained. + return e' diff --git a/src/swarm-engine/Swarm/Game/Step/Flood.hs b/src/swarm-engine/Swarm/Game/Step/Flood.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Flood.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Implementation of the 'Swarm.Language.Syntax.Volume' command for robots. +-- +-- Note: If the robot is currently on an unwalkable cell (which may happen in +-- the case of teleportation or if an entity is placed or pushed into its cell), +-- the volume shall be zero. +module Swarm.Game.Step.Flood ( + floodFill, +) where + +import Control.Effect.Lens +import Control.Lens (makeLenses, (%~), (&)) +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Swarm.Game.Location +import Swarm.Game.Step.RobotStepState +import Swarm.Game.Step.Util (checkMoveFailureUnprivileged) +import Swarm.Game.Step.Util.Inspect (getNeighborLocs) +import Swarm.Game.Universe + +data FloodParms = FloodParms + { theSubworld :: SubworldName + , maxVisits :: Int + } + +data Tracking = Tracking + { visited :: HashSet Location + , floodPartition :: FloodPartition + } + +-- | We annotate each visited cell as +-- being part of the boundary or the interior. +-- This lets us: +-- +-- 1. Use the interior cell count as a termination condition +-- 2. Handle (eventual) cache invalidation differently for boundary +-- members than interior members. +data FloodPartition = FloodPartition + { _boundary :: HashSet Location + , _interior :: HashSet Location + } + +makeLenses ''FloodPartition + +-- | +-- == Algorithm +-- +-- Explore via DFS using a list as a stack. +-- Each iteration examines a single cell. +-- +-- 1. Mark the popped cell as visited, regardless of walkability. +-- 2. Check popped cell for walkability +-- 3. Add all neighbors that aren't already visited, regardless of walkability, to the stack. +-- But unwalkable cells shall not produce neighbors and shall be marked with a boundary/interior distinction. +floodRecursive :: + HasRobotStepState sig m => + Tracking -> + [Location] -> + FloodParms -> + m (Maybe Int) +floodRecursive tracking pending params = + case pending of + nextLoc : otherLocs -> + if interiorCount > maxVisits params + then return Nothing + else checkNeighbors nextLoc otherLocs + [] -> return $ Just interiorCount + where + interiorCount = HashSet.size $ _interior $ floodPartition tracking + checkNeighbors nextLoc otherLocs = do + isWalkable <- null <$> checkMoveFailureUnprivileged cosmicLoc + let candidateNeighbors = + if isWalkable + then map (view planar) $ getNeighborLocs cosmicLoc + else [] + visitableNeighbors = filter (not . (`HashSet.member` visited tracking)) candidateNeighbors + + -- It's cheaper to prepend the "visitableNeighbors" list because + -- it should in general be a shorter list than the "pending" list. + newPending = visitableNeighbors <> otherLocs + + partitionMutator = + if isWalkable + then interior + else boundary + newPartition = floodPartition tracking & partitionMutator %~ HashSet.insert nextLoc + + newTracking = + tracking + { visited = newVisited + , floodPartition = newPartition + } + floodRecursive newTracking newPending params + where + newVisited = HashSet.insert nextLoc $ visited tracking + cosmicLoc = Cosmic (theSubworld params) nextLoc + +floodFill :: + HasRobotStepState sig m => + Cosmic Location -> + Int -> + m (Maybe Int) +floodFill (Cosmic swn curLoc) = + floodRecursive emptyTracking [curLoc] . FloodParms swn + where + emptyTracking = Tracking mempty $ FloodPartition mempty mempty diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs b/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs @@ -0,0 +1,237 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Pathfinding cache invalidation logic +-- +-- == Overview +-- Each time the 'Path' command is invoked, the computed +-- shortest-path is placed in in a cache specific to the invoking robot. +-- If the 'Path' command is invoked again by that robot +-- with identical arguments and from the same position, or a position lying +-- on the previously computed path, then the shortest path shall +-- be retrieved from the cache instead of being recomputed. +-- +-- If the 'Path' command is re-invoked with different arguments +-- or from a novel position, then the shortest-path shall be +-- recomputed and the cache overwritten with this new result. +-- +-- Asynchronous to the event of invoking the 'Path' command, +-- there are a variety of events that may invalidate +-- a previously-computed shortest path between some +-- location and a destination, including adding or removing +-- particular entities at certain locations. +-- +-- Certain events allow for partial re-use of the previously +-- computed path. +module Swarm.Game.Step.Path.Cache ( + retrieveCachedPath, + revalidatePathCache, + recordCache, +) where + +import Control.Arrow (left, (&&&)) +import Control.Carrier.State.Lazy +import Control.Effect.Lens +import Control.Lens ((^.)) +import Control.Monad (unless) +import Data.Either.Extra (maybeToEither) +import Data.IntMap qualified as IM +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Tuple.Extra (both) +import Swarm.Game.Entity +import Swarm.Game.Location +import Swarm.Game.Robot +import Swarm.Game.Robot.Walk +import Swarm.Game.State +import Swarm.Game.Step.Path.Cache.DistanceLimit +import Swarm.Game.Step.Path.Type +import Swarm.Game.Step.Path.Walkability (checkUnwalkable) +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 + +-- | Fetch the previously computed shortest path from the cache. +-- Log success or the reason it failed. +retrieveCachedPath :: + HasRobotStepState sig m => + WalkabilityContext -> + PathfindingParameters (Cosmic Location) -> + m (Either CacheRetreivalInapplicability [Location]) +retrieveCachedPath currentWalkabilityContext newParms = do + pcr <- use $ pathCaching . pathCachingRobots + rid <- use robotID + let eitherCachedPath = guardFailures rid pcr + myEntry :: CacheRetrievalAttempt + myEntry = either RecomputationRequired (const Success) eitherCachedPath + + pathCaching . pathCachingLog + %= RB.insert (CacheLogEntry rid $ RetrievalAttempt myEntry) + + return eitherCachedPath + where + PathfindingParameters currentDistanceLimit (Cosmic currentSubworld currentRobotLoc) target = newParms + + guardFailures rid pcr = do + -- Checks whether this robot has a cached path + cached <- maybeToEither NotCached $ IM.lookup rid pcr + + let PathfindingCache prevParms prevWalkabilityContext _targetLoc (CachedPath pathCells (TailMap ps)) = cached + PathfindingParameters prevDistLimit previousSubworldName t = prevParms + + -- Subworlds must match + unless (previousSubworldName == currentSubworld) $ + Left $ + DifferentArg NewSubworld + + -- Pathfinding target type must match + unless (t == target) $ + Left $ + DifferentArg NewTargetType + + -- Walkability context must match + unless (currentWalkabilityContext == prevWalkabilityContext) $ + Left $ + DifferentArg NewWalkabilityContext + + left (DifferentArg . NewDistanceLimit) $ + getDistanceLimitInvalidation currentRobotLoc pathCells currentDistanceLimit prevDistLimit + + -- Checks whether invoked from the same position or a position lying + -- on the previously computed path + maybeToEither PositionOutsidePath $ M.lookup currentRobotLoc ps + +-- | Store a newly computed shortest path in the cache. +recordCache :: + HasRobotStepState sig m => + PathfindingParameters SubworldName -> + WalkabilityContext -> + -- | includes robot starting position + NonEmpty Location -> + m () +recordCache parms wc pathLocs = do + rid <- use robotID + pathCaching . pathCachingRobots %= IM.insert rid newCache + where + newCache = PathfindingCache parms wc (NE.last pathLocs) $ CachedPath pathLocs $ mkTailMap pathLocs + +-- | For every non-empty suffix of the path, place its tail in a map keyed +-- by its head. +mkTailMap :: NonEmpty Location -> TailMap +mkTailMap pathLocs = TailMap locsMap + where + locsMap = M.fromList . NE.toList . NE.map (NE.head &&& NE.tail) $ tails1 pathLocs + +-- | +-- Returns either a 'Left' which mandates cache invalidation (with a reason), +-- or a 'Right' containing a 'Maybe'; 'Nothing' indicates the cache should +-- remain unchanged, while 'Just' supplies a modified cache entry. +-- +-- Cache is affected by modification of: +-- +-- * cell walkability (i.e., an entity is placed or removed +-- that is "unwalkable" (blacklist) or "exclusively walkable" (whitelist) +-- with respect to the invoking robot +-- * "target" entities (if the `path` command had been invoked +-- with the modified entity as a target). Note that it is impossible +-- to find a path to an "unwalkable" target, so this nonsensical case +-- is ignored for the purpose of cache invalidation. +perhapsInvalidateForRobot :: + WalkabilityContext -> + -- | location of modified cell + Cosmic Location -> + -- | nature of entity modification + CellModification Entity -> + PathfindingCache -> + Either InvalidationReason (Maybe PathfindingCache) +perhapsInvalidateForRobot + walkInfo + (Cosmic swn entityLoc) + entityModification + oldCache@(PathfindingCache parms _previousWalkabilityInfo destLoc p) + | swn /= pathSubworld = Right Nothing + | otherwise = case entityModification of + Swap oldEntity newEntity -> deriveBarrierModification $ both Just (oldEntity, newEntity) + Remove oldEntity -> deriveBarrierModification (Just oldEntity, Nothing) + Add newEntity -> deriveBarrierModification (Nothing, Just newEntity) + where + PathfindingParameters _distLimit pathSubworld tgt = parms + CachedPath origPath (TailMap locmap) = p + + isWalkable = null . checkUnwalkable walkInfo + isOnPath = entityLoc `M.member` locmap + + -- NOTE: oldContent and newContent are guaranteed to be different, + -- because the 'Swap' constructor enforces such. + deriveBarrierModification change@(_oldContent, newContent) = + case tgt of + LocationTarget _locTarget -> barrierChange + -- If the location of the changed entity was the terminus + -- of the path, and the path search is "by entity", then + -- we know that the path must be invalidated due to removal + -- of the goal. + -- Also, we know that a "target entity" on the path will + -- only ever exist the path's terminus; otherwise the + -- terminus would have been earlier! + EntityTarget targetEntityName -> handleEntityTarget targetEntityName + where + handleEntityTarget targetEntityName + | destLoc == entityLoc = Left TargetEntityRemoved + | maybe True ((/= targetEntityName) . (^. entityName)) newContent = barrierChange + | isOnPath = Right $ Just $ truncatePath origPath entityLoc oldCache + | otherwise = Left TargetEntityAddedOutsidePath + + walkabilityPair = both isWalkable change + barrierChange + | uncurry (==) walkabilityPair = Right Nothing + | snd walkabilityPair = Left UnwalkableRemoved + | isOnPath = Left UnwalkableOntoPath + -- addition of a barrier outside of the path is irrelevant. + | otherwise = Right Nothing + +-- | If the newly-added target entity lies on the existing path, +-- truncate the path to set it as the goal. +truncatePath :: + NonEmpty Location -> + Location -> + PathfindingCache -> + PathfindingCache +truncatePath origPath entityLoc oldCache = + oldCache {cachedPath = CachedPath truncPath $ mkTailMap truncPath} + where + truncPath = prependList truncPathExcludingEntityLoc $ pure entityLoc + truncPathExcludingEntityLoc = takeWhile (== entityLoc) $ NE.toList origPath + +-- | Given an event that entails the modification of some cell, +-- check whether a shortest-path previously computed for a +-- given robot is still valid or can be updated. +revalidatePathCache :: + (Has (State GameState) sig m) => + Cosmic Location -> + CellModification Entity -> + (RID, PathfindingCache) -> + m () +revalidatePathCache entityLoc entityModification (rid, pc) = do + maybeRobot <- robotWithID rid + let (logEntry, updateFunc) = getCacheUpdate $ checkPath maybeRobot + pathCaching . pathCachingRobots %= updateFunc + pathCaching . pathCachingLog %= RB.insert (CacheLogEntry rid logEntry) + where + checkPath = \case + Nothing -> Left NonexistentRobot + Just bot -> + perhapsInvalidateForRobot + (view walkabilityContext bot) + entityLoc + entityModification + pc + + getCacheUpdate = \case + Left reason -> (Invalidate reason, IM.delete rid) + Right maybeReplacement -> case maybeReplacement of + Nothing -> (Preserve Unmodified, id) + Just newCache -> (Preserve PathTruncated, IM.insert rid newCache) diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Cache/DistanceLimit.hs b/src/swarm-engine/Swarm/Game/Step/Path/Cache/DistanceLimit.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Path/Cache/DistanceLimit.hs @@ -0,0 +1,69 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Handles cache invalidation if the distance +-- limit is modified between invocations of +-- the 'Path' command. +module Swarm.Game.Step.Path.Cache.DistanceLimit ( + getDistanceLimitInvalidation, + withinDistance, +) where + +import Control.Monad (unless) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Swarm.Game.Location +import Swarm.Game.Step.Path.Type + +-- | +-- A greater distance limit might yield a shorter path +-- if there was a better route that just needed to venture outside +-- of the allowed radius. +-- +-- On the other hand, a smaller distance limit /will not/ invalidate +-- the cache so long as all cells on the path are within the new limit. +getDistanceLimitInvalidation :: + -- | current robot location + Location -> + -- | original path + NonEmpty Location -> + -- | current limit + Maybe Integer -> + -- | previous limit + Maybe Integer -> + Either DistanceLimitChange () +-- Limit unchanged: +getDistanceLimitInvalidation _ _ Nothing Nothing = return () +-- Limit was increased to infinity: +getDistanceLimitInvalidation _ _ Nothing (Just _) = Left LimitIncreased +-- Limit was decreased from infinity: +getDistanceLimitInvalidation robotLoc pathCells (Just currLimit) Nothing = + handleLimitDecreased robotLoc pathCells currLimit +getDistanceLimitInvalidation robotLoc pathCells (Just currLimit) (Just prevLimit) + | currLimit < prevLimit = handleLimitDecreased robotLoc pathCells currLimit + | currLimit > prevLimit = Left LimitIncreased + | otherwise = return () -- Limit unchanged + +handleLimitDecreased :: + Location -> + NonEmpty Location -> + Integer -> + Either DistanceLimitChange () +handleLimitDecreased robotLoc pathCells currLimit = + unless (all (withinDistance currLimit robotLoc) $ NE.tail pathCells) $ + Left PathExceededLimit + +-- * Utility functions + +-- | This function is shared between path computation logic +-- and patch cache invalidation logic to ensure that +-- the choice of inequality operator is consistent (e.g. @<@ vs. @<=@). +withinDistance :: + -- | distance limit + Integer -> + -- | current robot location + Location -> + -- | target location + Location -> + Bool +withinDistance distLimit robotLoc = (<= distLimit) . fromIntegral . manhattan robotLoc diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Finding.hs b/src/swarm-engine/Swarm/Game/Step/Path/Finding.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Path/Finding.hs @@ -0,0 +1,154 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Implementation of the 'Swarm.Language.Syntax.Path' command for robots. +-- +-- = Design considerations +-- In general the playfield can be dynamic, and obstructions may +-- appear that invalidate a given computed shortest path. +-- Therefore, there would be limited value in a command that returns +-- an entirely static computed path that is somehow stored on the client side +-- (i.e. inside a swarm-lang program). +-- +-- In the current implementation, a complete path is computed +-- internally upon invoking the @path@ command +-- and doled out incrementally across ticks. +-- Each @path@ invocation returns the direction of the +-- next "move" along the computed shortest path. +-- +-- This internally stored path is re-used across invocations until some +-- event invalidates its cache (see "Swarm.Game.Step.Path.Cache"). +-- +-- == Max distance +-- +-- We allow the caller to supply a max distance, but also impose an internal maximum +-- distance to prevent programming errors from irrecoverably freezing the game. +module Swarm.Game.Step.Path.Finding where + +import Control.Carrier.State.Lazy +import Control.Effect.Lens +import Control.Lens ((^.)) +import Control.Monad (filterM, guard) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Graph.AStar (aStarM) +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Swarm.Game.Entity +import Swarm.Game.Location +import Swarm.Game.Robot +import Swarm.Game.State +import Swarm.Game.Step.Path.Cache +import Swarm.Game.Step.Path.Cache.DistanceLimit (withinDistance) +import Swarm.Game.Step.Path.Type +import Swarm.Game.Step.RobotStepState +import Swarm.Game.Step.Util +import Swarm.Game.Step.Util.Inspect +import Swarm.Game.Universe +import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction +import Swarm.Util (hoistMaybe) + +-- | Swarm command arguments are converted to idiomatic Haskell +-- types before invoking this function, and conversely the callsite +-- is also responsible for translating the output type to a swarm value. +-- +-- The cost function is uniformly @1@ between adjacent cells. +-- +-- Viable paths are determined by walkability. +-- If the goal type is an 'Entity', then it is permissible for that +-- entity to be 'Unwalkable'. +-- +-- See "Swarm.Game.Step.Path.Cache" for caching details. +pathCommand :: + HasRobotStepState sig m => + PathfindingParameters (Cosmic Location) -> + m (Maybe (Direction, Int)) +pathCommand parms = do + currentWalkabilityContext <- use walkabilityContext + + -- First, check if the pathfinding target has a cached path. + eitherCachedPath <- retrieveCachedPath currentWalkabilityContext parms + + case eitherCachedPath of + Right foundCachedPath -> return $ Just $ mkResult foundCachedPath + Left _ -> do + -- This is a short-circuiting optimization; if the goal location itself + -- is not a walkable cell, then no amount of searching will reach it. + isGoalLocWalkable <- case target of + LocationTarget loc -> null <$> checkMoveFailure (Cosmic currentSubworld loc) + EntityTarget _ -> return True + + runMaybeT $ do + guard isGoalLocWalkable + maybeFoundPath <- lift computePath + foundPath <- hoistMaybe maybeFoundPath + -- NOTE: This will not cache the fact that a path was not found. + lift $ recordCache (fmap (^. subworld) parms) currentWalkabilityContext $ robotLoc :| foundPath + return $ mkResult foundPath + where + mkResult p = (nextDir p, length p) + PathfindingParameters maybeDistanceLimit (Cosmic currentSubworld robotLoc) target = parms + + computePath = + aStarM + (neighborFunc withinDistanceLimit . Cosmic currentSubworld) + (const $ const $ return 1) + (return . distHeuristic) + goalReachedFunc + (return robotLoc) + + withinDistanceLimit :: Location -> Bool + withinDistanceLimit = withinDistance distLimit robotLoc + + directionTo :: Location -> Direction + directionTo nextLoc = DAbsolute $ nearestDirection $ nextLoc .-. robotLoc + + -- Extracts the head of the found path to determine + -- the next direction for the robot to proceed along + nextDir :: [Location] -> Direction + nextDir pathLocs = case pathLocs of + [] -> DRelative DDown + (nextLoc : _) -> directionTo nextLoc + + neighborFunc :: + HasRobotStepState sig m => + (Location -> Bool) -> + Cosmic Location -> + m (HashSet Location) + neighborFunc isWithinRange loc = do + locs <- filterM isWalkableLoc neighborLocs + return $ HashSet.fromList $ map (view planar) locs + where + neighborLocs = getNeighborLocs loc + isWalkableLoc someLoc = + if not $ isWithinRange $ view planar someLoc + then return False + else do + isGoal <- goalReachedFunc $ view planar someLoc + if isGoal + then return True + else null <$> checkMoveFailureUnprivileged someLoc + + -- This is an optimization for when a specific location + -- is given as the target. + -- However, it is not strictly necessary, and in fact + -- cannot be used when the target is a certain type of + -- entity. + distHeuristic :: Location -> Int32 + distHeuristic = case target of + LocationTarget gLoc -> manhattan gLoc + EntityTarget _eName -> const 0 + + goalReachedFunc :: Has (State GameState) sig m => Location -> m Bool + goalReachedFunc loc = case target of + LocationTarget gLoc -> return $ loc == gLoc + EntityTarget eName -> do + me <- entityAt $ Cosmic currentSubworld loc + return $ (view entityName <$> me) == Just eName + + -- A failsafe limit is hardcoded to prevent the game from freezing + -- if an error exists in some .sw code. + distLimit = maybe maxPathRange (min maxPathRange) maybeDistanceLimit diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Type.hs b/src/swarm-engine/Swarm/Game/Step/Path/Type.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Path/Type.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types for shortest-path-finding and logging +-- path-cache invalidation events. +-- +-- By convention, a @[Location]@ /does not/ include the +-- starting location, whereas a @NonEmpty Location@ does. +-- +-- Consequentially, an empty @[Location]@ implies that +-- the robot's current location is already at the goal location. +-- +-- A gratuitous number of sum types are defined here +-- to facilitate explainability of caching behavior via logs. +module Swarm.Game.Step.Path.Type where + +import Control.Lens +import Data.Aeson (ToJSON (..), genericToJSON) +import Data.IntMap.Strict (IntMap) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Map qualified as M +import GHC.Generics (Generic) +import Swarm.Game.Entity +import Swarm.Game.Location +import Swarm.Game.Robot (RID) +import Swarm.Game.Robot.Walk (WalkabilityContext) +import Swarm.Game.Universe (SubworldName) +import Swarm.Util.JSON (optionsMinimize) +import Swarm.Util.Lens (makeLensesNoSigs) +import Swarm.Util.RingBuffer + +maxLogEntries :: Int +maxLogEntries = 32 + +-- | This is parameterized on the starting location, +-- as we may either want to: +-- +-- 1. provide the planar start location (when first /computing/ the path), or +-- 2. suppress it and only propagate the subworld name +-- (when /retrieving/ from cache), which precludes the downstream possibility +-- of accidentally mixing up the planar location of the /target/ +-- with the current /robot location/. +data PathfindingParameters a = PathfindingParameters + { distanceLimit :: Maybe Integer + -- ^ Manhattan distance limit on cells to explore + -- (NOTE: this is not a "path length" limit) + , startingLoc :: a + -- ^ Starting location + , searchGoal :: PathfindingTarget + -- ^ Search goal + } + deriving (Generic, Eq, Show, ToJSON, Functor) + +-- | It is possible for the cache to be unaffected +-- by certain events, or the cache may modified without +-- fully recomputing the shortest path. +data CachePreservationMode + = Unmodified + | PathTruncated + deriving (Show, Eq, Generic, ToJSON) + +data CacheLogEntry = CacheLogEntry + { robot :: RID + , event :: CacheEvent + } + deriving (Show, Eq, Generic, ToJSON) + +data CacheRetrievalAttempt + = Success + | RecomputationRequired CacheRetreivalInapplicability + deriving (Show, Eq, Generic) + +instance ToJSON CacheRetrievalAttempt where + toJSON = genericToJSON optionsMinimize + +-- | Certain events can obligate the cache to be +-- completely invalidated, or partially or fully preserved. +data CacheEvent + = Invalidate InvalidationReason + | Preserve CachePreservationMode + | RetrievalAttempt CacheRetrievalAttempt + deriving (Show, Eq, Generic) + +instance ToJSON CacheEvent where + toJSON = genericToJSON optionsMinimize + +data DistanceLimitChange + = LimitIncreased + | PathExceededLimit + deriving (Show, Eq, Generic, ToJSON) + +data DifferentArgument + = NewSubworld + | NewTargetType + | NewWalkabilityContext + | NewDistanceLimit DistanceLimitChange + deriving (Show, Eq, Generic, ToJSON) + +-- | Reasons why we cannot re-use a precomputed path +-- from the cache upon re-invoking the 'Path' command +data CacheRetreivalInapplicability + = NotCached + | DifferentArg DifferentArgument + | PositionOutsidePath + deriving (Show, Eq, Generic) + +instance ToJSON CacheRetreivalInapplicability where + toJSON = genericToJSON optionsMinimize + +-- | Reasons for cache being invalidated +data InvalidationReason + = TargetEntityAddedOutsidePath + | TargetEntityRemoved + | UnwalkableRemoved + | UnwalkableOntoPath + | NonexistentRobot + deriving (Show, Eq, Generic, ToJSON) + +emptyPathCache :: PathCaching +emptyPathCache = PathCaching mempty $ mkRingBuffer $ Finite maxLogEntries + +-- | Shortest paths can either be computed to the nearest entity of +-- a given type or to a specific location. +data PathfindingTarget + = LocationTarget Location + | -- | Note: navigation to entities does not benefit from the + -- distance heuristic optimization of the A* algorithm + -- (but see #1568) + EntityTarget EntityName + deriving (Generic, Eq, Show, ToJSON) + +-- | Facilitates lookup of any shortest path to a particular +-- goal cell, given a location that already lies on a +-- shortest path. +newtype TailMap = TailMap (Map Location [Location]) + deriving (Generic, Eq, Show) + +instance ToJSON TailMap where + toJSON (TailMap x) = toJSON $ M.toList x + +data CachedPath = CachedPath + { originalPath :: NonEmpty Location + , locations :: TailMap + -- ^ Fast lookup map of path suffix by + -- current location + } + deriving (Generic, Eq, Show, ToJSON) + +-- | A per-robot cache for the @path@ command. +data PathfindingCache = PathfindingCache + { invocationParms :: PathfindingParameters SubworldName + , walkabilityInfo :: WalkabilityContext + , targetLoc :: Location + , cachedPath :: CachedPath + } + deriving (Generic, Eq, Show, ToJSON) + +data PathCaching = PathCaching + { _pathCachingRobots :: IntMap PathfindingCache + -- ^ Keyed by RID + , _pathCachingLog :: RingBuffer CacheLogEntry + -- ^ For diagnostics/testing/debugging + } +makeLensesNoSigs ''PathCaching + +-- | All the RIDs of robots that are storing a cached path that +-- may require invalidation. +pathCachingRobots :: Lens' PathCaching (IntMap PathfindingCache) + +-- | Event log for cache invalidation +pathCachingLog :: Lens' PathCaching (RingBuffer CacheLogEntry) diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs b/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs @@ -0,0 +1,41 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Walkability logic +module Swarm.Game.Step.Path.Walkability where + +import Control.Lens +import Data.Set qualified as S +import Swarm.Game.Entity hiding (empty, lookup, singleton, union) +import Swarm.Game.Robot.Walk +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`). + PathBlockedBy (Maybe Entity) + | PathLiquid Entity + +-- | Pure logic used inside of +-- 'Swarm.Game.Step.Util.checkMoveFailureUnprivileged' +checkUnwalkable :: + WalkabilityContext -> + Maybe Entity -> + Maybe MoveFailureMode +checkUnwalkable (WalkabilityContext _ walkExceptions) Nothing = + 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 + | e `hasProperty` Liquid && CFloat `S.notMember` caps = + Just $ PathLiquid e + | otherwise = Nothing + where + eName = e ^. entityName + isUnwalkableEntity = case walkExceptions of + Whitelist onlyWalkables -> eName `S.notMember` onlyWalkables + Blacklist unwalkables -> e `hasProperty` Unwalkable || eName `S.member` unwalkables diff --git a/src/swarm-engine/Swarm/Game/Step/RobotStepState.hs b/src/swarm-engine/Swarm/Game/Step/RobotStepState.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/RobotStepState.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- This exists in its own module so that it can be +-- used by both "Swarm.Game.Step.Path.Cache" and +-- "Swarm.Game.Step.Util" without introducing an +-- import cycle. +module Swarm.Game.Step.RobotStepState where + +import Control.Carrier.State.Lazy +import Control.Effect.Error +import Swarm.Game.Exception +import Swarm.Game.Robot +import Swarm.Game.State + +-- | All functions that are used for robot step can access 'GameState' and the current 'Robot'. +-- +-- They can also throw exception of our custom type, which is handled elsewhere. +-- Because of that the constraint is only 'Throw', but not 'Catch'/'Error'. +type HasRobotStepState sig m = (Has (State GameState) sig m, Has (State Robot) sig m, Has (Throw Exn) sig m) diff --git a/src/swarm-engine/Swarm/Game/Step/Util.hs b/src/swarm-engine/Swarm/Game/Step/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Util.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- 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 Data.Array (bounds, (!)) +import Data.IntMap qualified as IM +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Linear (zero) +import Swarm.Game.Device +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.Structure.Recognition.Tracking qualified as SRT +import Swarm.Game.State +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Step.Path.Cache +import Swarm.Game.Step.Path.Type +import Swarm.Game.Step.Path.Walkability +import Swarm.Game.Step.RobotStepState +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.Util hiding (both) +import System.Random (UniformRange, uniformR) +import Prelude hiding (Applicative (..), lookup) + +deriveHeading :: HasRobotStepState sig m => Direction -> m Heading +deriveHeading d = do + orient <- use robotOrientation + when (isCardinal d) $ hasCapabilityFor COrient $ TDir d + return $ applyTurn d $ orient ? zero + +lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmic Location, Maybe Entity) +lookInDirection d = do + newHeading <- deriveHeading d + loc <- use robotLocation + let nextLoc = loc `offsetBy` newHeading + (nextLoc,) <$> entityAt nextLoc + +-- | Modify the entity (if any) at a given location. +updateEntityAt :: + (Has (State Robot) sig m, Has (State GameState) sig m) => + Cosmic Location -> + (Maybe Entity -> Maybe Entity) -> + m () +updateEntityAt cLoc@(Cosmic subworldName loc) upd = do + someChange <- + zoomWorld subworldName $ + W.updateM @Int (locToCoords loc) upd + + forM_ (WM.getModification =<< someChange) $ \modType -> do + currentTick <- use $ temporal . ticks + myID <- use robotID + zoomRobots $ wakeWatchingRobots myID currentTick cLoc + SRT.entityModified modType cLoc + + pcr <- use $ pathCaching . pathCachingRobots + mapM_ (revalidatePathCache cLoc modType) $ IM.toList pcr + +-- * Capabilities + +-- | Exempts the robot from various command constraints +-- when it is either a system robot or playing in creative mode +isPrivilegedBot :: (Has (State GameState) sig m, Has (State Robot) sig m) => m Bool +isPrivilegedBot = (||) <$> use systemRobot <*> use creativeMode + +-- | Test whether the current robot has a given capability (either +-- because it has a device which gives it that capability, or it is a +-- system robot, or we are in creative mode). +hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool +hasCapability cap = do + isPrivileged <- isPrivilegedBot + caps <- use robotCapabilities + return (isPrivileged || cap `S.member` getCapabilitySet caps) + +-- | Ensure that either a robot has a given capability, OR we are in creative +-- mode. +hasCapabilityFor :: + (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m () +hasCapabilityFor cap term = do + h <- hasCapability cap + h `holdsOr` Incapable FixByEquip (R.singletonCap cap) term + +-- * Exceptions + +holdsOrFail' :: (Has (Throw Exn) sig m) => Const -> Bool -> [Text] -> m () +holdsOrFail' c a ts = a `holdsOr` cmdExn c ts + +isJustOrFail' :: (Has (Throw Exn) sig m) => Const -> Maybe a -> [Text] -> m a +isJustOrFail' c a ts = a `isJustOr` cmdExn c ts + +-- | Create an exception about a command failing. +cmdExn :: Const -> [Text] -> Exn +cmdExn c parts = CmdFailed c (T.unwords parts) Nothing + +-- * Some utility functions + +-- | Set a flag telling the UI that the world needs to be redrawn. +flagRedraw :: (Has (State GameState) sig m) => m () +flagRedraw = needsRedraw .= True + +-- * Randomness + +-- | Generate a uniformly random number using the random generator in +-- the game state. +uniform :: (Has (State GameState) sig m, UniformRange a) => (a, a) -> m a +uniform bnds = do + rand <- use $ randomness . randGen + let (n, g) = uniformR bnds rand + randomness . randGen .= g + return n + +-- | Given a weighting function and a list of values, choose one of +-- the values randomly (using the random generator in the game +-- state), with the probability of each being proportional to its +-- weight. Return @Nothing@ if the list is empty. +weightedChoice :: Has (State GameState) sig m => (a -> Integer) -> [a] -> m (Maybe a) +weightedChoice weight as = do + r <- uniform (0, total - 1) + return $ go r as + where + total = sum (map weight as) + + go _ [] = Nothing + go !k (x : xs) + | k < w = Just x + | otherwise = go (k - w) xs + where + w = weight x + +-- | Generate a random robot name in the form @adjective_name@. +randomName :: Has (State GameState) sig m => m Text +randomName = do + NameGenerator adjs names <- use $ robotInfo . robotNaming . nameGenerator + i <- uniform (bounds adjs) + j <- uniform (bounds names) + return $ T.concat [adjs ! i, "_", names ! j] + +-- * Moving + +-- | Make sure nothing is in the way. +-- No exception for system robots +checkMoveFailureUnprivileged :: + HasRobotStepState sig m => + Cosmic Location -> + m (Maybe MoveFailureMode) +checkMoveFailureUnprivileged nextLoc = do + me <- entityAt nextLoc + 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. +checkMoveFailure :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureMode) +checkMoveFailure nextLoc = do + systemRob <- use systemRobot + runMaybeT $ do + guard $ not systemRob + maybeMoveFailure <- lift $ checkMoveFailureUnprivileged nextLoc + hoistMaybe maybeMoveFailure diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -0,0 +1,578 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- 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 +import Control.Effect.Lens +import Control.Effect.Lift +import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) +import Control.Monad (forM_, unless, when) +import Data.IntSet qualified as IS +import Data.List (find) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Sequence qualified as Seq +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (getZonedTime) +import Data.Tuple (swap) +import Linear (zero) +import Swarm.Game.Achievement.Attainment +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Achievement.Description (getValidityRequirements) +import Swarm.Game.CESK +import Swarm.Game.Device +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.Land +import Swarm.Game.Location +import Swarm.Game.Recipe +import Swarm.Game.Robot +import Swarm.Game.Robot.Concrete +import Swarm.Game.Robot.Walk (emptyExceptions) +import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation) +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Step.RobotStepState +import Swarm.Game.Step.Util +import Swarm.Game.Universe +import Swarm.Game.World qualified as W +import Swarm.Game.World.Coords +import Swarm.Language.Capability +import Swarm.Language.Pipeline.QQ (tmQ) +import Swarm.Language.Requirements.Type qualified as R +import Swarm.Language.Syntax +import Swarm.Language.Text.Markdown qualified as Markdown +import Swarm.Log +import System.Clock (TimeSpec) +import Prelude hiding (Applicative (..), lookup) + +data GrabbingCmd + = Grab' + | Harvest' + | Swap' + | Push' + deriving (Eq, Show) + +-- | Ensure that a robot is capable of executing a certain constant +-- (either because it has a device which gives it that capability, +-- or it is a system robot, or we are in creative mode). +-- +-- For certain capabilities that require payment of inventory +-- items in order to be exercised, we pay the toll up front, regardless of +-- other conditions that may preclude the capability from eventually +-- being exercised (e.g. an obstacle that ultimately prevents a "move"). +-- +-- Note that there exist some code paths where the "toll" +-- is bypassed, e.g. see 'hasCapabilityFor'. +-- We should just try to avoid authoring scenarios that +-- include toll-gated devices for those particular capabilities. +-- +-- Since this function has the side-effect of removing items from the +-- robot's inventory, we must be careful that it is executed exactly +-- once per command. +ensureCanExecute :: + ( Has (State Robot) sig m + , Has (State GameState) sig m + , Has (Throw Exn) sig m + ) => + 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 + +payExerciseCost :: + ( Has (State Robot) sig m + , Has (State GameState) sig m + , Has (Throw Exn) sig m + ) => + Const -> + NE.NonEmpty (DeviceUseCost Entity EntityName) -> + m () +payExerciseCost c rawCosts = do + em <- use $ landscape . terrainAndEntities . entityMap + let eitherCosts = (traverse . traverse) (lookupEntityE $ entitiesByName em) rawCosts + costs <- case eitherCosts of + -- NOTE: Entity references have been validated already at scenario load time, + -- so we should never encounter this error. + Left e -> throwError $ Fatal e + Right cs -> return cs + inv <- use robotInventory + let getMissingIngredients = findLacking inv . ingredients . useCost + maybeFeasibleRecipe = find (null . getMissingIngredients) $ NE.sort costs + case maybeFeasibleRecipe of + Nothing -> + throwError $ + Incapable FixByObtainConsumables (expenseToRequirement $ NE.head costs) (TConst c) + -- Consume the inventory + Just feasibleRecipe -> + forM_ (ingredients . useCost $ feasibleRecipe) $ \(cnt, e) -> + robotInventory %= deleteCount cnt e + where + expenseToRequirement :: DeviceUseCost Entity Entity -> R.Requirements + expenseToRequirement (DeviceUseCost d (ExerciseCost ingdts)) = + R.Requirements S.empty (S.singleton $ d ^. entityName) ingdtsMap + where + ingdtsMap = M.fromListWith (+) $ map (swap . fmap (view entityName)) ingdts + +-- | Clear watches that are out of range +purgeFarAwayWatches :: + HasRobotStepState sig m => m () +purgeFarAwayWatches = do + privileged <- isPrivilegedBot + myLoc <- use robotLocation + rid <- use robotID + + let isNearby = isNearbyOrExempt privileged myLoc + f loc = + if not $ isNearby loc + then IS.delete rid + else id + + robotInfo . robotsWatching %= M.filter (not . IS.null) . M.mapWithKey f + +verbedGrabbingCmd :: GrabbingCmd -> Text +verbedGrabbingCmd = \case + Harvest' -> "harvested" + Grab' -> "grabbed" + Swap' -> "swapped" + Push' -> "pushed" + +-- | Update the location of a robot, and simultaneously update the +-- 'robotsByLocation' map, so we can always look up robots by +-- location. This should be the /only/ way to update the location +-- of a robot. +-- Also implements teleportation by portals. +updateRobotLocation :: + (HasRobotStepState sig m) => + Cosmic Location -> + Cosmic Location -> + m () +updateRobotLocation oldLoc newLoc + | oldLoc == newLoc = return () + | otherwise = do + newlocWithPortal <- applyPortal newLoc + rid <- use robotID + zoomRobots $ do + removeRobotFromLocationMap oldLoc rid + addRobotToLocation rid newlocWithPortal + modify (unsafeSetRobotLocation newlocWithPortal) + flagRedraw + where + applyPortal loc = do + lms <- use $ landscape . worldNavigation + let maybePortalInfo = M.lookup loc $ portals lms + updatedLoc = maybe loc destination maybePortalInfo + maybeTurn = reorientation <$> maybePortalInfo + forM_ maybeTurn $ \d -> + robotOrientation . _Just %= applyTurn d + return updatedLoc + +-- | Execute a stateful action on a target robot --- whether the +-- current one or another. +onTarget :: + (HasRobotStepState sig m, Has (Lift IO) sig m) => + RID -> + (forall sig' m'. (HasRobotStepState sig' m', Has (Lift IO) sig' m') => m' ()) -> + m () +onTarget rid act = do + myID <- use robotID + case myID == rid of + 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' + +-- | Enforces validity of the robot's privileged status to receive +-- an achievement. +grantAchievementForRobot :: + (HasRobotStepState sig m, Has (Lift IO) sig m) => + GameplayAchievement -> + m () +grantAchievementForRobot a = do + sys <- use systemRobot + let isValidRobotType = not sys || robotTypeRequired == ValidForSystemRobot + when isValidRobotType $ + grantAchievement a + where + ValidityConditions robotTypeRequired _ = getValidityRequirements a + +checkGameModeAchievementValidity :: + Has (State GameState) sig m => + GameplayAchievement -> + m Bool +checkGameModeAchievementValidity a = do + creative <- use creativeMode + return $ not creative || gameplayModeRequired == ValidInCreativeMode + where + ValidityConditions _ gameplayModeRequired = getValidityRequirements a + +-- | NOTE: When possible, one should use the +-- 'grantAchievementForRobot' function instead of this one. +grantAchievement :: + (Has (State GameState) sig m, Has (Lift IO) sig m) => + GameplayAchievement -> + m () +grantAchievement a = do + isGameModeValid <- checkGameModeAchievementValidity a + when isGameModeValid $ do + currentTime <- sendIO getZonedTime + scenarioPath <- use currentScenarioPath + discovery + . gameAchievements + %= M.insertWith + (<>) + a + (Attainment (GameplayAchievement a) scenarioPath currentTime) + +-- | Capabilities needed for a specific robot to evaluate or execute a +-- constant. Right now, the only difference is whether the robot is +-- heavy or not when executing the 'Swarm.Language.Syntax.Move' command, but there might +-- be other exceptions added in the future. +constCapsFor :: Const -> Robot -> Maybe Capability +constCapsFor Move r + | r ^. robotHeavy = Just CMoveheavy +constCapsFor Backup r + | r ^. robotHeavy = Just CMoveheavy +constCapsFor Stride r + | r ^. robotHeavy = Just CMoveheavy +constCapsFor c _ = constCaps c + +-- | Requires that the target location is within one cell. +-- Requirement is waived if the bot is privileged. +isNearbyOrExempt :: Bool -> Cosmic Location -> Cosmic Location -> Bool +isNearbyOrExempt privileged myLoc otherLoc = + privileged || case cosmoMeasure manhattan myLoc otherLoc of + InfinitelyFar -> False + Measurable x -> x <= 1 + +------------------------------------------------------------ +-- Updating discovered entities, recipes, and commands +------------------------------------------------------------ + +-- | Update the global list of discovered entities, and check for new recipes. +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 + +-- | Update the availableRecipes list. +-- This implementation is not efficient: +-- * Every time we discover a new entity, we iterate through the entire list of recipes to see which ones we can make. +-- Trying to do something more clever seems like it would definitely be a case of premature optimization. +-- One doesn't discover new entities all that often. +-- * For each usable recipe, we do a linear search through the list of known recipes to see if we already know it. +-- This is a little more troubling, since it's quadratic in the number of recipes. +-- But it probably doesn't really make that much difference until we get up to thousands of recipes. +updateAvailableRecipes :: Has (State GameState) sig m => (Inventory, Inventory) -> Entity -> m () +updateAvailableRecipes invs e = do + allInRecipes <- use $ recipesInfo . recipesIn + let entityRecipes = recipesFor allInRecipes e + usableRecipes = filter (knowsIngredientsFor invs) entityRecipes + knownRecipes <- use $ discovery . availableRecipes . notificationsContent + let newRecipes = filter (`notElem` knownRecipes) usableRecipes + newCount = length newRecipes + discovery . availableRecipes %= mappend (Notifications newCount (newCount > 0) newRecipes) + updateAvailableCommands e + +updateAvailableCommands :: Has (State GameState) sig m => Entity -> m () +updateAvailableCommands e = do + let newCaps = getMap $ e ^. entityCapabilities + keepConsts = \case + Just cap -> cap `M.member` newCaps + Nothing -> False + entityConsts = filter (keepConsts . constCaps) allConst + knownCommands <- use $ discovery . availableCommands . notificationsContent + let newCommands = filter (`notElem` knownCommands) entityConsts + newCount = length newCommands + discovery . availableCommands %= mappend (Notifications newCount (newCount > 0) newCommands) + +------------------------------------------------------------ +-- The "watch" command +------------------------------------------------------------ + +addWatchedLocation :: + HasRobotStepState sig m => + Cosmic Location -> + m () +addWatchedLocation loc = do + rid <- use robotID + robotInfo . robotsWatching %= M.insertWith (<>) loc (IS.singleton rid) + +-- | Give some entities from a parent robot (the robot represented by +-- the ambient @State Robot@ effect) to a child robot (represented +-- by the given 'RID') as part of a 'Swarm.Language.Syntax.Build' +-- or 'Swarm.Language.Syntax.Reprogram' command. +-- The first 'Inventory' is devices to be equipped, and the second +-- is entities to be transferred. +-- +-- In classic mode, the entities will be /transferred/ (that is, +-- removed from the parent robot's inventory); in creative mode, the +-- entities will be copied/created, that is, no entities will be +-- removed from the parent robot. +provisionChild :: + (HasRobotStepState sig m) => + RID -> + Inventory -> + Inventory -> + m () +provisionChild childID toEquip toGive = do + -- Equip and give devices to child + zoomRobots $ do + robotMap . ix childID . equippedDevices %= E.union toEquip + robotMap . ix childID . robotInventory %= E.union toGive + + -- Delete all items from parent in classic mode + creative <- use creativeMode + unless creative $ + robotInventory %= (`E.difference` (toEquip `E.union` toGive)) + +------------------------------------------------------------ +-- Exceptions and validation +------------------------------------------------------------ + +-- | Create an exception about a command failing, with an achievement +cmdExnWithAchievement :: Const -> [Text] -> GameplayAchievement -> Exn +cmdExnWithAchievement c parts a = CmdFailed c (T.unwords parts) $ Just a + +-- | Raise an exception about a command failing with a formatted error message. +raise :: (Has (Throw Exn) sig m) => Const -> [Text] -> m a +raise c parts = throwError (cmdExn c parts) + +-- | Run a subcomputation that might throw an exception in a context +-- where we are returning a CESK machine; any exception will be +-- turned into an 'Up' state. +withExceptions :: Monad m => Store -> Cont -> ThrowC Exn m CESK -> m CESK +withExceptions s k m = do + res <- runThrow m + case res of + Left exn -> return $ Up exn s k + Right a -> return a + +-- | Print some text via the robot's log. +traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => RobotLogSource -> Severity -> Text -> m LogEntry +traceLog source sev msg = do + m <- createLogEntry source sev msg + robotLog %= (Seq.|> m) + return m + +updateWorldAndRobots :: + (HasRobotStepState sig m) => + Const -> + [WorldUpdate Entity] -> + [RobotUpdate] -> + m () +updateWorldAndRobots cmd wf rf = do + mapM_ (updateWorld cmd) wf + applyRobotUpdates rf + flagRedraw + +-- | Format a set of suggested devices for use in an error message, +-- in the format @device1 or device2 or ... or deviceN@. +formatDevices :: Set Entity -> Text +formatDevices = T.intercalate " or " . map (^. entityName) . S.toList + +------------------------------------------------------------ +-- Debugging +------------------------------------------------------------ + +-- | Create a log entry given current robot and game time in ticks +-- noting whether it has been said. +-- +-- This is the more generic version used both for (recorded) said +-- messages and normal logs. +createLogEntry :: + (Has (State GameState) sig m, Has (State Robot) sig m) => + RobotLogSource -> + Severity -> + Text -> + m LogEntry +createLogEntry source sev msg = do + rid <- use robotID + rn <- use robotName + time <- use $ temporal . ticks + loc <- use robotLocation + pure $ LogEntry time (RobotLog source rid loc) sev rn msg + +-- | replace some entity in the world with another entity +updateWorld :: + HasRobotStepState sig m => + Const -> + WorldUpdate Entity -> + m () +updateWorld c (ReplaceEntity loc eThen down) = do + w <- use $ landscape . multiWorld + let eNow = W.lookupCosmicEntity (fmap locToCoords loc) w + -- Can fail if a robot started a multi-tick "drill" operation on some entity + -- and meanwhile another entity swaps it out from under them. + if Just eThen /= eNow + then throwError $ cmdExn c ["The", eThen ^. entityName, "is not there."] + else updateEntityAt loc $ const down + +applyRobotUpdates :: + (Has (State GameState) sig m, Has (State Robot) sig m) => + [RobotUpdate] -> + m () +applyRobotUpdates = + mapM_ \case + AddEntity c e -> robotInventory %= E.insertCount c e + LearnEntity e -> robotInventory %= E.insertCount 0 e + +-- | Construct a "seed robot" from entity, time range and position, +-- and add it to the world. It has low priority and will be covered +-- by placed entities. +addSeedBot :: + Has (State GameState) sig m => + Entity -> + (Integer, Integer) -> + Integer -> + Integer -> + Cosmic Location -> + TimeSpec -> + m () +addSeedBot e (minT, maxT) seedlingCount seedlingRadius loc ts = + zoomRobots + . addTRobot (initMachine seedProg) + $ mkRobot + Nothing + "seed" + (Markdown.fromText $ T.unwords ["A growing", e ^. entityName, "seed."]) + (Just loc) + zero + ( defaultEntityDisplay '.' + & displayAttr .~ (e ^. entityDisplay . displayAttr) + & displayPriority .~ 0 + & childInheritance .~ Invisible + ) + Nothing + [] + [(1, e)] + True + False + emptyExceptions + ts + where + seedProg = + seedProgram + minT + (maxT - minT) + seedlingCount + seedlingRadius + (e ^. entityName) + +-- | A system program for a "seed robot", to regrow a growable entity +-- after it is harvested. +-- +-- NOTE: Seedling propagation delay (spreadable growth) +-- re-uses the growth timing parameters. +seedProgram :: + -- | min time + Integer -> + -- | rand time + Integer -> + -- | seedling count + Integer -> + -- | seedling radius + Integer -> + -- | entity to place + EntityName -> + TSyntax +seedProgram minTime randTime seedlingCount seedlingRadius thing = + [tmQ| + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + try { + r <- random (1 + $int:randTime); + wait (r + $int:minTime); + appear "|" (inl ()); + r <- random (1 + $int:randTime); + wait (r + $int:minTime); + place $str:thing; + + doN $int:seedlingCount ( + _robo <- build { + propagationDelay <- random (1 + $int:randTime); + wait (propagationDelay + $int:minTime); + + totalDist <- random (1 + $int:seedlingRadius); + horizontalDist <- random (1 + totalDist); + let verticalDist = totalDist - horizontalDist in + + shouldReverse <- random 2; + if (shouldReverse == 0) { + turn back; + } {}; + stride horizontalDist; + turn left; + shouldReverse2 <- random 2; + if (shouldReverse2 == 0) { + turn back; + } {}; + stride verticalDist; + + create $str:thing; + try { + sow $str:thing; + } {}; + + selfdestruct + }; + ); + } {}; + selfdestruct + |] + +------------------------------------------------------------ +-- Some utility functions +------------------------------------------------------------ + +verbGrabbingCmd :: GrabbingCmd -> Text +verbGrabbingCmd = \case + Harvest' -> "harvest" + Grab' -> "grab" + Swap' -> "swap" + Push' -> "push" diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Inspect.hs b/src/swarm-engine/Swarm/Game/Step/Util/Inspect.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Util/Inspect.hs @@ -0,0 +1,32 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utilities for querying robots and their neighbors +module Swarm.Game.Step.Util.Inspect where + +import Control.Carrier.State.Lazy +import Control.Effect.Lens +import Control.Lens hiding (from, use, (%=), (<.>)) +import Data.IntMap qualified as IM +import Data.List (find) +import Data.List.Extra (enumerate) +import Data.Text (Text) +import Swarm.Game.Location +import Swarm.Game.Robot +import Swarm.Game.State +import Swarm.Game.State.Robot +import Swarm.Game.Universe +import Swarm.Language.Syntax.Direction + +-- * World queries + +getNeighborLocs :: Cosmic Location -> [Cosmic Location] +getNeighborLocs loc = map (offsetBy loc . flip applyTurn north . DRelative . DPlanar) enumerate + +-- | Get the robot with a given ID. +robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot) +robotWithID rid = use (robotInfo . robotMap . at rid) + +-- | Get the robot with a given name. +robotWithName :: (Has (State GameState) sig m) => Text -> m (Maybe Robot) +robotWithName rname = use (robotInfo . robotMap . to IM.elems . to (find $ \r -> r ^. robotName == rname)) diff --git a/src/swarm-engine/Swarm/Game/Step/Validate.hs b/src/swarm-engine/Swarm/Game/Step/Validate.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Step/Validate.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Validation of gameplay. +-- +-- Facilities for running a game state until completion, checking for +-- any errors encountered. This is not used for normal gameplay but +-- can be used by /e.g./ integration tests. +module Swarm.Game.Step.Validate where + +import Control.Lens (use, (^.)) +import Control.Monad.State (StateT, gets) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Swarm.Effect.Time (runTimeIO) +import Swarm.Game.Robot.Concrete (robotLog) +import Swarm.Game.State (GameState, messageInfo, robotInfo, winCondition) +import Swarm.Game.State.Robot (robotMap) +import Swarm.Game.State.Substate (WinCondition (..), WinStatus (..), messageQueue) +import Swarm.Game.Step (gameTick) +import Swarm.Game.Tick (TickNumber) +import Swarm.Log (logToText) + +-- | Keep stepping a 'GameState' until completion, returning the +-- number of ticks taken if successful, or any bad error messages +-- encountered. +playUntilWin :: StateT GameState IO (Either (NE.NonEmpty T.Text) TickNumber) +playUntilWin = do + w <- use winCondition + b <- gets badErrorsInLogs + case NE.nonEmpty b of + Just badErrs -> return $ Left badErrs + Nothing -> case w of + WinConditions (Won _ ts) _ -> return $ Right ts + _ -> runTimeIO gameTick >> playUntilWin + +-- | Extract any bad error messages from robot logs or the global +-- message queue, where "bad" errors are either fatal errors or +-- ones referring to issues in the issue tracker. +badErrorsInLogs :: GameState -> [T.Text] +badErrorsInLogs g = + concatMap + (\r -> filter isBad (logToText $ r ^. robotLog)) + (g ^. robotInfo . robotMap) + <> filter isBad (logToText $ g ^. messageInfo . messageQueue) + where + isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m diff --git a/src/swarm-engine/Swarm/Game/Tick.hs b/src/swarm-engine/Swarm/Game/Tick.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Tick.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Tick ( + TickNumber (..), + addTicks, +) where + +import Data.Aeson (FromJSON, ToJSON (..)) +import Data.Aeson qualified as A +import Data.Int (Int64) +import GHC.Generics (Generic) +import Prettyprinter (Pretty (..)) +import Swarm.Util.JSON (optionsUnwrapUnary) +import Swarm.Util.WindowedCounter (Offsettable (..)) + +-- | 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) + +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 diff --git a/src/swarm-engine/Swarm/Game/Value.hs b/src/swarm-engine/Swarm/Game/Value.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/Value.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Conversions from native Haskell values +-- to values in the swarm language. +module Swarm.Game.Value where + +import Control.Lens (view) +import Data.Either.Extra (maybeToEither) +import Data.Int (Int32) +import Data.List (uncons) +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.Language.Syntax.Direction +import Swarm.Language.Value + +-- * Patterns + +type VRect = Value +pattern VRect :: Integer -> Integer -> Integer -> Integer -> VRect +pattern VRect x1 y1 x2 y2 = VPair (VPair (VInt x1) (VInt y1)) (VPair (VInt x2) (VInt y2)) + +-- * Conversions + +-- | Conversion from native Haskell types +-- to their swarm-lang equivalents, useful for +-- implementing swarm +-- +-- in Haskell. +class Valuable a where + asValue :: a -> Value + +instance Valuable Int32 where + asValue = VInt . fromIntegral + +instance Valuable Int where + asValue = VInt . fromIntegral + +instance Valuable Integer where + asValue = VInt + +instance Valuable Bool where + asValue = VBool + +instance Valuable Text where + asValue = VText + +instance Valuable () where + asValue = const VUnit + +instance (Valuable a) => Valuable (V2 a) where + asValue (V2 x y) = asValue (x, y) + +instance (Valuable a, Valuable b) => Valuable (a, b) where + asValue (x, y) = VPair (asValue x) (asValue y) + +instance Valuable Location where + asValue (Location x y) = asValue (x, y) + +instance Valuable Entity where + asValue = VText . view entityName + +instance Valuable Robot where + asValue = VRobot . view robotID + +instance Valuable Direction where + asValue = VDir + +instance (Valuable a) => Valuable (Maybe a) where + asValue = asValue . maybeToEither () + +instance (Valuable a, Valuable b) => Valuable (Either a b) where + asValue (Left x) = VInj False $ asValue x + asValue (Right x) = VInj True $ asValue x + +instance Valuable a => Valuable [a] where + asValue = asValue . uncons + +instance Valuable AreaDimensions where + asValue (AreaDimensions w h) = asValue (w, h) diff --git a/src/swarm-engine/Swarm/Log.hs b/src/swarm-engine/Swarm/Log.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Log.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A data type to represent log messages, both for robot logs and +-- the system log. +module Swarm.Log ( + -- * Log entries + Severity (..), + RobotLogSource (..), + LogSource (..), + LogEntry (..), + leTime, + leSource, + leSeverity, + leName, + leText, + + -- * Utilities + logToText, +) where + +import Control.Lens (makeLenses, view) +import Data.Aeson (FromJSON, ToJSON) +import Data.Foldable (toList) +import Data.Text (Text) +import GHC.Generics (Generic) +import Swarm.Game.Location (Location) +import Swarm.Game.Tick (TickNumber) +import Swarm.Game.Universe (Cosmic) + +-- | Severity of the error - critical errors are bugs +-- and should be reported as Issues. +data Severity = Info | Debug | Warning | Error | Critical + deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) + +-- | How a robot log entry was produced. +data RobotLogSource + = -- | Produced by 'Swarm.Language.Syntax.Say' + Said + | -- | Produced by 'Swarm.Language.Syntax.Log' + Logged + | -- | Produced as the result of an error. + RobotError + | -- | Produced as a status message from a command. + CmdStatus + deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) + +-- | Source of a log entry. +data LogSource + = -- | Log produced by a robot. Stores information about which + -- command was used and the ID and location of the producing + -- robot. + RobotLog RobotLogSource Int (Cosmic Location) + | -- | Log produced by an exception or system. + SystemLog + deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) + +-- | A log entry. +data LogEntry = LogEntry + { _leTime :: TickNumber + -- ^ The time at which the entry was created. + -- Note that this is the first field we sort on. + , _leSource :: LogSource + -- ^ Where this log message came from. + , _leSeverity :: Severity + -- ^ Severity level of this log message. + , _leName :: Text + -- ^ Name of the robot or subsystem that generated this log entry. + , _leText :: Text + -- ^ The text of the log entry. + } + deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) + +makeLenses ''LogEntry + +-- | Extract the text from a container of log entries. +logToText :: Foldable t => t LogEntry -> [Text] +logToText = map (view leText) . toList diff --git a/src/swarm-engine/Swarm/Version.hs b/src/swarm-engine/Swarm/Version.hs new file mode 100644 --- /dev/null +++ b/src/swarm-engine/Swarm/Version.hs @@ -0,0 +1,172 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Effect/Unify.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: This module defines an effect signature for +-- computations that support doing unification. The intention is for +-- code needing unification to use the operations defined in this +-- module, and then import 'Swarm.Effect.Unify.Fast' to dispatch the +-- 'Unification' effects. +module Swarm.Effect.Unify where + +import Control.Algebra +import Data.Kind (Type) +import Data.Set (Set) +import Swarm.Language.Types hiding (Type) + +-- | Data type representing available unification operations. +data Unification (m :: Type -> Type) k where + Unify :: UType -> UType -> Unification m (Either UnificationError UType) + ApplyBindings :: UType -> Unification m UType + FreshIntVar :: Unification m IntVar + FreeUVars :: UType -> Unification m (Set IntVar) + +-- | Unify two types, returning a type equal to both, or a 'UnificationError' if +-- the types definitely do not unify. +(=:=) :: Has Unification sig m => UType -> UType -> m (Either UnificationError UType) +t1 =:= t2 = send (Unify t1 t2) + +-- | Substitute for all the unification variables that are currently +-- bound. It is guaranteed that any unification variables remaining +-- in the result are not currently bound, /i.e./ we have learned no +-- information about them. +applyBindings :: Has Unification sig m => UType -> m UType +applyBindings = send . ApplyBindings + +-- | Compute the set of free unification variables of a type (after +-- substituting away any which are already bound). +freeUVars :: Has Unification sig m => UType -> m (Set IntVar) +freeUVars = send . FreeUVars + +-- | Generate a fresh unification variable. +freshIntVar :: Has Unification sig m => m IntVar +freshIntVar = send FreshIntVar + +-- | An error that occurred while running the unifier. +data UnificationError where + -- | Occurs check failure, i.e. the solution to some unification + -- equations was an infinite term. + Infinite :: IntVar -> UType -> UnificationError + -- | Mismatch error between the given terms. + UnifyErr :: TypeF UType -> TypeF UType -> UnificationError + -- | Encountered an undefined/unknown type constructor. + UndefinedUserType :: UType -> UnificationError + -- | Encountered an unexpanded recursive type in unifyF. This + -- should never happen. + UnexpandedRecTy :: TypeF UType -> UnificationError + deriving (Show) diff --git a/src/swarm-lang/Swarm/Effect/Unify/Common.hs b/src/swarm-lang/Swarm/Effect/Unify/Common.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Effect/Unify/Common.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Description: Common definitions used in both the naive and fast +-- implementations of unification. +module Swarm.Effect.Unify.Common where + +import Control.Algebra +import Control.Effect.State (State, get) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set (Set) +import Prelude hiding (lookup) + +------------------------------------------------------------ +-- Substitutions + +-- | A value of type @Subst n a@ is a substitution which maps +-- names of type @n@ (the /domain/, see 'dom') to values of type +-- @a@. Substitutions can be /applied/ to certain terms (see +-- 'subst'), replacing any free occurrences of names in the +-- domain with their corresponding values. Thus, substitutions can +-- be thought of as functions of type @Term -> Term@ (for suitable +-- @Term@s that contain names and values of the right type). +-- +-- Concretely, substitutions are stored using a @Map@. +newtype Subst n a = Subst {getSubst :: Map n a} + deriving (Eq, Ord, Show, Functor) + +-- | The domain of a substitution is the set of names for which the +-- substitution is defined. +dom :: Subst n a -> Set n +dom = M.keysSet . getSubst + +-- | The identity substitution, /i.e./ the unique substitution with an +-- empty domain, which acts as the identity function on terms. +idS :: Subst n a +idS = Subst M.empty + +-- | Construct a singleton substitution, which maps the given name to +-- the given value. +(|->) :: n -> a -> Subst n a +x |-> t = Subst (M.singleton x t) + +-- | Insert a new name/value binding into the substitution. +insert :: Ord n => n -> a -> Subst n a -> Subst n a +insert n a (Subst m) = Subst (M.insert n a m) + +-- | Look up the value a particular name maps to under the given +-- substitution; or return @Nothing@ if the name being looked up is +-- not in the domain. +lookup :: Ord n => n -> Subst n a -> Maybe a +lookup x (Subst m) = M.lookup x m + +-- | Look up a name in a substitution stored in a state effect. +lookupS :: (Ord n, Has (State (Subst n a)) sig m) => n -> m (Maybe a) +lookupS x = lookup x <$> get diff --git a/src/swarm-lang/Swarm/Effect/Unify/Fast.hs b/src/swarm-lang/Swarm/Effect/Unify/Fast.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Effect/Unify/Fast.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Description: Fast yet purely functional implementation of +-- unification, using a map as a lazy substitution, i.e. a +-- manually-maintained "functional shared memory". +-- +-- See Dijkstra, Middelkoop, & Swierstra, "Efficient Functional +-- Unification and Substitution", Utrecht University tech report +-- UU-CS-2008-027 (section 5) for the basic idea, and Peyton Jones et +-- al, "Practical type inference for arbitrary-rank types" +-- (pp. 74--75) for a correct implementation of unification via +-- references. +module Swarm.Effect.Unify.Fast where + +import Control.Algebra +import Control.Applicative (Alternative) +import Control.Carrier.Accum.FixedStrict (AccumC, runAccum) +import Control.Carrier.Reader (ReaderC, runReader) +import Control.Carrier.State.Strict (StateC, evalState) +import Control.Carrier.Throw.Either (ThrowC, runThrow) +import Control.Category ((>>>)) +import Control.Effect.Accum (Accum, add) +import Control.Effect.Reader (Reader, ask, local) +import Control.Effect.State (State, get, gets, modify) +import Control.Effect.Throw (Throw, throwError) +import Control.Monad (zipWithM) +import Control.Monad.Free +import Control.Monad.Trans (MonadIO) +import Data.Function (on) +import Data.Functor.Identity +import Data.Map qualified as M +import Data.Map.Merge.Lazy qualified as M +import Data.Monoid (First (..)) +import Data.Set (Set) +import Data.Set qualified as S +import Swarm.Effect.Unify +import Swarm.Effect.Unify.Common +import Swarm.Language.Types hiding (Type) +import Prelude hiding (lookup) + +------------------------------------------------------------ +-- Substitutions + +-- | Compose two substitutions. Applying @s1 \@\@ s2@ is the same as +-- applying first @s2@, then @s1@; that is, semantically, +-- composition of substitutions corresponds exactly to function +-- composition when they are considered as functions on terms. +-- +-- As one would expect, composition is associative and has 'idS' as +-- its identity. +-- +-- Note that we do /not/ apply @s1@ to all the values in @s2@, since +-- the substitution is maintained lazily; we do not need to maintain +-- the invariant that values in the mapping do not contain any of +-- the keys. This makes composition much faster, at the cost of +-- making application more complex. +(@@) :: (Ord n, Substitutes n a a) => Subst n a -> Subst n a -> Subst n a +(Subst s1) @@ (Subst s2) = Subst (s2 `M.union` s1) + +-- | Class of things supporting substitution. @Substitutes n b a@ means +-- that we can apply a substitution of type @Subst n b@ to a +-- value of type @a@, replacing all the free names of type @n@ +-- inside the @a@ with values of type @b@, resulting in a new value +-- of type @a@. +-- +-- We also do a lazy occurs-check during substitution application, +-- so we need the ability to throw a unification error. +class Substitutes n b a where + subst :: Has (Throw UnificationError) sig m => Subst n b -> a -> m a + +-- | We can perform substitution on terms built up as the free monad +-- over a structure functor @f@. +instance Substitutes IntVar UType UType where + subst s u = case runSubst (go u) of + -- If the substitution completed without encountering a repeated + -- variable, just return the result. + (First Nothing, u') -> return u' + -- Otherwise, throw an error, but re-run substitution starting at + -- the repeated variable to generate an expanded cyclic equality + -- constraint of the form x = ... x ... . + (First (Just x), _) -> + throwError $ + Infinite x (snd (runSubst (go $ Pure x))) + where + runSubst :: ReaderC (Set IntVar) (AccumC (First IntVar) Identity) a -> (First IntVar, a) + runSubst = run . runAccum (First Nothing) . runReader S.empty + + -- A version of substitution that recurses through the term, + -- keeping track of unification variables seen along the current + -- path. When it encounters a previously-seen variable, it simply + -- returns it unchanged but notes the first such variable that was + -- encountered. + go :: + (Has (Reader (Set IntVar)) sig m, Has (Accum (First IntVar)) sig m) => + UType -> + m UType + go (Pure x) = case lookup x s of + Nothing -> pure $ Pure x + Just t -> do + seen <- ask + case S.member x seen of + True -> add (First (Just x)) >> pure (Pure x) + False -> local (S.insert x) $ go t + go (Free t) = Free <$> goF t + + goF :: (Has (Reader (Set IntVar)) sig m, Has (Accum (First IntVar)) sig m) => TypeF UType -> m (TypeF UType) + goF (TyConF c ts) = TyConF c <$> mapM go ts + goF t@(TyVarF {}) = pure t + goF (TyRcdF m) = TyRcdF <$> mapM go m + goF (TyRecF x t) = TyRecF x <$> go t + goF t@(TyRecVarF _) = pure t + +------------------------------------------------------------ +-- Carrier type + +-- | Carrier type for unification: we maintain a current substitution, +-- a counter for generating fresh unification variables, and can +-- throw unification errors. +newtype UnificationC m a = UnificationC + { unUnificationC :: + StateC + (Set (UType, UType)) + ( StateC + (Subst IntVar UType) + ( StateC + FreshVarCounter + ( ThrowC UnificationError m + ) + ) + ) + a + } + deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO) + +-- | Counter for generating fresh unification variables. +newtype FreshVarCounter = FreshVarCounter {getFreshVarCounter :: Int} + deriving (Eq, Ord, Enum) + +-- | Run a 'Unification' effect via the 'UnificationC' carrier. Note +-- that we also require an ambient @Reader 'TDCtx'@ effect, so unification +-- will be sure to pick up whatever type aliases happen to be in scope. +runUnification :: + (Algebra sig m, Has (Reader TDCtx) sig m) => + UnificationC m a -> + m (Either UnificationError a) +runUnification = + unUnificationC + >>> evalState S.empty + >>> evalState idS + >>> evalState (FreshVarCounter 0) + >>> runThrow + +------------------------------------------------------------ +-- Unification + +-- The idea here (using an explicit substitution as a sort of +-- "functional shared memory", instead of directly using IORefs), is +-- based on Dijkstra et al. Unfortunately, their implementation of +-- unification is subtly wrong; fortunately, a single integration test +-- in the Swarm test suite failed, leading to discovering the bug. +-- The basic issue is that when unifying an equation between two +-- variables @x = y@, we must look up *both* to see whether they are +-- already mapped by the substitution (and if so, replace them by +-- their referent and keep recursing). Dijkstra et al. only look up +-- @x@ and simply map @x |-> y@ if x is not in the substitution, but +-- this can lead to cycles where e.g. x is mapped to y, and later we +-- unify @y = x@ resulting in both @x |-> y@ and @y |-> x@ in the +-- substitution, which at best leads to a spurious infinite type +-- error, and at worst leads to infinite recursion in the unify function. +-- +-- Peyton Jones et al. show how to do it correctly: when unifying x = y and +-- x is not mapped in the substitution, we must also look up y. + +-- | Implementation of the 'Unification' effect in terms of the +-- 'UnificationC' carrier. +instance + (Algebra sig m, Has (Reader TDCtx) sig m) => + Algebra (Unification :+: sig) (UnificationC m) + where + alg hdl sig ctx = UnificationC $ case sig of + L (Unify t1 t2) -> (<$ ctx) <$> runThrow (unify t1 t2) + L (ApplyBindings t) -> do + s <- get @(Subst IntVar UType) + (<$ ctx) <$> subst s t + L FreshIntVar -> do + v <- IntVar <$> gets getFreshVarCounter + modify @FreshVarCounter succ + return $ v <$ ctx + L (FreeUVars t) -> do + s <- get @(Subst IntVar UType) + (<$ ctx) . fuvs <$> subst s t + R other -> alg (unUnificationC . hdl) (R (R (R (R other)))) ctx + +-- | Unify two types, returning a unified type equal to both. Note +-- that for efficiency we /don't/ do an occurs check here, but +-- instead lazily during substitution. +-- +-- We keep track of a set of pairs of types we have seen; if we ever +-- see a pair a second time we simply assume they are equal without +-- recursing further. This constitutes a finite (coinductive) +-- algorithm for doing unification on recursive types. +-- +-- For example, suppose we wanted to unify @rec s. Unit + Unit + s@ +-- and @rec t. Unit + t@. These types are actually equal since +-- their infinite unfoldings are both @Unit + Unit + Unit + ...@ In +-- practice we would proceed through the following recursive calls +-- to unify: +-- +-- @ +-- (rec s. Unit + Unit + s) =:= (rec t. Unit + t) +-- { unfold the LHS } +-- (Unit + Unit + (rec s. Unit + Unit + s)) =:= (rec t. Unit + t) +-- { unfold the RHS } +-- (Unit + Unit + (rec s. Unit + Unit + s)) =:= (Unit + (rec t. Unit + t) +-- { unifyF matches the + and makes two calls to unify } +-- Unit =:= Unit { trivial} +-- (Unit + (rec s. Unit + Unit + s)) =:= (rec t. Unit + t) +-- { unfold the RHS } +-- (Unit + (rec s. Unit + Unit + s)) =:= (Unit + (rec t. Unit + t)) +-- { unifyF on + } +-- (rec s. Unit + Unit + s) =:= (rec t. Unit + t) +-- { back to the starting pair, return success } +-- @ +unify :: + ( Has (Throw UnificationError) sig m + , Has (Reader TDCtx) sig m + , Has (State (Subst IntVar UType)) sig m + , Has (State (Set (UType, UType))) sig m + ) => + UType -> + UType -> + m UType +unify ty1 ty2 = do + seen <- get @(Set (UType, UType)) + case S.member (ty1, ty2) seen of + True -> return ty1 + False -> do + modify (S.insert (ty1, ty2)) + case (ty1, ty2) of + (Pure x, Pure y) | x == y -> pure (Pure x) + (Pure x, y) -> do + mxv <- lookupS x + case mxv of + Nothing -> unifyVar x y + Just xv -> unify xv y + (x, Pure y) -> unify (Pure y) x + (UTyRec x ty, _) -> unify (unfoldRec x ty) ty2 + (_, UTyRec x ty) -> unify ty1 (unfoldRec x ty) + (UTyUser x1 tys, _) -> do + ty1' <- expandTydef x1 tys + unify ty1' ty2 + (_, UTyUser {}) -> unify ty2 ty1 + (Free t1, Free t2) -> Free <$> unifyF t1 t2 + +-- | Unify a unification variable which /is not/ bound by the current +-- substitution with another term. If the other term is also a +-- variable, we must look it up as well to see if it is bound. +unifyVar :: + ( Has (Throw UnificationError) sig m + , Has (Reader TDCtx) sig m + , Has (State (Subst IntVar UType)) sig m + , Has (State (Set (UType, UType))) sig m + ) => + IntVar -> + UType -> + m UType +unifyVar x (Pure y) = do + myv <- lookupS y + case myv of + -- x = y but the variable y is not bound: just add (x |-> y) to + -- the current Subst + -- + -- Note, as an optimization we just call e.g. insert x (Pure y) + -- instead of building a singleton Subst with @(|->)@ and then + -- composing, since composition doesn't need to apply the newly + -- created binding to all the other values bound in the Subst. + Nothing -> modify @(Subst IntVar UType) (insert x (Pure y)) >> pure (Pure y) + -- x = y and y is bound to v: recurse on x = v. + Just yv -> unify (Pure x) yv + +-- x = t for a non-variable t: just add (x |-> t) to the Subst. +unifyVar x t = modify (insert x t) >> pure t + +-- | Perform unification on two non-variable terms: check that they +-- have the same top-level constructor and recurse on their +-- contents. +unifyF :: + ( Has (Throw UnificationError) sig m + , Has (Reader TDCtx) sig m + , Has (State (Subst IntVar UType)) sig m + , Has (State (Set (UType, UType))) sig m + ) => + TypeF UType -> + TypeF UType -> + m (TypeF UType) +unifyF t1 t2 = case (t1, t2) of + -- Recursive types are always expanded in 'unify', these first four cases + -- should never happen. + (TyRecF {}, _) -> throwError $ UnexpandedRecTy t1 + (_, TyRecF {}) -> throwError $ UnexpandedRecTy t2 + (TyRecVarF {}, _) -> throwError $ UnexpandedRecTy t1 + (_, TyRecVarF {}) -> throwError $ UnexpandedRecTy t2 + (TyConF c1 ts1, TyConF c2 ts2) -> case c1 == c2 of + True -> TyConF c1 <$> zipWithM unify ts1 ts2 + False -> unifyErr + (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 + True -> pure t1 + False -> unifyErr + (TyVarF {}, _) -> unifyErr + (TyRcdF m1, TyRcdF m2) -> + case ((==) `on` M.keysSet) m1 m2 of + False -> unifyErr + _ -> fmap TyRcdF . sequence $ M.merge M.dropMissing M.dropMissing (M.zipWithMatched (const unify)) m1 m2 + (TyRcdF {}, _) -> unifyErr + where + unifyErr = throwError $ UnifyErr t1 t2 diff --git a/src/swarm-lang/Swarm/Effect/Unify/Naive.hs b/src/swarm-lang/Swarm/Effect/Unify/Naive.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Effect/Unify/Naive.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Description: Naive (slow) substitution-based implementation of +-- unification. Uses a simple but expensive-to-maintain invariant on +-- substitutions, and returns a substitution from unification which +-- must then be composed with the substitution being tracked. +-- +-- Not used in Swarm, and also unmaintained +-- (e.g. "Swarm.Effect.Unify.Fast" now supports expanding type +-- aliases + recursive types; this module does not). It's still here just for +-- testing/comparison. +module Swarm.Effect.Unify.Naive where + +import Control.Algebra +import Control.Applicative (Alternative) +import Control.Carrier.State.Strict (StateC, evalState) +import Control.Carrier.Throw.Either (ThrowC, runThrow) +import Control.Category ((>>>)) +import Control.Effect.State (get, gets, modify) +import Control.Effect.Throw (Throw, throwError) +import Control.Monad (zipWithM) +import Control.Monad.Free +import Control.Monad.Trans (MonadIO) +import Data.Function (on) +import Data.Map ((!?)) +import Data.Map qualified as M +import Data.Map.Merge.Lazy qualified as M +import Data.Maybe (fromMaybe) +import Data.Set qualified as S +import Swarm.Effect.Unify +import Swarm.Effect.Unify.Common +import Swarm.Language.Types hiding (Type) + +------------------------------------------------------------ +-- Substitutions + +-- | Class of things supporting substitution. @Substitutes n b a@ means +-- that we can apply a substitution of type @Subst n b@ to a +-- value of type @a@, replacing all the free names of type @n@ +-- inside the @a@ with values of type @b@, resulting in a new value +-- of type @a@. +class Substitutes n b a where + subst :: Subst n b -> a -> a + +-- | We can perform substitution on terms built up as the free monad +-- over a structure functor @f@. +instance (Show n, Ord n, Functor f) => Substitutes n (Free f n) (Free f n) where + subst s f = f >>= \n -> fromMaybe (Pure n) (getSubst s !? n) + +-- | Compose two substitutions. Applying @s1 \@\@ s2@ is the same as +-- applying first @s2@, then @s1@; that is, semantically, +-- composition of substitutions corresponds exactly to function +-- composition when they are considered as functions on terms. +-- +-- As one would expect, composition is associative and has 'idS' as +-- its identity. +(@@) :: (Ord n, Substitutes n a a) => Subst n a -> Subst n a -> Subst n a +(Subst s1) @@ (Subst s2) = Subst (M.map (subst (Subst s1)) s2 `M.union` s1) + +-- | Compose a whole container of substitutions. For example, +-- @compose [s1, s2, s3] = s1 \@\@ s2 \@\@ s3@. +compose :: (Ord n, Substitutes n a a, Foldable t) => t (Subst n a) -> Subst n a +compose = foldr (@@) idS + +------------------------------------------------------------ +-- Carrier type + +-- Note: this carrier type and the runUnification function are +-- identical between this module and Swarm.Effect.Unify.Fast, but it +-- seemed best to duplicate it, so we can modify the carriers +-- independently in the future if we want. + +-- | Carrier type for unification: we maintain a current substitution, +-- a counter for generating fresh unification variables, and can +-- throw unification errors. +newtype UnificationC m a = UnificationC + { unUnificationC :: + StateC (Subst IntVar UType) (StateC FreshVarCounter (ThrowC UnificationError m)) a + } + deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO) + +-- | Counter for generating fresh unification variables. +newtype FreshVarCounter = FreshVarCounter {getFreshVarCounter :: Int} + deriving (Eq, Ord, Enum) + +-- | Run a 'Unification' effect via the 'UnificationC' carrier. +runUnification :: Algebra sig m => UnificationC m a -> m (Either UnificationError a) +runUnification = + unUnificationC >>> evalState idS >>> evalState (FreshVarCounter 0) >>> runThrow + +------------------------------------------------------------ +-- Unification + +-- | Naive implementation of the 'Unification' effect in terms of the +-- 'UnificationC' carrier. +-- +-- We maintain an invariant on the current @Subst@ that map keys +-- never show up in any of the values. For example, we could have +-- @{x -> a+5, y -> 5}@ but not @{x -> a+y, y -> 5}@. +instance Algebra sig m => Algebra (Unification :+: sig) (UnificationC m) where + alg hdl sig ctx = UnificationC $ case sig of + L (Unify t1 t2) -> do + s1 <- get @(Subst IntVar UType) + let t1' = subst s1 t1 + t2' = subst s1 t2 + s2 <- unify t1' t2' + modify (s2 @@) + return $ Right (subst s2 t1') <$ ctx + L (ApplyBindings t) -> do + s <- get @(Subst IntVar UType) + return $ subst s t <$ ctx + L FreshIntVar -> do + v <- IntVar <$> gets getFreshVarCounter + modify @FreshVarCounter succ + return $ v <$ ctx + L (FreeUVars t) -> do + s <- get @(Subst IntVar UType) + return $ fuvs (subst s t) <$ ctx + R other -> alg (unUnificationC . hdl) (R (R (R other))) ctx + +-- | Unify two types and return the mgu, i.e. the smallest +-- substitution which makes them equal. +unify :: + Has (Throw UnificationError) sig m => + UType -> + UType -> + m (Subst IntVar UType) +unify ty1 ty2 = case (ty1, ty2) of + (Pure x, Pure y) + | x == y -> return idS + | otherwise -> return $ x |-> Pure y + (Pure x, y) + | x `S.member` fuvs y -> throwError $ Infinite x y + | otherwise -> return $ x |-> y + (y, Pure x) + | x `S.member` fuvs y -> throwError $ Infinite x y + | otherwise -> return $ x |-> y + (Free t1, Free t2) -> unifyF t1 t2 + +-- | Unify two non-variable terms and return an mgu, i.e. the smallest +-- substitution which makes them equal. +unifyF :: + Has (Throw UnificationError) sig m => + TypeF UType -> + TypeF UType -> + m (Subst IntVar UType) +unifyF t1 t2 = case (t1, t2) of + (TyConF c1 ts1, TyConF c2 ts2) -> case c1 == c2 of + True -> compose <$> zipWithM unify ts1 ts2 + False -> unifyErr + (TyConF {}, _) -> unifyErr + (TyVarF v1, TyVarF v2) -> case v1 == v2 of + True -> return idS + False -> unifyErr + (TyVarF {}, _) -> unifyErr + (TyRcdF m1, TyRcdF m2) -> + case ((==) `on` M.keysSet) m1 m2 of + False -> unifyErr + _ -> (fmap compose . sequence) (M.merge M.dropMissing M.dropMissing (M.zipWithMatched (const unify)) m1 m2) + (TyRcdF {}, _) -> unifyErr + -- Don't support any extra features (e.g. recursive types), so just + -- add a catch-all failure case + (_, _) -> unifyErr + where + unifyErr = throwError $ UnifyErr t1 t2 diff --git a/src/swarm-lang/Swarm/Language/Capability.hs b/src/swarm-lang/Swarm/Language/Capability.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Capability.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Capabilities needed to evaluate and execute programs. Language +-- constructs or commands require certain capabilities, and in turn +-- capabilities are provided by various devices. A robot must have an +-- appropriate device equipped in order to make use of each language +-- construct or command. +module Swarm.Language.Capability ( + Capability (..), + capabilityName, + constCaps, + constByCaps, +) where + +import Control.Arrow ((&&&)) +import Data.Aeson (FromJSONKey, ToJSONKey) +import Data.Char (toLower) +import Data.Data (Data) +import Data.Hashable (Hashable) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +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 Witch (from) +import Prelude hiding (lookup) + +-- | Various capabilities which robots can have. +data Capability + = -- | 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 + CFloat + | -- | Evaluate conditional expressions + CCond + | -- | Negate boolean value + CNegation + | -- | Evaluate comparison operations + CCompare + | -- | Use cardinal direction constants. + 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. + CProd + | -- | Capability for working with record types. + 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) + +capabilityName :: Capability -> Text +capabilityName = from @String . map toLower . drop 1 . show + +instance ToJSON Capability where + toJSON = String . capabilityName + +instance FromJSON Capability where + parseJSON = withText "Capability" tryRead + where + tryRead :: Text -> Parser Capability + tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of + Just c -> return c + Nothing -> failT ["Unknown capability", t] + +-- | Capabilities needed to evaluate or execute a constant. +constCaps :: Const -> Maybe Capability +constCaps = \case + -- ---------------------------------------------------------------- + -- Some built-in constants that don't require any special capability. + Noop -> Nothing + AppF -> Nothing + Force -> Nothing + Return -> Nothing + Parent -> Nothing + Base -> Nothing + Setname -> Nothing + Undefined -> Nothing + Fail -> Nothing + Has -> Nothing + Equipped -> Nothing + -- speaking is natural to robots (unlike listening) + Say -> Nothing + -- 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 + 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 + +-- | Inverts the 'constCaps' mapping. +constByCaps :: Map Capability (NE.NonEmpty Const) +constByCaps = + binTuples $ + map swap $ + mapMaybe (sequenceA . (id &&& constCaps)) allConst diff --git a/src/swarm-lang/Swarm/Language/Context.hs b/src/swarm-lang/Swarm/Language/Context.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Context.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | +-- 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. +module Swarm.Language.Context where + +import Control.Algebra (Has) +import Control.Effect.Reader (Reader, ask, local) +import Control.Lens.Empty (AsEmpty (..)) +import Control.Lens.Prism (prism) +import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) +import Data.Data (Data) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Text (Text) +import GHC.Generics (Generic) +import Swarm.Util.JSON (optionsUnwrapUnary) +import Prelude hiding (lookup) + +-- | We use 'Text' values to represent variables. +type Var = Text + +-- | A context is a mapping from variable names to things. +newtype Ctx t = Ctx {unCtx :: Map Var t} + deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic) + +instance ToJSON t => ToJSON (Ctx t) where + toJSON = genericToJSON optionsUnwrapUnary + +instance FromJSON t => FromJSON (Ctx t) where + parseJSON = genericParseJSON optionsUnwrapUnary + +-- | The semigroup operation for contexts is /right/-biased union. +instance Semigroup (Ctx t) where + (<>) = union + +instance Monoid (Ctx t) where + mempty = empty + mappend = (<>) + +instance AsEmpty (Ctx t) where + _Empty = prism (const empty) isEmpty + where + isEmpty (Ctx c) + | M.null c = Right () + | otherwise = Left (Ctx c) + +-- | The empty context. +empty :: Ctx t +empty = Ctx M.empty + +-- | A singleton context. +singleton :: Var -> t -> Ctx t +singleton x t = Ctx (M.singleton x t) + +-- | Look up a variable in a context. +lookup :: Var -> Ctx t -> Maybe t +lookup x (Ctx c) = M.lookup x c + +-- | Look up a variable in a context in an ambient Reader effect. +lookupR :: Has (Reader (Ctx t)) sig m => Var -> 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) + +-- | Get the list of key-value associations from a context. +assocs :: Ctx t -> [(Var, t)] +assocs = M.assocs . 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) + +-- | /Right/-biased union of contexts. +union :: Ctx t -> Ctx t -> Ctx t +union (Ctx c1) (Ctx c2) = Ctx (c2 `M.union` c1) + +-- | Locally extend the context with an additional binding. +withBinding :: Has (Reader (Ctx t)) sig m => Var -> 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 ctx = local (`union` ctx) diff --git a/src/swarm-lang/Swarm/Language/Elaborate.hs b/src/swarm-lang/Swarm/Language/Elaborate.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Elaborate.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Term elaboration which happens after type checking. +module Swarm.Language.Elaborate where + +import Control.Applicative ((<|>)) +import Control.Lens (transform, (^.)) +import Swarm.Language.Syntax + +-- | Perform some elaboration / rewriting on a fully type-annotated +-- term. This currently performs such operations as rewriting @if@ +-- expressions and recursive let expressions to use laziness +-- appropriately. It also inserts types and requirements on bound +-- variables so they will be available at runtime. +-- +-- In theory it could also perform rewriting for overloaded +-- constants depending on the actual type they are used at, but +-- currently that sort of thing tends to make type inference fall +-- over. +elaborate :: TSyntax -> TSyntax +elaborate = transform rewrite + where + rewrite :: TSyntax -> TSyntax + rewrite (Syntax' l t cs ty) = Syntax' l (rewriteTerm t) cs ty + + rewriteTerm :: TTerm -> TTerm + rewriteTerm = \case + -- Here we take inferred types for variables bound by def or + -- bind (but NOT let) and stuff them into the term itself, so that + -- we will still have access to them at runtime, after type + -- annotations on the AST are erased. We need them at runtime so + -- we can keep track of the types of variables in scope, for use + -- in typechecking additional terms entered at the REPL. The + -- reason we do not do this for 'let' is so that 'let' introduces + -- truly local bindings which will not be available for use in + -- later REPL terms. + -- + -- We assume requirements for these variables have already been + -- filled in during typechecking. The reason we need to wait + -- until now to fill in the types is that we have to wait until + -- solving, substitution, and generalization are complete. + -- + -- 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) + LSLet -> Nothing + in SLet ls r x mty' 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 + -- Leave any other subterms alone. + t -> t + +-- | Insert a special 'suspend' primitive at the very end of an erased +-- term which must have a command type. +insertSuspend :: Term -> Term +insertSuspend t = case t of + -- Primitive things which have type Cmd Unit: p => (p ; suspend ()) + TRequireDevice {} -> thenSuspend + TRequire {} -> 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) + 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 + TConst Noop -> TSuspend TUnit + -- Anything else: p => (__res__ <- p; suspend __res__) + -- + -- Note that since we don't put type + reqs annotations on + -- __res__, it won't get added to the type environment and hence + -- won't be in scope for use after the suspend. But we pick a + -- weird unlikely-to-be-used name just to be safe. + t' -> TBind (Just "__res__") Nothing Nothing t' (TSuspend (TVar "__res__")) + where + thenSuspend = TBind Nothing Nothing Nothing t (TSuspend TUnit) diff --git a/src/swarm-lang/Swarm/Language/Format.hs b/src/swarm-lang/Swarm/Language/Format.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Format.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Formatting Swarm language code. +module Swarm.Language.Format where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (.~)) +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.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) + +-- | From where should the input be taken? +data FormatInput = Stdin | InputFile FilePath + +getInput :: FormatInput -> IO Text +getInput Stdin = T.getContents +getInput (InputFile fp) = T.readFile fp + +showInput :: FormatInput -> Text +showInput Stdin = "(input)" +showInput (InputFile fp) = T.pack fp + +-- | Where should the formatted code be output? +data FormatOutput = Stdout | OutputFile FilePath | Inplace + +type FormatWidth = Int + +data FormatConfig = FormatConfig + { formatInput :: FormatInput + , formatOutput :: FormatOutput + , formatWidth :: Maybe FormatWidth + , formatLanguageVersion :: LanguageVersion + } + +-- | Validate and format swarm-lang code. +formatSwarmIO :: FormatConfig -> IO () +formatSwarmIO cfg@(FormatConfig input output mWidth _) = do + content <- getInput input + mWindowWidth <- (fmap . fmap) Term.width Term.size + let w = mWidth <|> case output of Stdout -> mWindowWidth; _ -> Nothing + case formatSwarm cfg {formatWidth = w} content of + Right fmt -> case output of + Stdout -> T.putStrLn fmt + OutputFile outFile -> T.writeFile outFile fmt + Inplace -> case input of + Stdin -> T.putStrLn fmt + InputFile inFile -> T.writeFile inFile fmt + Left e -> do + T.hPutStrLn stderr $ showInput input <> ":" <> e + exitFailure + +formatSwarm :: FormatConfig -> Text -> Either Text Text +formatSwarm (FormatConfig _ _ mWidth ver) content = case readTerm' cfg content of + Right Nothing -> Right "" + Right (Just ast) -> + let mkOpt w = LayoutOptions (AvailablePerLine w 1.0) + opt = (mkOpt <$> mWidth) ? defaultLayoutOptions + in Right . RT.renderStrict . layoutPretty opt $ ppr ast + Left e -> Left (into @Text $ errorBundlePretty e) + where + cfg = defaultParserConfig & languageVersion .~ ver diff --git a/src/swarm-lang/Swarm/Language/JSON.hs b/src/swarm-lang/Swarm/Language/JSON.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/JSON.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Some orphan @To/FromJSON@ instances for terms and values. We have +-- to put them all here to avoid circular module dependencies. +module Swarm.Language.JSON where + +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.Util.JSON (optionsMinimize) +import Witch (into) + +instance FromJSON TSyntax where + parseJSON = withText "Term" $ either (fail . into @String) return . processTermEither + +instance ToJSON TSyntax where + toJSON = Ae.String . prettyText + +instance FromJSON Term +instance FromJSON Syntax +instance ToJSON Term +instance ToJSON Syntax + +instance ToJSON Value where + toJSON = genericToJSON optionsMinimize + +instance FromJSON Value where + parseJSON = genericParseJSON optionsMinimize + +deriving instance FromJSON Env +deriving instance ToJSON Env diff --git a/src/swarm-lang/Swarm/Language/Key.hs b/src/swarm-lang/Swarm/Language/Key.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Key.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parsing and pretty-printing for keys (as in, keys on a keyboard) +-- and key combos. +module Swarm.Language.Key ( + KeyCombo, + mkKeyCombo, + parseKeyComboFull, + parseKeyCombo, + prettyKeyCombo, + specialKeyNames, +) +where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Foldable (asum) +import Data.Kind qualified +import Data.List (sort, (\\)) +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void +import GHC.Generics hiding (from) +import Graphics.Vty.Input.Events qualified as V +import Text.Megaparsec +import Text.Megaparsec.Char (char, string) +import Text.Megaparsec.Char.Lexer (decimal) +import Witch (from) + +------------------------------------------------------------ +-- Parsing + +-- | 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 instance FromJSON V.Key +deriving instance FromJSON V.Modifier +deriving instance ToJSON V.Key +deriving instance ToJSON V.Modifier + +type SParser = Parsec Void Text + +-- | Smart constructor for 'KeyCombo'. +mkKeyCombo :: [V.Modifier] -> V.Key -> KeyCombo +mkKeyCombo mods k = KeyCombo k (sort mods) + +-- | Parse a key combo with nothing after it. +parseKeyComboFull :: SParser KeyCombo +parseKeyComboFull = parseKeyCombo <* eof + +-- | Parse a key combo like @\"M-C-F5\"@, @\"Down\"@, or @\"C-x\"@. +parseKeyCombo :: SParser KeyCombo +parseKeyCombo = + mkKeyCombo <$> many (try (parseModifier <* char '-')) <*> parseKey + +parseModifier :: SParser V.Modifier +parseModifier = + V.MShift <$ string "S" + <|> V.MCtrl <$ string "C" + <|> V.MMeta <$ string "M" + <|> V.MAlt <$ string "A" + +parseKey :: SParser V.Key +parseKey = + -- For an explanation of the 'reverse', see Note [Key names are not prefix-free] + (asum . map specialKeyParser . reverse . S.toList $ specialKeyNames) + <|> parseFunctionKey + <|> parseCharKey + +-- Note [Key names are not prefix-free] +-- +-- The names of special keys are not prefix-free, and in particular +-- include 'Down', 'DownRight', 'DownLeft', and also 'Up', 'UpRight', +-- 'UpLeft'. When we try to parse a particular name with 'string' it +-- will backtrack as long as the whole string is not consumed, which +-- means it's OK if key names share a common prefix, like Enter and +-- Esc. However, when one key name is a prefix of another we have to +-- be careful of the order in which we try parsing them, and in +-- particular we must try parsing the longer one first. If we have +-- 'Up' come first and then 'UpLeft', for example, given the input +-- "UpLeft" the 'Up' would succeed, but then the entire parse would +-- fail since there is input left over. If we simply reverse the list +-- of key names (which are sorted alphabetically), it guarantees that +-- longer names will come before names which are prefixes of them. + +parseFunctionKey :: SParser V.Key +parseFunctionKey = V.KFun <$> try (char 'F' *> decimal) + +parseCharKey :: SParser V.Key +parseCharKey = V.KChar <$> anySingle + +specialKeyParser :: Text -> SParser V.Key +specialKeyParser t = read . ('K' :) . from @Text <$> string t + +-- https://stackoverflow.com/questions/51848587/list-constructor-names-using-generics-in-haskell +specialKeyNames :: Set Text +specialKeyNames = S.fromList . map T.tail $ (names' @(Rep V.Key) \\ ["KChar", "KFun"]) + +class Names' (f :: Data.Kind.Type -> Data.Kind.Type) where + names' :: [Text] +instance (Names' f) => Names' (M1 D t f) where + names' = names' @f +instance (Names' f, Names' g) => Names' (f :+: g) where + names' = names' @f ++ names' @g +instance (Constructor c) => Names' (C1 c f) where + names' = [from @String (conName (undefined :: C1 c f g))] + +------------------------------------------------------------ +-- Pretty-printing + +-- | Pretty-print a key combo, e.g. @\"C-M-F5\"@. Right inverse to +-- 'parseKeyCombo'. Left inverse up to reordering of modifiers. +prettyKeyCombo :: KeyCombo -> Text +prettyKeyCombo (KeyCombo k mods) = T.append (T.concat (map prettyModifier mods)) (prettyKey k) + +prettyModifier :: V.Modifier -> Text +prettyModifier m = from @String [modifierChar m, '-'] + where + modifierChar = \case + V.MAlt -> 'A' + V.MCtrl -> 'C' + V.MMeta -> 'M' + V.MShift -> 'S' + +prettyKey :: V.Key -> Text +prettyKey = + from @String . \case + V.KChar c -> [c] + V.KFun n -> 'F' : show n + k -> drop 1 (show k) diff --git a/src/swarm-lang/Swarm/Language/Kindcheck.hs b/src/swarm-lang/Swarm/Language/Kindcheck.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Kindcheck.hs @@ -0,0 +1,132 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Kind checking for the Swarm language. +module Swarm.Language.Kindcheck ( + KindError (..), + checkPolytypeKind, + checkKind, +) where + +import Control.Algebra (Has) +import Control.Effect.Reader (Reader, ask) +import Control.Effect.Throw (Throw, throwError) +import Control.Monad.Extra (unlessM) +import Data.Fix (Fix (..)) +import Swarm.Language.Types + +-- | Kind checking errors that can occur. +data KindError + = -- | A type constructor expects n arguments, but was given these + -- arguments instead. + ArityMismatch TyCon Int [Type] + | -- | An undefined type constructor was encountered in the given type. + UndefinedTyCon TyCon Type + | -- | A trivial recursive type (one that does not use its bound + -- variable) was encountered. + TrivialRecTy Var Type + | -- | A vacuous recursive type (one that expands immediately to + -- itself) was encountered. + 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 + +-- | 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 +-- -> Type -> ... -> Type@ which can be represented by a number (the +-- arity); every type constructor must also be fully applied. So, we +-- only have to check that each type constructor is applied to the +-- correct number of type arguments. In the future, we might very +-- well want to generalize to arbitrary higher kinds (e.g. @(Type -> +-- Type) -> Type@ etc.) which would require generalizing this +-- checking code a bit. +-- +-- Here we also check that any recursive types are non-vacuous, +-- /i.e./ not of the form @rec t. t@, and non-trivial, /i.e./ the +-- variable bound by the @rec@ actually occurs somewhere in the +-- body. +checkKind :: (Has (Reader TDCtx) sig m, Has (Throw KindError) sig m) => Type -> m () +checkKind ty@(Fix tyF) = case tyF of + TyConF c tys -> do + tdCtx <- ask + case getArity <$> tcArity tdCtx c of + Nothing -> throwError $ UndefinedTyCon c ty + Just a -> case compare (length tys) a of + EQ -> mapM_ checkKind tys + _ -> throwError $ ArityMismatch c a tys + TyVarF _ -> return () + TyRcdF m -> mapM_ checkKind m + TyRecF x t -> do + -- It's important to call checkKind first, to rule out undefined + -- type constructors. Within the recursive kind check, we + -- substitute the given variable name for the bound de Bruijn + -- 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) + -- 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. + checkRecTy x t + TyRecVarF _ -> return () + +-- | Check that the body of a recursive type actually contains the +-- bound variable at least once (otherwise there's no point in using +-- @rec@) and does not consist solely of that variable. +checkRecTy :: (Has (Reader TDCtx) sig m, Has (Throw KindError) sig m) => Var -> Type -> m () +checkRecTy x ty = do + unlessM (containsVar NZ ty) $ throwError (TrivialRecTy x ty) + unlessM (nonVacuous NZ ty) $ throwError (VacuousRecTy x ty) + +-- Note, in theory it would be more efficient to combine containsVar +-- and nonVacuous into a single check that walks over the type only +-- once, but we keep them separate just to simplify things. This +-- won't make much difference in the grand scheme of things since +-- types are small. + +-- | 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 + TyRecVarF j -> pure (i == j) + TyVarF {} -> pure False + TyConF (TCUser u) tys -> do + 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 + +-- | @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 +-- another way, we make sure the recursive type is "productive" in +-- the sense that unfolding it will result in a well-defined +-- infinite type (as opposed to @rec x. x@ which just unfolds to +-- itself). However, we can't just check whether it literally looks +-- 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 + -- 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 + nonVacuous i ty' + -- Increment the variable we're looking for when going under a @rec@ + -- binder. + TyRecF _ ty -> nonVacuous (NS i) ty + -- If we encounter any other kind of type constructor or record + -- type, rejoice! + TyConF {} -> pure True + TyRcdF {} -> pure True + -- This last case can't actully happen if we already checked that + -- the recursive type actually contains its bound variable (with + -- 'containsVar'), since it would correspond to something like @rec + -- x. y@. However, it's still correct to return True. + TyVarF {} -> pure True diff --git a/src/swarm-lang/Swarm/Language/LSP.hs b/src/swarm-lang/Swarm/Language/LSP.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/LSP.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Language Server Protocol (LSP) server for the Swarm language. +-- See the docs/EDITORS.md to learn how to use it. +module Swarm.Language.LSP where + +import Control.Lens (to, (^.)) +import Control.Monad (void) +import Control.Monad.IO.Class +import Data.Int (Int32) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text.IO qualified as Text +import Language.LSP.Diagnostics +import Language.LSP.Protocol.Lens qualified as LSP +import Language.LSP.Protocol.Message qualified as LSP +import Language.LSP.Protocol.Types qualified as LSP +import Language.LSP.Server +import Language.LSP.VFS (VirtualFile (..), virtualFileText) +import Swarm.Language.LSP.Hover qualified as H +import Swarm.Language.LSP.VarUsage qualified as VU +import Swarm.Language.Parser (readTerm') +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 System.IO (stderr) +import Witch + +lspMain :: IO () +lspMain = + void $ + runServer $ + ServerDefinition + { defaultConfig = () + , configSection = "swarm" + , parseConfig = const $ const $ Right () + , onConfigChange = const $ return () + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = const handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = + defaultOptions + { -- set sync options to get DidSave event, as well as Open and Close events. + optTextDocumentSync = + Just + ( LSP.TextDocumentSyncOptions + (Just True) + (Just syncKind) + (Just False) + (Just False) + (Just . LSP.InR . LSP.SaveOptions $ Just True) + ) + } + } + where + -- Using SyncFull seems to handle the debounce for us. + -- The alternative is to use SyncIncremental, but then the + -- handler is called for each keystroke. + syncKind = LSP.TextDocumentSyncKind_Full + +diagnosticSourcePrefix :: Text +diagnosticSourcePrefix = "swarm-lsp" + +debug :: (MonadIO m) => Text -> m () +debug msg = liftIO $ Text.hPutStrLn stderr $ "[swarm-lsp] " <> msg + +type TextDocumentVersion = Int32 + +validateSwarmCode :: LSP.NormalizedUri -> Maybe TextDocumentVersion -> Text -> LspM () () +validateSwarmCode doc version content = do + -- debug $ "Validating: " <> from (show doc) <> " ( " <> content <> ")" + + -- FIXME: #1040 With this call to flushDiagnosticsBySource in place, the warnings + -- in other buffers (editor tabs) end up getting cleared when switching between + -- (focusing on) other buffers in VS Code. + -- However, getting rid of this seems to break error highlighting. + flushDiagnosticsBySource 0 (Just diagnosticSourcePrefix) + + let (parsingErrs, unusedVarWarnings) = case readTerm' defaultParserConfig content of + Right Nothing -> ([], []) + Right (Just term) -> (parsingErrors, unusedWarnings) + where + VU.Usage _ problems = VU.getUsage mempty term + unusedWarnings = mapMaybe (VU.toErrPos content) problems + + parsingErrors = case processParsedTerm' mempty term of + Right _ -> [] + Left e -> pure $ showTypeErrorPos content e + Left e -> (pure $ showErrorPos e, []) + -- debug $ "-> " <> from (show err) + + publishDiags $ + map makeUnusedVarDiagnostic unusedVarWarnings + + -- NOTE: "publishDiags" keeps only one diagnostic at a + -- time (the most recent) so we make sure the errors are + -- issued last (after any warnings). + -- Note that it does not achieve the desired effect to simply + -- concatenate the two diagnostic lists into a single + -- publishDiagnostics function call (regardless of the order + -- of the lists). + publishDiags $ + map makeParseErrorDiagnostic parsingErrs + where + publishDiags :: [LSP.Diagnostic] -> LspM () () + publishDiags = publishDiagnostics 1 doc version . partitionBySource + + makeUnusedVarDiagnostic :: (LSP.Range, Text) -> LSP.Diagnostic + makeUnusedVarDiagnostic (range, msg) = + LSP.Diagnostic + range + (Just LSP.DiagnosticSeverity_Warning) -- severity + Nothing -- code + Nothing -- code description + (Just diagnosticSourcePrefix) -- source + msg + (Just [LSP.DiagnosticTag_Unnecessary]) -- tags + Nothing -- related source code info + Nothing -- data + makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> LSP.Diagnostic + makeParseErrorDiagnostic ((startLine, startCol), (endLine, endCol), msg) = + LSP.Diagnostic + ( LSP.Range + (LSP.Position (fromIntegral startLine) (fromIntegral startCol)) + (LSP.Position (fromIntegral endLine) (fromIntegral endCol)) + ) + (Just LSP.DiagnosticSeverity_Error) -- severity + Nothing -- code + Nothing -- code description + (Just diagnosticSourcePrefix) -- source + msg + Nothing -- tags + (Just []) -- related info + Nothing -- data + +showTypeErrorPos :: Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text) +showTypeErrorPos code (CTE l _ te) = (minusOne start, minusOne end, msg) + where + minusOne (x, y) = (x - 1, y - 1) + + (start, end) = case l of + SrcLoc s e -> getLocRange code (s, e) + NoLoc -> ((1, 1), (65535, 65535)) -- unknown loc spans the whole document + msg = prettyText te + +handlers :: Handlers (LspM ()) +handlers = + mconcat + [ notificationHandler LSP.SMethod_Initialized $ \_not -> do + debug "Initialized" + , notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri + content = fromMaybe "?" $ msg ^. LSP.params . LSP.text + validateSwarmCode (LSP.toNormalizedUri doc) Nothing content + , notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri + content = msg ^. LSP.params . LSP.textDocument . LSP.text + validateSwarmCode (LSP.toNormalizedUri doc) Nothing content + , notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri + mdoc <- getVirtualFile doc + case mdoc of + Just vf@(VirtualFile _ version _rope) -> do + validateSwarmCode doc (Just (fromIntegral version)) (virtualFileText vf) + _ -> debug $ "No virtual file found for: " <> from (show msg) + , requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do + let doc = req ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri + pos = req ^. LSP.params . LSP.position + mdoc <- getVirtualFile doc + let maybeHover = do + vf <- mdoc + (markdownText, maybeRange) <- H.showHoverInfo doc pos vf + return $ LSP.Hover (LSP.InL $ LSP.MarkupContent LSP.MarkupKind_Markdown markdownText) maybeRange + responder . Right . LSP.maybeToNull $ maybeHover + ] diff --git a/src/swarm-lang/Swarm/Language/LSP/Hover.hs b/src/swarm-lang/Swarm/Language/LSP/Hover.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/LSP/Hover.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Language.LSP.Hover ( + showHoverInfo, + + -- * Documentation rendering + renderDoc, + treeToMarkdown, + + -- * Finding source location + narrowToPosition, + + -- * Explaining source position + explain, +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((^.)) +import Control.Monad (guard, void) +import Data.Foldable (asum) +import Data.Graph +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map qualified as M +import Data.Maybe (catMaybes, fromMaybe) +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.Typecheck (inferConst) +import Swarm.Language.Types +import Swarm.Util qualified as U + +withinBound :: Int -> SrcLoc -> Bool +withinBound pos (SrcLoc s e) = pos >= s && pos < e +withinBound _ NoLoc = False + +ropeToLspPosition :: R.Position -> J.Position +ropeToLspPosition (R.Position l c) = + J.Position (fromIntegral l) (fromIntegral c) + +lspToRopePosition :: J.Position -> R.Position +lspToRopePosition (J.Position myLine myCol) = + R.Position (fromIntegral myLine) (fromIntegral myCol) + +showHoverInfo :: + J.NormalizedUri -> + J.Position -> + VirtualFile -> + Maybe (Text, Maybe J.Range) +showHoverInfo _ p vf@(VirtualFile _ _ myRope) = + either (const Nothing) (fmap genHoverInfo) (readTerm' defaultParserConfig content) + where + content = virtualFileText vf + absolutePos = + R.charLength . fst $ R.charSplitAtPosition (lspToRopePosition p) myRope + + genHoverInfo stx = + case processParsedTerm stx of + Left _e -> + let found = narrowToPosition stx $ fromIntegral absolutePos + finalPos = posToRange myRope (found ^. sLoc) + in (,finalPos) . treeToMarkdown 0 $ explain found + Right pt -> + let found = + narrowToPosition pt $ fromIntegral absolutePos + finalPos = posToRange myRope (found ^. sLoc) + in (,finalPos) . treeToMarkdown 0 $ explain found + +posToRange :: R.Rope -> SrcLoc -> Maybe J.Range +posToRange myRope foundSloc = do + (s, e) <- case foundSloc of + SrcLoc s e -> Just (s, e) + _ -> Nothing + let (startRope, _) = R.charSplitAt (fromIntegral s) myRope + (endRope, _) = R.charSplitAt (fromIntegral e) myRope + return $ + J.Range + (ropeToLspPosition $ R.charLengthAsPosition startRope) + (ropeToLspPosition $ R.charLengthAsPosition endRope) + +descend :: + ExplainableType ty => + -- | position + Int -> + -- | next element to inspect + Syntax' ty -> + Maybe (Syntax' ty) +descend pos s1@(Syntax' l1 _ _ _) = do + guard $ withinBound pos l1 + return $ narrowToPosition s1 pos + +-- | Find the most specific term for a given +-- position within the code. +narrowToPosition :: + ExplainableType ty => + -- | parent term + Syntax' ty -> + -- | absolute offset within the file + Int -> + Syntax' ty +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 + SBind mlv _ _ _ s1@(Syntax' _ _ _ lty) s2 -> (mlv >>= d . flip locVarToSyntax' (getInnerType lty)) <|> d s1 <|> d s2 + 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 + -- atoms - return their position and end recursion + TUnit -> Nothing + TConst {} -> Nothing + TDir {} -> Nothing + TInt {} -> Nothing + TText {} -> Nothing + TBool {} -> Nothing + TVar {} -> Nothing + TRequire {} -> Nothing + TRequireDevice {} -> Nothing + STydef {} -> Nothing + -- these should not show up in surface language + TRef {} -> Nothing + TRobot {} -> Nothing + TAntiInt {} -> Nothing + TAntiText {} -> Nothing + SSuspend {} -> Nothing + where + d = descend pos + +renderDoc :: Int -> Text -> Text +renderDoc d t + | d == 0 = t + | otherwise = T.drop 2 . indent (max 0 (4 * (d - 1)) + 2) $ "* " <> t + where + indent x = T.unlines . map (T.replicate x " " <>) . T.lines + +treeToMarkdown :: Int -> Tree Text -> Text +treeToMarkdown d (Node t children) = + T.unlines $ renderDoc d t : map (treeToMarkdown $ d + 1) children + +class Show t => ExplainableType t where + -- | Pretty print the type. + prettyType :: t -> Text + + -- | Strip the type of its outermost layer. + -- + -- This allows us to strip lambda or command type + -- and get the type of the bound variable. + getInnerType :: t -> t + + -- | Check if this type is same as the given 'Polytype'. + -- + -- We use it to not print same type twice (e.g. inferred and generic). + eq :: t -> Polytype -> Bool + +instance ExplainableType () where + prettyType = const "?" + getInnerType = id + eq _ _ = False + +instance ExplainableType Polytype where + prettyType = prettyTextLine + getInnerType = fmap $ \case + (l :->: _r) -> l + (TyCmd t) -> t + t -> t + eq = (==) + +explain :: ExplainableType ty => Syntax' ty -> Tree Text +explain trm = case trm ^. sTerm of + TUnit -> literal "The unit value." + TConst c -> literal . constGenSig c $ briefDoc (constDoc $ constInfo c) + TDir {} -> literal "A direction literal." + TInt {} -> literal "An integer literal." + TText {} -> literal "A text literal." + TBool {} -> literal "A boolean literal." + TVar v -> pure $ typeSignature v ty "" + SRcd {} -> literal "A record literal." + SProj {} -> literal "A record projection." + STydef {} -> literal "A type synonym definition." + -- type ascription + SAnnotate lhs typeAnn -> + Node + (typeSignature "_" typeAnn "A type ascription for") + [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." + 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 + SLam (LV _s v) _mType _syn -> + pure $ + typeSignature v ty $ + "A lambda expression binding the variable " <> U.bquote v <> "." + SBind mv _ _ _ rhs _cmds -> + pure $ + typeSignature (maybe "__rhs" lvVar mv) (getInnerType $ rhs ^. sType) $ + "A monadic bind for commands" <> maybe "." (\(LV _s v) -> ", that binds variable " <> U.bquote v <> ".") mv + -- composite types + SPair {} -> + Node + (typeSignature "_" ty "A tuple consisting of:") + (explain <$> unTuple trm) + SDelay {} -> + pure . T.unlines $ + [ "Delay evaluation of a term, written `{...}`." + , "" + , "Swarm is an eager language, but in some cases (e.g. for `if` statements and recursive bindings) we need to delay evaluation." + , "" + , "The counterpart to `{...}` is `force`:" + , "```" + , "force {t} = t" + , "```" + ] + -- internal syntax that should not actually show in hover + 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." + TRobot {} -> internal "A robot reference." + SSuspend {} -> internal "A suspension." + where + ty = trm ^. sType + literal = pure . typeSignature (prettyText . void $ trm ^. sTerm) ty + 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 + +-- | Helper function to explain function application. +-- +-- Note that 'Force' is often inserted internally, so +-- if it shows up here we drop it. +explainFunction :: ExplainableType ty => Syntax' ty -> Tree Text +explainFunction s = + case unfoldApps s of + (Syntax' _ (TConst Force) _ _ :| [innerT]) -> explain innerT + (Syntax' _ (TConst Force) _ _ :| f : params) -> explainF f params + (f :| params) -> explainF f params + where + explainF f params = + Node + "Function application of:" + [ explain f + , Node + "with parameters:" + (map explain params) + ] + +explainDefinition :: ExplainableType ty => LetSyntax -> Bool -> LocVar -> ty -> Maybe Polytype -> Text +explainDefinition ls isRecursive (LV _s var) ty maybeTypeAnnotation = + typeSignature var ty $ + T.unwords + [ "A" + , (if isRecursive then "" else "non-") <> "recursive" + , if ls == LSDef then "definition" else "let" + , "expression" + , if null maybeTypeAnnotation then "without" else "with" + , "a type annotation on the variable." + ] + +typeSignature :: ExplainableType ty => Var -> ty -> Text -> Text +typeSignature v typ body = T.unlines ["```", short, "```", body] + where + short = v <> ": " <> prettyType typ diff --git a/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs b/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Language.LSP.VarUsage where + +import Control.Monad (guard) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Language.LSP.Protocol.Types qualified as J +import Swarm.Language.Parser.Util qualified as P +import Swarm.Language.Syntax +import Swarm.Util qualified as U + +data BindingType + = Lambda + | Let + | Bind + deriving (Eq, Show) + +data VarUsage = VarUsage LocVar BindingType + +type BindingSites = Map Var (NonEmpty SrcLoc) + +data Usage = Usage + { usages :: Set LocVar + -- ^ Variable references + , problems :: [VarUsage] + -- ^ Variable declarations without any references + } + +instance Semigroup Usage where + Usage y1 z1 <> Usage y2 z2 = + Usage + (y1 <> y2) + (z1 <> z2) + +instance Monoid Usage where + mempty = Usage mempty mempty + +toErrPos :: Text -> VarUsage -> Maybe (J.Range, Text) +toErrPos code (VarUsage (LV loc v) scope) = do + -- A leading underscore will suppress the unused variable warning + guard $ not $ "_" `T.isPrefixOf` v + rangePair <- case loc of + SrcLoc s e -> Just (s, e) + _ -> Nothing + let (start, end) = P.getLocRange code rangePair + ((startLine, startCol), (endLine, endCol)) = (minusOne start, minusOne end) + range = + J.Range + (J.Position (fromIntegral startLine) (fromIntegral startCol)) + (J.Position (fromIntegral endLine) (fromIntegral endCol)) + return (range, txt) + where + txt = + T.unwords + [ "Unused variable" + , U.quote v + , "in" + , T.pack $ show scope + , "expression" + ] + minusOne (x, y) = (x - 1, y - 1) + +-- | Descends the syntax tree rooted at a variable declaration, +-- accumulating variable references. +-- Generates a "problem" if an associated variable reference +-- is not encountered in the subtree for this declaration. +checkOccurrences :: + BindingSites -> + LocVar -> + BindingType -> + [Syntax] -> + Usage +checkOccurrences bindings lv@(LV loc v) declType childSyntaxes = + Usage childUsages $ missing <> deeperMissing + where + deeperBindings = M.insertWith (<>) v (pure loc) bindings + Usage childUsages deeperMissing = mconcat $ map (getUsage deeperBindings) childSyntaxes + missing = [VarUsage lv declType | lv `S.notMember` childUsages] + +-- | Build up the bindings map as a function argument as +-- we descend into the syntax tree. +-- Aggregates unused bindings as we return from each layer. +getUsage :: + BindingSites -> + Syntax -> + Usage +getUsage bindings (CSyntax _pos t _comments) = case t of + TVar v -> Usage myUsages mempty + where + myUsages = case M.lookup v bindings of + Nothing -> mempty + Just (loc :| _) -> S.singleton $ LV loc v + 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] + -- 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 + 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 diff --git a/src/swarm-lang/Swarm/Language/Parser.hs b/src/swarm-lang/Swarm/Language/Parser.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parser for the Swarm language. Note, you probably don't want to +-- use this directly, unless there is a good reason to parse a term +-- without also type checking it; use +-- 'Swarm.Language.Pipeline.processTerm' instead, which parses, +-- typechecks, elaborates, and capability checks a term all at once. +module Swarm.Language.Parser ( + readTerm, + readTerm', +) where + +import Data.Bifunctor (first, second) +import Data.Sequence (Seq) +import Data.Text (Text) +import Swarm.Language.Parser.Comment (populateComments) +import Swarm.Language.Parser.Core (ParserConfig, ParserError, defaultParserConfig, runParser') +import Swarm.Language.Parser.Lex (sc) +import Swarm.Language.Parser.Term (parseTerm) +import Swarm.Language.Parser.Util (fullyMaybe) +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 either the resulting 'Term' (or +-- 'Nothing' if the input was only whitespace) or a pretty-printed +-- parse error message. +readTerm :: Text -> Either Text (Maybe Syntax) +readTerm = first (from . errorBundlePretty) . readTerm' defaultParserConfig + +-- | A lower-level `readTerm` which allow configuring the parser and +-- returns the megaparsec bundle error for precise error reporting. +readTerm' :: ParserConfig -> Text -> Either ParserError (Maybe Syntax) +readTerm' cfg = second handleComments . runParser' cfg (fullyMaybe sc parseTerm) + where + handleComments :: (Maybe Syntax, Seq Comment) -> Maybe Syntax + handleComments (s, cs) = populateComments cs <$> s diff --git a/src/swarm-lang/Swarm/Language/Parser/Comment.hs b/src/swarm-lang/Swarm/Language/Parser/Comment.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/Comment.hs @@ -0,0 +1,119 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Facilities for re-inserting parsed comments back into an AST. +-- Actual parsing of comments is handled in "Swarm.Language.Parser.Lex". +module Swarm.Language.Parser.Comment ( + -- * Comment AST insertion + populateComments, + populateStandaloneComments, + populateSuffixComments, + + -- * Generic tree traversals + preorder, + revpostorder, +) where + +import Control.Lens (backwards, mapMOf, (%~)) +import Control.Lens.Plated (Plated, plate) +import Control.Monad ((>=>)) +import Control.Monad.State (MonadState (..), State, evalState) +import Data.Foldable qualified as F +import Data.List (partition) +import Data.Sequence (Seq, (<|), (|>)) +import Swarm.Language.Syntax + +------------------------------------------------------------ +-- Comment insertion +------------------------------------------------------------ + +-- The approach for preserving comments is taken from +-- https://www.reddit.com/r/haskell/comments/ni4gpm/comment/gz0ipmp/ . In short: +-- +-- (1) Parse all comments out-of-band and record a source span for +-- each (this is done in "Swarm.Language.Parser.Lex"). +-- +-- (2) For each standalone comment (i.e. comments on a line by +-- themselves), attach them to the earliest node in a preorder +-- traversal which begins after the comment. +-- +-- (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 +-- before the comment. + +-- | Re-insert parsed comments into an AST. Prerequisite: the sequence of comments +-- must be in order by 'SrcLoc'. +populateComments :: Seq Comment -> Syntax -> Syntax +populateComments cmts = populateStandaloneComments standalone . populateSuffixComments suffix + where + (standalone, suffix) = partition isStandalone (F.toList cmts) + +-- | Insert comments from the state at the current AST node (using the +-- provided insertion function) as long as the custom comparison +-- function returns 'True' when applied to the 'SrcLoc's of the next +-- comment and the AST node (in that order). +insertComments :: + (SrcLoc -> SrcLoc -> Bool) -> + (Comment -> Comments -> Comments) -> + Syntax -> + State [Comment] Syntax +insertComments cmpLoc ins = go + where + go s@(CSyntax l t cs) = do + curCmts <- get + case curCmts of + [] -> return s + (nextCmt : restCmts) -> case commentSrcLoc nextCmt `cmpLoc` l of + True -> put restCmts >> go (CSyntax l t (ins nextCmt cs)) + False -> return s + +-- | Given a list of standalone comments sorted by 'SrcLoc', insert +-- them into the given AST, attaching each comment to the earliest +-- node in a preorder traversal which begins after it. +populateStandaloneComments :: [Comment] -> Syntax -> Syntax +populateStandaloneComments cmts = + flip evalState cmts + . preorder (insertComments srcLocBefore (\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. +populateSuffixComments :: [Comment] -> Syntax -> Syntax +populateSuffixComments cmts = + flip evalState (reverse cmts) + . revpostorder (insertComments (flip srcLocBefore) (\c -> afterComments %~ (c <|))) + +------------------------------------------------------------ +-- Traversals +------------------------------------------------------------ + +-- $setup +-- >>> import Control.Monad.State +-- >>> import Data.Tree +-- >>> import Data.List (intercalate) +-- >>> next :: Tree Int -> State Int (Tree Int); next (Node _ cs) = do { i <- get; put (i+1); return (Node i cs) } +-- >>> showTree :: Show a => Tree a -> String; showTree = foldTree (\n cs -> show n ++ case cs of { [] -> ""; _ -> "(" ++ intercalate " " cs ++ ")" }) +-- >>> exampleTree = Node 0 [Node 0 [], Node 0 [Node 0 [], Node 0 [], Node 0 []], Node 0 [Node 0 []]] + +-- | Preorder traversal of a 'Plated' structure with a monadic +-- transformation. Apply the transformation at the root, then +-- recursively transform each of the children. +-- +-- >>> showTree (evalState (preorder next exampleTree) 0) +-- "0(1 2(3 4 5) 6(7))" +preorder :: (Plated a, Monad m) => (a -> m a) -> (a -> m a) +preorder g = go + where + 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. +-- +-- >>> showTree (evalState (revpostorder next exampleTree) 0) +-- "7(6 5(4 3 2) 1(0))" +revpostorder :: (Plated a, Monad m) => (a -> m a) -> (a -> m a) +revpostorder g = go + where + go = mapMOf (backwards plate) go >=> g diff --git a/src/swarm-lang/Swarm/Language/Parser/Core.hs b/src/swarm-lang/Swarm/Language/Parser/Core.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/Core.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Core data type definitions and utilities for the Swarm language +-- parser. +module Swarm.Language.Parser.Core ( + -- * Parser configuration + Antiquoting (..), + LanguageVersion (..), + ParserConfig, + defaultParserConfig, + antiquoting, + languageVersion, + + -- * Comment parsing state + CommentState (..), + freshLine, + comments, + + -- * Parser type + Parser, + ParserError, + + -- ** Running + runParser, + runParser', + runParserTH, +) where + +import Control.Lens (makeLenses, (^.)) +import Control.Monad.Reader (ReaderT, runReaderT) +import Control.Monad.State (StateT, runStateT) +import Data.Bifunctor (second) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Text (Text) +import Data.Void (Void) +import Swarm.Language.Syntax (Comment) +import Text.Megaparsec hiding (runParser, runParser') +import Text.Megaparsec qualified as MP +import Text.Megaparsec.State (initialPosState, initialState) +import Witch (from) + +------------------------------------------------------------ +-- Custom parser state + +-- | When parsing a term using a quasiquoter (i.e. something in the +-- Swarm source code that will be parsed at compile time), we want +-- to allow antiquoting, i.e. writing something like $x to refer to +-- an existing Haskell variable. But when parsing a term entered by +-- the user at the REPL, we do not want to allow this syntax. +data Antiquoting = AllowAntiquoting | DisallowAntiquoting + deriving (Eq, Ord, Show) + +-- | 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 + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Read-only parser configuration. +data ParserConfig = ParserConfig + { _antiquoting :: Antiquoting + , _languageVersion :: LanguageVersion + } + +makeLenses ''ParserConfig + +defaultParserConfig :: ParserConfig +defaultParserConfig = + ParserConfig + { _antiquoting = DisallowAntiquoting + , _languageVersion = SwarmLangLatest + } + +data CommentState = CS + { _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). + , _comments :: Seq Comment + -- ^ The actual sequence of comments, in the order they were encountered + } + +makeLenses ''CommentState + +initCommentState :: CommentState +initCommentState = CS {_freshLine = True, _comments = Seq.empty} + +------------------------------------------------------------ +-- Parser types + +type Parser = ReaderT ParserConfig (StateT CommentState (Parsec Void Text)) + +type ParserError = ParseErrorBundle Text Void + +------------------------------------------------------------ +-- Running parsers + +-- | Run a parser on some input text, returning either the result + +-- all collected comments, or a parse error message. +runParser :: Parser a -> Text -> Either ParserError (a, Seq Comment) +runParser = runParser' defaultParserConfig + +-- | Like 'runParser', but allow configuring with an arbitrary +-- 'ParserConfig'. +runParser' :: ParserConfig -> Parser a -> Text -> Either ParserError (a, Seq Comment) +runParser' cfg p t = + (\pt -> parse pt "" t) + . fmap (second (^. comments)) + . flip runStateT initCommentState + . 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 = + either (fail . errorBundlePretty) (return . fst) + . snd + . flip MP.runParser' initState + . flip runStateT initCommentState + . flip runReaderT defaultParserConfig {_antiquoting = AllowAntiquoting} + $ p + where + initState :: State Text Void + initState = + (initialState file (from s)) + { statePosState = + (initialPosState file (from s)) + { pstateSourcePos = SourcePos file (mkPos line) (mkPos col) + } + } diff --git a/src/swarm-lang/Swarm/Language/Parser/Lex.hs b/src/swarm-lang/Swarm/Language/Parser/Lex.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/Lex.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Token lexing and comment preservation for the Swarm language. +module Swarm.Language.Parser.Lex ( + -- * Parsing with source locations + parseLoc, + parseLocG, + + -- * Whitespace + comments + getCommentSituation, + lineComment, + blockComment, + sc, + + -- * Tokens + + -- ** Lexemes + lexeme, + + -- ** Specific token types + symbol, + operator, + reservedWords, + reservedCS, + reserved, + IdentifierType (..), + locIdentifier, + locTmVar, + locTyName, + identifier, + tyVar, + tyName, + tmVar, + textLiteral, + integer, + + -- ** Combinators + braces, + parens, + brackets, +) where + +import Control.Lens (use, view, (%=), (.=)) +import Control.Monad (void) +import Data.Char (isLower, isUpper) +import Data.Containers.ListUtils (nubOrd) +import Data.List.Extra (enumerate) +import Data.Sequence qualified as Seq +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Language.Parser.Core +import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction +import Swarm.Language.Types (baseTyName) +import Swarm.Util (failT, squote) +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L +import Witch (from, into) + +------------------------------------------------------------ +-- Parsing with source locations + +-- | Add 'SrcLoc' to a parser +parseLocG :: Parser a -> Parser (SrcLoc, a) +parseLocG pa = do + start <- getOffset + a <- pa + end <- getOffset + pure (SrcLoc start end, a) + +-- | Add 'SrcLoc' to a 'Term' parser +parseLoc :: Parser Term -> Parser Syntax +parseLoc pterm = uncurry Syntax <$> parseLocG pterm + +------------------------------------------------------------ +-- Whitespace + +-- Approach for preserving comments taken from https://www.reddit.com/r/haskell/comments/ni4gpm/comment/gz0ipmp/ + +-- | If we see a comment starting now, is it the first non-whitespace +-- thing on the current line so far, or were there other +-- non-whitespace tokens previously? +getCommentSituation :: Parser CommentSituation +getCommentSituation = do + fl <- use freshLine + return $ if fl then StandaloneComment else SuffixComment + +-- | Parse a line comment, while appending it out-of-band to the list of +-- comments saved in the custom state. +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) + +-- | 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)) + +-- | Skip spaces and comments. +sc :: Parser () +sc = + -- 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. + skipMany . choice . map hidden $ + [ hspace1 + , eol *> (freshLine .= True) -- If we see a newline, reset freshLine to True. + , lineComment "//" + , blockComment "/*" "*/" + ] + +------------------------------------------------------------ +-- Tokens + +-- | In general, we follow the convention that every token parser +-- assumes no leading whitespace and consumes all trailing +-- whitespace. Concretely, we achieve this by wrapping every token +-- parser using 'lexeme'. +-- +-- Also sets freshLine to False every time we see a non-whitespace +-- token. +lexeme :: Parser a -> Parser a +lexeme p = (freshLine .= False) *> L.lexeme sc p + +-- | A lexeme consisting of a literal string. +symbol :: Text -> Parser Text +symbol s = (freshLine .= False) *> L.symbol sc s + +-- | A lexeme consisting of a specific string, not followed by any other +-- operator character. +operator :: Text -> Parser Text +operator n = (lexeme . try) (string n <* notFollowedBy operatorChar) + +-- | Recognize a single character which is one of the characters used +-- by a built-in operator. +operatorChar :: Parser Text +operatorChar = T.singleton <$> oneOf opChars + where + isOp = \case { ConstMFunc {} -> False; _ -> True } . constMeta + opChars = nubOrd . concatMap (from . syntax) . filter isOp $ map constInfo allConst + +-- | Names of base types built into the language. +baseTypeNames :: [Text] +baseTypeNames = map baseTyName enumerate + +-- | Names of types built into the language. +primitiveTypeNames :: [Text] +primitiveTypeNames = "Cmd" : baseTypeNames + +-- | List of keywords built into the language. +keywords :: [Text] +keywords = T.words "let in def tydef end true false forall require requirements rec" + +-- | List of reserved words that cannot be used as variable names. +reservedWords :: Set Text +reservedWords = + S.fromList $ + map (syntax . constInfo) (filter isUserFunc allConst) + ++ map directionSyntax allDirs + ++ 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 +-- if it fails. +reservedGen :: (Text -> Parser a) -> Text -> Parser () +reservedGen str w = (lexeme . try) $ str w *> notFollowedBy (alphaNumChar <|> char '_') + +-- | Parse a case-sensitive reserved word. +reservedCS :: Text -> Parser () +reservedCS = reservedGen string + +-- | Parse a case-insensitive reserved word. +reserved :: Text -> Parser () +reserved = reservedGen string' + +-- | What kind of identifier are we parsing? +data IdentifierType = IDTyVar | IDTyName | IDTmVar + deriving (Eq, Ord, Show) + +-- | 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") + 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 + +-- | Parse a term variable together with its source location info. +locTmVar :: Parser LocVar +locTmVar = locIdentifier IDTmVar + +-- | Parse a user-defined type name together with its source location +-- info. +locTyName :: Parser LocVar +locTyName = locIdentifier IDTyName + +-- | Parse an identifier, i.e. any non-reserved string containing +-- alphanumeric characters and underscores, not starting with a +-- digit. The Bool indicates whether we are parsing a type variable. +identifier :: IdentifierType -> Parser Var +identifier = fmap lvVar . locIdentifier + +-- | Parse a type variable, which must start with an underscore or +-- lowercase letter and cannot be the lowercase version of a type +-- name. +tyVar :: Parser Var +tyVar = identifier IDTyVar + +-- | Parse a (user-defined) type constructor name, which must start +-- with an uppercase letter. +tyName :: Parser Var +tyName = identifier IDTyName + +-- | Parse a term variable, which can start in any case and just +-- cannot be the same (case-insensitively) as a lowercase reserved +-- word. +tmVar :: Parser Var +tmVar = identifier IDTmVar + +-- | Parse a text literal (including escape sequences) in double quotes. +textLiteral :: Parser Text +textLiteral = into <$> lexeme (char '"' >> manyTill L.charLiteral (char '"')) + +-- | Parse a positive integer literal token, in decimal, binary, +-- octal, or hexadecimal notation. Note that negation is handled as +-- a separate operator. +integer :: Parser Integer +integer = + label "integer literal" $ + lexeme $ do + n <- + string "0b" + *> L.binary + <|> string "0o" + *> L.octal + <|> string "0x" + *> L.hexadecimal + <|> L.decimal + notFollowedBy alphaNumChar + return n + +------------------------------------------------------------ +-- Combinators + +braces :: Parser a -> Parser a +braces = between (symbol "{") (symbol "}") + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") diff --git a/src/swarm-lang/Swarm/Language/Parser/QQ.hs b/src/swarm-lang/Swarm/Language/Parser/QQ.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/QQ.hs @@ -0,0 +1,42 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A quasiquoter for Swarm polytypes. +module Swarm.Language.Parser.QQ (tyQ) 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.Type (parsePolytype) +import Swarm.Language.Parser.Util (fully) +import Swarm.Util (liftText) + +------------------------------------------------------------ +-- Quasiquoters +------------------------------------------------------------ + +-- | A quasiquoter for Swarm polytypes, so we can conveniently write them +-- down using concrete syntax and have them parsed into abstract +-- syntax at compile time. This is used, for example, in writing down +-- the concrete types of constants (see "Swarm.Language.Typecheck"). +tyQ :: QuasiQuoter +tyQ = + QuasiQuoter + { quoteExp = quoteTypeExp + , quotePat = error "quotePat not implemented for polytypes" + , quoteType = error "quoteType not implemented for polytypes" + , quoteDec = error "quoteDec not implemented for polytypes" + } + +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 + dataToExpQ (fmap liftText . cast) parsed diff --git a/src/swarm-lang/Swarm/Language/Parser/Record.hs b/src/swarm-lang/Swarm/Language/Parser/Record.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/Record.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parsing records in the Swarm language. +module Swarm.Language.Parser.Record ( + parseRecord, +) where + +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.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 +-- 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 +-- binding in the record. +parseRecord :: Parser a -> Parser (Map Var a) +parseRecord p = (parseBinding `sepBy` symbol ",") >>= fromListUnique + where + parseBinding = (,) <$> tmVar <*> p + fromListUnique kvs = case findDup (map fst kvs) of + Nothing -> return $ M.fromList kvs + Just x -> failT ["duplicate field name", squote x, "in record literal"] diff --git a/src/swarm-lang/Swarm/Language/Parser/Term.hs b/src/swarm-lang/Swarm/Language/Parser/Term.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/Term.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parser for terms of the Swarm language. +module Swarm.Language.Parser.Term where + +import Control.Lens (view, (^.)) +import Control.Monad (guard, join) +import Control.Monad.Combinators.Expr +import Data.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 Swarm.Language.Parser.Core +import Swarm.Language.Parser.Lex +import Swarm.Language.Parser.Record (parseRecord) +import Swarm.Language.Parser.Type +import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction +import Swarm.Language.Types +import Swarm.Util (failT, findDup) +import Text.Megaparsec hiding (runParser) +import Text.Megaparsec.Char + +-- Imports for doctests (cabal-docspec needs this) + +-- $setup +-- >>> import qualified Data.Map.Strict as M + +-------------------------------------------------- +-- Parser + +parseDirection :: Parser Direction +parseDirection = asum (map alternative allDirs) "direction constant" + where + alternative d = d <$ (reserved . directionSyntax) d + +-- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@) +parseConst :: Parser Const +parseConst = asum (map alternative consts) "built-in user function" + where + consts = filter isUserFunc allConst + alternative c = c <$ reserved (syntax $ 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 +parseTermAtom = do + s1 <- parseTermAtom2 + ps <- many (symbol "." *> parseLocG tmVar) + return $ foldl' (\(Syntax l1 t) (l2, x) -> Syntax (l1 <> l2) (TProj t x)) s1 ps + +-- | Parse an atomic term. +parseTermAtom2 :: Parser Syntax +parseTermAtom2 = + parseLoc + ( TUnit <$ symbol "()" + <|> TConst <$> parseConst + <|> TVar <$> tmVar + <|> TDir <$> parseDirection + <|> 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") + ) + ) + <|> uncurry SRequirements <$> (reserved "requirements" *> match parseTerm) + <|> SLam + <$> (symbol "\\" *> locTmVar) + <*> optional (symbol ":" *> parseType) + <*> (symbol "." *> parseTerm) + <|> sLet LSLet + <$> (reserved "let" *> locTmVar) + <*> 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))) + <|> 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 ",")) + ) + <|> parseLoc (TDelay (TConst Noop) <$ try (symbol "{" *> symbol "}")) + <|> parseLoc (SDelay <$> braces parseTerm) + <|> parseLoc (view antiquoting >>= (guard . (== AllowAntiquoting)) >> parseAntiquotation) + +-- | 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 + +sNoop :: Syntax +sNoop = STerm (TConst Noop) + +-- | Create a polytype from a list of variable binders and a type. +-- Ensure that no binder is repeated, and all type variables in the +-- type are present in the list of binders (/i.e./ the type contains +-- no free type variables). +bindTydef :: [Var] -> Type -> Parser Polytype +bindTydef xs ty + | Just repeated <- findDup xs = + failT ["Duplicate variable on left-hand side of tydef:", repeated] + | not (S.null free) = + failT $ + "Undefined type variable(s) on right-hand side of tydef:" : S.toList free + | otherwise = return $ Forall xs ty + where + free = tyVars ty `S.difference` S.fromList xs + +parseAntiquotation :: Parser Term +parseAntiquotation = + TAntiText <$> (lexeme . try) (symbol "$str:" *> tmVar) + <|> TAntiInt <$> (lexeme . try) (symbol "$int:" *> tmVar) + +-- | Parse a Swarm language term. +parseTerm :: Parser Syntax +parseTerm = sepEndBy1 parseStmt (symbol ";") >>= mkBindChain + +mkBindChain :: [Stmt] -> Parser Syntax +mkBindChain stmts = case last stmts of + Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Return) (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 + mkBind (Binder x t1) t2 = loc (Just x) t1 t2 $ SBind (Just x) Nothing Nothing Nothing t1 t2 + loc mx a b = Syntax $ maybe NoLoc lvSrcLoc mx <> (a ^. sLoc) <> (b ^. sLoc) + +data Stmt + = BareTerm Syntax + | Binder LocVar Syntax + deriving (Show) + +parseStmt :: Parser Stmt +parseStmt = + mkStmt <$> optional (try (locTmVar <* symbol "<-")) <*> parseExpr + +mkStmt :: Maybe LocVar -> Syntax -> Stmt +mkStmt Nothing = BareTerm +mkStmt (Just x) = Binder x + +parseExpr :: Parser Syntax +parseExpr = + parseLoc $ ascribe <$> parseExpr' <*> optional (symbol ":" *> parsePolytype) + where + ascribe :: Syntax -> Maybe Polytype -> Term + ascribe s Nothing = s ^. sTerm + ascribe s (Just ty) = SAnnotate s ty + +parseExpr' :: Parser Syntax +parseExpr' = makeExprParser parseTermAtom table + where + table = snd <$> M.toDescList tableMap + tableMap = + M.unionsWith + (++) + [ M.singleton 9 [InfixL (exprLoc2 $ SApp <$ string "")] + , binOps + , unOps + ] + + -- add location for ExprParser by combining all + exprLoc2 :: Parser (Syntax -> Syntax -> Term) -> Parser (Syntax -> Syntax -> Syntax) + exprLoc2 p = do + (l, f) <- parseLocG p + pure $ \s1 s2 -> Syntax (l <> (s1 ^. sLoc) <> (s2 ^. sLoc)) $ f s1 s2 + +-- | Precedences and parsers of binary operators. +-- +-- >>> M.map length binOps +-- fromList [(0,1),(2,1),(3,1),(4,6),(6,3),(7,2),(8,1)] +binOps :: Map Int [Operator Parser Syntax] +binOps = M.unionsWith (++) $ mapMaybe binOpToTuple allConst + where + binOpToTuple c = do + let ci = constInfo c + ConstMBinOp assoc <- pure (constMeta ci) + let assI = case assoc of + L -> InfixL + N -> InfixN + R -> InfixR + pure $ + M.singleton + (fixity ci) + [assI (mkOp c <$ operator (syntax ci))] + +-- | Precedences and parsers of unary operators (currently only 'Neg'). +-- +-- >>> M.map length unOps +-- fromList [(7,1)] +unOps :: Map Int [Operator Parser Syntax] +unOps = M.unionsWith (++) $ mapMaybe unOpToTuple allConst + where + unOpToTuple c = do + let ci = constInfo c + ConstMUnOp assoc <- pure (constMeta ci) + let assI = case assoc of + P -> Prefix + S -> Postfix + pure $ + M.singleton + (fixity ci) + [assI (exprLoc1 $ SApp (noLoc $ TConst c) <$ operator (syntax ci))] + + -- combine location for ExprParser + exprLoc1 :: Parser (Syntax -> Term) -> Parser (Syntax -> Syntax) + exprLoc1 p = do + (l, f) <- parseLocG p + pure $ \s -> Syntax (l <> s ^. sLoc) $ f s diff --git a/src/swarm-lang/Swarm/Language/Parser/Type.hs b/src/swarm-lang/Swarm/Language/Parser/Type.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/Type.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parsing types in the Swarm language. +module Swarm.Language.Parser.Type ( + parsePolytype, + parseType, + parseTypeMolecule, + parseTypeAtom, + 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.Lex ( + braces, + brackets, + parens, + reserved, + reservedCS, + symbol, + tyName, + tyVar, + ) +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 = + 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 + +-- | Parse a Swarm language (mono)type. +parseType :: Parser Type +parseType = makeExprParser parseTypeMolecule table + where + table = + [ [InfixR ((:*:) <$ symbol "*")] + , [InfixR ((:+:) <$ symbol "+")] + , [InfixR ((:->:) <$ symbol "->")] + ] + +-- | A "type molecule" consists of either a type constructor applied +-- to a chain of type atoms, or just a type atom by itself. We have +-- to separate this out from parseTypeAtom to deal with the left +-- recursion. +parseTypeMolecule :: Parser Type +parseTypeMolecule = + TyConApp <$> parseTyCon <*> many parseTypeAtom + <|> parseTypeAtom + +-- | A "type atom" consists of some atomic type snytax --- type +-- variables, things in brackets of some kind, or a lone type +-- constructor. +parseTypeAtom :: Parser Type +parseTypeAtom = + TyVar <$> tyVar + <|> TyConApp <$> parseTyCon <*> pure [] + <|> TyDelay <$> braces parseType + <|> TyRcd <$> brackets (parseRecord (symbol ":" *> parseType)) + <|> tyRec <$> (reserved "rec" *> tyVar) <*> (symbol "." *> parseType) + <|> parens parseType + +-- | 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" + <|> TCUser <$> tyName + +-- | Close over a recursive type, replacing any bound occurrences +-- of its variable in the body with de Bruijn indices. Note that +-- (1) we don't have to worry about conflicts with type variables +-- bound by a top-level @forall@; since @forall@ must always be at +-- the top level, any @rec@ will necessarily be lexically within the +-- scope of any @forall@ and hence variables bound by @rec@ will +-- shadow any variables bound by a @forall@. For example, @forall +-- a. a -> (rec a. unit + a)@ is a function from an arbitrary type +-- to a recursive natural number. (2) Any @rec@ contained inside +-- this one will have already been closed over when it was parsed, +-- and its bound variables thus replaced by de Bruijn indices, so +-- neither do we have to worry about being shadowed --- any +-- remaining free occurrences of the variable name in question are +-- indeed references to this @rec@ binder. +tyRec :: Var -> Type -> Type +tyRec x = TyRec x . ($ NZ) . foldFix s + where + s :: TypeF (Nat -> Type) -> Nat -> Type + s = \case + TyRecF y ty -> Fix . TyRecF y . ty . NS + TyVarF y + | x == y -> Fix . TyRecVarF + | otherwise -> const (Fix (TyVarF y)) + fty -> \i -> Fix (fmap ($ i) fty) diff --git a/src/swarm-lang/Swarm/Language/Parser/Util.hs b/src/swarm-lang/Swarm/Language/Parser/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Parser/Util.hs @@ -0,0 +1,97 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A few utilities for use in conjunction with the parser. +module Swarm.Language.Parser.Util ( + fully, + fullyMaybe, + showShortError, + showErrorPos, + getLocRange, +) where + +import Data.List.NonEmpty qualified as NE +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Language.Parser.Core (ParserError) +import Text.Megaparsec +import Text.Megaparsec.Pos qualified as Pos +import Witch (from) + +-- | Run a parser "fully", consuming leading whitespace and ensuring +-- that the parser extends all the way to eof. +fully :: (MonadParsec e s f) => f () -> f a -> f a +fully sc p = sc *> p <* eof + +-- | Run a parser "fully", consuming leading whitespace (including the +-- possibility that the input is nothing but whitespace) and +-- ensuring that the parser extends all the way to eof. +fullyMaybe :: (MonadParsec e s f) => f () -> f a -> f (Maybe a) +fullyMaybe sc = fully sc . optional + +-- | A utility for converting a 'ParserError' into a one line message: +-- @: @ +showShortError :: ParserError -> String +showShortError pe = show (line + 1) <> ": " <> from msg + where + ((line, _), _, msg) = showErrorPos pe + +-- | A utility for converting a 'ParserError' into a range and error message. +showErrorPos :: ParserError -> ((Int, Int), (Int, Int), Text) +showErrorPos (ParseErrorBundle errs sourcePS) = (minusOne start, minusOne end, from msg) + where + -- convert megaparsec source pos to starts at 0 + minusOne (x, y) = (x - 1, y - 1) + + -- get the first error position (ps) and line content (str) + err = NE.head errs + offset = case err of + TrivialError x _ _ -> x + FancyError x _ -> x + (str, ps) = reachOffset offset sourcePS + msg = parseErrorTextPretty err + + -- extract the error starting position + start@(line, col) = getLineCol ps + + -- compute the ending position based on the word at starting position + wordlength = case break (== ' ') . drop col <$> str of + Just (word, _) -> length word + 1 + _ -> 0 + end = (line, col + wordlength) + +getLineCol :: PosState a -> (Int, Int) +getLineCol ps = (line, col) + where + line = unPos $ sourceLine $ pstateSourcePos ps + col = unPos $ sourceColumn $ pstateSourcePos ps + +-- | Given a text, convert a range expressed as indices into the +-- text value to a range expressed in terms of (line number, column +-- number) pairs. +getLocRange :: Text -> (Int, Int) -> ((Int, Int), (Int, Int)) +getLocRange code (locStart, locEnd) = (start, end) + where + start = getLocPos locStart + end = getLocPos (dropWhiteSpace locEnd) + + -- remove trailing whitespace that got included by the lexer + dropWhiteSpace offset + | isWhiteSpace offset = dropWhiteSpace (offset - 1) + | otherwise = offset + isWhiteSpace offset = + -- Megaparsec offset needs to be (-1) to start at 0 + T.index code (offset - 1) `elem` [' ', '\n', '\r', '\t'] + + -- using megaparsec offset facility, compute the line/col + getLocPos offset = + let sourcePS = + PosState + { pstateInput = code + , pstateOffset = 0 + , pstateSourcePos = Pos.initialPos "" + , pstateTabWidth = Pos.defaultTabWidth + , pstateLinePrefix = "" + } + (_, ps) = reachOffset offset sourcePS + in getLineCol ps diff --git a/src/swarm-lang/Swarm/Language/Pipeline.hs b/src/swarm-lang/Swarm/Language/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Pipeline.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Some convenient functions for putting together the whole Swarm +-- language processing pipeline: parsing, type checking, capability +-- checking, and elaboration. If you want to simply turn some raw +-- text representing a Swarm program into something useful, this is +-- probably the module you want. +module Swarm.Language.Pipeline ( + -- * Pipeline functions + processTerm, + processParsedTerm, + processTerm', + processParsedTerm', + processTermEither, + + -- * Utilities + extractTCtx, + extractReqCtx, +) where + +import Control.Lens ((^.)) +import Data.Bifunctor (first) +import Data.Text (Text) +import Data.Text qualified as T +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) + +processTermEither :: Text -> Either Text TSyntax +processTermEither t = case processTerm t of + Left err -> Left $ T.unwords ["Could not parse term:", err] + Right Nothing -> Left "Term was only whitespace" + Right (Just pt) -> Right pt + +-- | Given a 'Text' value representing a Swarm program, +-- +-- 1. Parse it (see "Swarm.Language.Parse") +-- 2. Typecheck it (see "Swarm.Language.Typecheck") +-- 3. Elaborate it (see "Swarm.Language.Elaborate") +-- +-- 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 + +-- | Like 'processTerm', but use a term that has already been parsed. +processParsedTerm :: Syntax -> Either ContextualTypeErr TSyntax +processParsedTerm = processParsedTerm' mempty + +-- | Like 'processTerm', but use explicit starting contexts. +processTerm' :: Env -> Text -> Either Text (Maybe TSyntax) +processTerm' e txt = do + mt <- readTerm txt + first (prettyTypeErrText txt) $ traverse (processParsedTerm' e) mt + +-- | Like 'processTerm'', but use a term that has already been parsed. +processParsedTerm' :: Env -> Syntax -> Either ContextualTypeErr TSyntax +processParsedTerm' e t = do + tt <- inferTop (e ^. envTypes) (e ^. envReqs) (e ^. envTydefs) t + return $ elaborate tt + +------------------------------------------------------------ +-- Some utility functions +------------------------------------------------------------ + +-- | Extract a type context from type annotations on definitions +-- contained in a term. Should probably only be used for testing. +extractTCtx :: Syntax' ty -> TCtx +extractTCtx (Syntax' _ t _ _) = extractTCtxTerm t + where + extractTCtxTerm = \case + SLet _ _ (LV _ x) mty _ _ t2 -> maybe id (Ctx.addBinding x) mty (extractTCtx t2) + SBind mx _ mty _ c1 c2 -> + maybe + id + (uncurry Ctx.addBinding) + ((,) . lvVar <$> mx <*> mty) + (extractTCtx c1 <> extractTCtx c2) + SAnnotate t1 _ -> extractTCtx t1 + _ -> mempty + +-- | Extract a requirements context from requirements annotations on +-- definitions contained in a term. Should probably only be used +-- for testing. +extractReqCtx :: Syntax' ty -> ReqCtx +extractReqCtx (Syntax' _ t _ _) = extractReqCtxTerm t + where + extractReqCtxTerm = \case + SLet _ _ (LV _ x) _ mreq _ t2 -> maybe id (Ctx.addBinding x) mreq (extractReqCtx t2) + SBind mx _ _ mreq c1 c2 -> + maybe + id + (uncurry Ctx.addBinding) + ((,) . lvVar <$> mx <*> mreq) + (extractReqCtx c1 <> extractReqCtx c2) + SAnnotate t1 _ -> extractReqCtx t1 + _ -> mempty diff --git a/src/swarm-lang/Swarm/Language/Pipeline/QQ.hs b/src/swarm-lang/Swarm/Language/Pipeline/QQ.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Pipeline/QQ.hs @@ -0,0 +1,60 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A quasiquoter for Swarm terms. +module Swarm.Language.Pipeline.QQ (tmQ) 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.Util (fully) +import Swarm.Language.Pipeline +import Swarm.Language.Pretty +import Swarm.Language.Syntax +import Swarm.Language.Types (Polytype) +import Swarm.Util (failT, liftText) +import Witch (from) + +-- | A quasiquoter for Swarm language terms, so we can conveniently +-- write them down using concrete syntax and have them parsed into +-- abstract syntax at compile time. The quasiquoter actually runs +-- the entire pipeline on them (parsing, typechecking, elaborating), +-- so a quasiquoted Swarm program with a parse error or a type error +-- will fail at Haskell compile time. This is useful for creating +-- system robot programs (for example, see +-- 'Swarm.Game.Step.seedProgram'). +tmQ :: QuasiQuoter +tmQ = + QuasiQuoter + { quoteExp = quoteTermExp + , quotePat = error "quotePat not implemented for terms" + , quoteType = error "quoteType not implemented for terms" + , quoteDec = error "quoteDec not implemented for terms" + } + +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 + case processParsedTerm parsed of + Left err -> failT [prettyTypeErrText (from s) err] + Right ptm -> dataToExpQ ((fmap liftText . cast) `extQ` antiTermExp) ptm + +antiTermExp :: Term' Polytype -> Maybe TH.ExpQ +antiTermExp (TAntiText v) = + Just $ TH.appE (TH.conE (TH.mkName "TText")) (TH.varE (TH.mkName (from v))) +antiTermExp (TAntiInt v) = + Just $ TH.appE (TH.conE (TH.mkName "TInt")) (TH.varE (TH.mkName (from v))) +antiTermExp _ = Nothing + +-- At the moment, only antiquotation of literal text and ints are +-- supported, because that's what we need for the seedProgram. But +-- we can easily add more in the future. diff --git a/src/swarm-lang/Swarm/Language/Pretty.hs b/src/swarm-lang/Swarm/Language/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Pretty.hs @@ -0,0 +1,603 @@ +{-# 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.hs b/src/swarm-lang/Swarm/Language/Requirements.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Requirements.hs @@ -0,0 +1,26 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Requirements are things that are needed in order to successfully +-- build a robot running a certain program. +module Swarm.Language.Requirements ( + -- * Requirements + + -- ** The 'Requirement' type + Requirement (..), + + -- ** The 'Requirements' type and utility functions + Requirements (..), + singleton, + singletonCap, + singletonDev, + singletonInv, + insert, + ReqCtx, + + -- * Requirements analysis + requirements, +) where + +import Swarm.Language.Requirements.Analysis +import Swarm.Language.Requirements.Type diff --git a/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs b/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs @@ -0,0 +1,188 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Analyze a term to discover the requirements for +-- evaluating/executing it. +-- +-- Note, eventually, requirements will be part of types and +-- requirements analysis will just be part of typechecking +-- (https://github.com/swarm-game/swarm/issues/231). +module Swarm.Language.Requirements.Analysis ( + requirements, +) where + +import Control.Algebra (Has, run) +import Control.Carrier.Accum.Strict (execAccum) +import Control.Carrier.Reader (runReader) +import Control.Effect.Accum (Accum, add) +import Control.Effect.Reader (Reader, ask, local) +import Control.Monad (when) +import Data.Fix (Fix (..)) +import Data.Foldable (forM_) +import Data.Map qualified as M +import Swarm.Language.Capability (Capability (..), constCaps) +import Swarm.Language.Context qualified as Ctx +import Swarm.Language.Requirements.Type +import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction (isCardinal) +import Swarm.Language.Types + +-- | Infer the requirements to execute/evaluate a term in a given +-- context. +-- +-- For function application and let-expressions, we assume that the +-- argument (respectively let-bound expression) is used at least +-- once in the body. Doing otherwise would require a much more +-- fine-grained analysis where we differentiate between the +-- capabilities needed to *evaluate* versus *execute* any expression +-- (since e.g. an unused let-binding would still incur the +-- capabilities to *evaluate* it), which does not seem worth it at +-- all. +-- +-- This is all a bit of a hack at the moment, to be honest; see #231 +-- for a description of a more correct approach. +requirements :: TDCtx -> ReqCtx -> Term -> Requirements +requirements tdCtx ctx = + run . execAccum mempty . runReader tdCtx . runReader ctx . (add (singletonCap CPower) *>) . go + where + go :: + ( Has (Accum Requirements) sig m + , Has (Reader ReqCtx) sig m + , Has (Reader TDCtx) sig m + ) => + Term -> + m () + go = \case + -- Some primitive literals that don't require any special + -- capability. + TUnit -> pure () + TDir d -> when (isCardinal d) $ add (singletonCap COrient) + TInt _ -> pure () + TAntiInt _ -> pure () + TText _ -> pure () + TAntiText _ -> pure () + TBool _ -> pure () + TSuspend {} -> pure () + -- It doesn't require any special capability to *inquire* about + -- the requirements of a term. + TRequirements _ _ -> pure () + -- Look up the capabilities required by a function/command + -- 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) + -- 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. + TVar x -> do + reqs <- ask @ReqCtx + forM_ (Ctx.lookup x reqs) add + -- A lambda expression requires the 'CLambda' capability, and + -- also all the capabilities of the body. We assume that the + -- lambda will eventually get applied, at which point it will + -- indeed require the body's capabilities (this is unnecessarily + -- conservative if the lambda is never applied, but such a + -- program could easily be rewritten without the unused + -- lambda). We also don't do anything with the argument: we + -- assume that it is used at least once within the body, and the + -- capabilities required by any argument will be picked up at + -- the application site. Again, this is overly conservative in + -- the case that the argument is unused, but in that case the + -- unused argument could be removed. + -- + -- Note, however, that we do need to *delete* the argument from + -- the context, in case the context already contains a definition + -- with the same name: inside the lambda that definition will be + -- shadowed, so we do not want the name to be associated to any + -- capabilities. + TLam x mty t -> do + 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. + 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 + when r $ add (singletonCap CRecursion) + add (singletonCap CEnv) + mapM_ polytypeRequirements mty + local @ReqCtx (Ctx.delete x) $ go t1 *> go t2 + -- 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 + 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) + local @ReqCtx (Ctx.addBinding x bodyReqs) $ go t2 + -- Using tydef requires CEnv, plus whatever the requirements are + -- for the type itself. + TTydef x ty _ t2 -> do + add (singletonCap CEnv) + polytypeRequirements ty + -- Now check the nested term with the new type definition added + -- to the context. + -- + -- Note, it's not ideal to be creating a TydefInfo from scratch + -- here; ideally we should get it from the kind checker. + -- Eventually we will put that into the third field of TTydef, + -- but it's not there yet at this point. This is really just a + -- 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) + -- We also delete the name in a TBind, if any, while recursing on + -- the RHS. + TBind mx _ _ t1 t2 -> do + go t1 + local @ReqCtx (maybe id Ctx.delete mx) $ go t2 + -- Everything else is straightforward. + TPair t1 t2 -> add (singletonCap CProd) *> go t1 *> go t2 + TDelay t -> go t + TRcd m -> add (singletonCap CRecord) *> forM_ (M.assocs m) (go . expandEq) + where + expandEq (x, Nothing) = TVar x + expandEq (_, Just t) = t + TProj t _ -> add (singletonCap CRecord) *> go t + -- A type ascription doesn't change requirements + TAnnotate t ty -> go t *> polytypeRequirements ty + +polytypeRequirements :: + (Has (Accum Requirements) sig m, Has (Reader TDCtx) sig m) => + Polytype -> + m () +polytypeRequirements (Forall _ ty) = typeRequirements ty + +typeRequirements :: + (Has (Accum Requirements) sig m, Has (Reader TDCtx) sig m) => + Type -> + m () +typeRequirements = go + where + go (Fix tyF) = goF tyF + + goF = \case + TyVarF _ -> pure () + TyConF (TCUser u) tys -> do + mapM_ go tys + ty' <- expandTydef u tys + go ty' + TyConF c tys -> do + case c of + TCSum -> add (singletonCap CSum) + TCProd -> add (singletonCap CProd) + _ -> pure () + mapM_ go tys + TyRcdF m -> mapM_ go m + TyRecF _ ty' -> add (singletonCap CRectype) *> go ty' + TyRecVarF _ -> pure () diff --git a/src/swarm-lang/Swarm/Language/Requirements/Type.hs b/src/swarm-lang/Swarm/Language/Requirements/Type.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Requirements/Type.hs @@ -0,0 +1,113 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A requirement is something that is needed in order to successfully +-- build a robot running a certain program. +module Swarm.Language.Requirements.Type ( + -- * Requirements + + -- ** The 'Requirement' type + Requirement (..), + + -- ** The 'Requirements' type and utility functions + Requirements (..), + singleton, + singletonCap, + singletonDev, + singletonInv, + insert, + ReqCtx, +) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Data (Data) +import Data.Hashable (Hashable) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import GHC.Generics (Generic) +import Swarm.Language.Capability (Capability (..)) +import Swarm.Language.Context (Ctx) + +-- | 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. +data Requirement + = -- | Require a specific capability. This must be fulfilled by + -- equipping an appropriate device. Requiring the same + -- capability multiple times is the same as requiring it once. + ReqCap Capability + | -- | Require a specific device to be equipped. Note that at this + -- point it is only a name, and has not been resolved to an actual + -- 'Swarm.Game.Entity.Entity'. That's because programs have to be type- and + -- capability-checked independent of an 'Swarm.Game.Entity.EntityMap'. The name + -- will be looked up at runtime, when actually executing a 'Swarm.Language.Syntax.Build' + -- or 'Swarm.Language.Syntax.Reprogram' command, and an appropriate exception thrown if + -- a device with the given name does not exist. + -- + -- 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 + -- in the inventory. The same comments apply re: resolving the + -- entity name to an actual 'Swarm.Game.Entity.Entity'. + -- + -- Inventory requirements are additive, that is, say, requiring 5 + -- 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) + +-- | It is tempting to define @Requirements = Set Requirement@, but +-- that would be wrong, since two identical 'ReqInv' should have +-- their counts added rather than simply being deduplicated. +-- +-- Since we will eventually need to deal with the different types of +-- requirements separately, it makes sense to store them separately +-- anyway. +data Requirements = Requirements + { capReqs :: Set Capability + , devReqs :: Set Text + , invReqs :: Map Text Int + } + deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON) + +instance Semigroup Requirements where + Requirements c1 d1 i1 <> Requirements c2 d2 i2 = + Requirements (c1 <> c2) (d1 <> d2) (M.unionWith (+) i1 i2) + +instance Monoid Requirements where + mempty = Requirements S.empty S.empty M.empty + +-- | Create a 'Requirements' set with a single 'Requirement'. +singleton :: Requirement -> Requirements +singleton (ReqCap c) = Requirements (S.singleton c) S.empty M.empty +singleton (ReqDev d) = Requirements S.empty (S.singleton d) M.empty +singleton (ReqInv n e) = Requirements S.empty S.empty (M.singleton e n) + +-- | For convenience, create a 'Requirements' set with a single +-- 'Capability' requirement. +singletonCap :: Capability -> Requirements +singletonCap = singleton . ReqCap + +-- | For convenience, create a 'Requirements' set with a single +-- device requirement. +singletonDev :: Text -> Requirements +singletonDev = singleton . ReqDev + +-- | For convenience, create a 'Requirements' set with a single +-- inventory requirement. +singletonInv :: Int -> Text -> Requirements +singletonInv n e = singleton (ReqInv n e) + +insert :: Requirement -> Requirements -> Requirements +insert = (<>) . singleton + +-- | A requirement context records the requirements for the +-- definitions bound to variables. +type ReqCtx = Ctx Requirements diff --git a/src/swarm-lang/Swarm/Language/Syntax.hs b/src/swarm-lang/Swarm/Language/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Abstract syntax for terms of the Swarm programming language. +module Swarm.Language.Syntax ( + -- * Constants + Const (..), + allConst, + ConstInfo (..), + ConstDoc (..), + ConstMeta (..), + MBinAssoc (..), + MUnAssoc (..), + constInfo, + arity, + isCmd, + isUserFunc, + isOperator, + isBuiltinFunction, + isTangible, + isLong, + + -- * Size limits + maxSniffRange, + maxScoutRange, + maxStrideRange, + maxPathRange, + globalMaxVolume, + + -- * SrcLoc + SrcLoc (..), + srcLocBefore, + noLoc, + + -- * Comments + CommentType (..), + CommentSituation (..), + isStandalone, + Comment (..), + Comments (..), + beforeComments, + afterComments, + + -- * Syntax + Syntax' (..), + sLoc, + sTerm, + sType, + sComments, + Syntax, + TSyntax, + USyntax, + pattern Syntax, + pattern CSyntax, + LocVar (..), + LetSyntax (..), + pattern STerm, + pattern TRequirements, + pattern TPair, + pattern TLam, + pattern TApp, + pattern (:$:), + pattern TLet, + pattern TTydef, + pattern TBind, + pattern TDelay, + pattern TRcd, + pattern TProj, + pattern TAnnotate, + pattern TSuspend, + + -- * Terms + Var, + DelayType (..), + Term' (..), + Term, + TTerm, + UTerm, + mkOp, + mkOp', + unfoldApps, + mkTuple, + unTuple, + + -- * Erasure + erase, + eraseS, + + -- * Term traversal + freeVarsS, + freeVarsT, + freeVarsV, + mapFreeS, + locVarToSyntax', + asTree, + measureAstSize, +) where + +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 +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 new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax/AST.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types represeting 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.Map.Strict (Map) +import Data.Text (Text) +import GHC.Generics (Generic) +import Swarm.Language.Requirements.Type (Requirements) +import Swarm.Language.Syntax.Comments +import Swarm.Language.Syntax.Constants +import Swarm.Language.Syntax.Direction +import Swarm.Language.Syntax.Loc +import Swarm.Language.Types + +------------------------------------------------------------ +-- Syntax: annotation on top of Terms with SrcLoc, comments, + type +------------------------------------------------------------ + +-- | The surface syntax for the language, with location and type annotations. +data Syntax' ty = Syntax' + { _sLoc :: SrcLoc + , _sTerm :: Term' ty + , _sComments :: Comments + , _sType :: ty + } + deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic) + +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. +data LetSyntax = LSLet | LSDef + deriving (Eq, Ord, Show, Bounded, Enum, Generic, Data, ToJSON, FromJSON) + +-- | Terms of the Swarm language. +data Term' ty + = -- | The unit value. + TUnit + | -- | A constant. + TConst Const + | -- | A direction literal. + TDir Direction + | -- | An integer literal. + TInt Integer + | -- | An antiquoted Haskell variable name of type Integer. + TAntiInt Text + | -- | A text literal. + TText Text + | -- | An antiquoted Haskell variable name of type Text. + TAntiText Text + | -- | A Boolean literal. + TBool Bool + | -- | 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. + TRobot Int + | -- | A memory reference. These likewise never show up in surface syntax, + -- but are here to facilitate pretty-printing. + TRef Int + | -- | Require a specific device to be installed. + TRequireDevice Text + | -- | Require a certain number of an entity. + TRequire 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 + -- original term may have been elaborated, e.g. `force` may have been added + -- around some variables, etc.) + SRequirements Text (Syntax' ty) + | -- | A variable. + TVar Var + | -- | A pair. + SPair (Syntax' ty) (Syntax' ty) + | -- | A lambda expression, with or without a type annotation on the + -- binder. + SLam LocVar (Maybe Type) (Syntax' ty) + | -- | Function application. + SApp (Syntax' ty) (Syntax' ty) + | -- | A (recursive) let/def expression, with or without a type + -- 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) + | -- | 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) + | -- | 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 + -- the variable (if any) during type inference. Once type + -- inference is complete, during elaboration we will copy the + -- inferred type into the @Maybe Polytype@ field (since the + -- @Maybe ty@ field will be erased). + -- + -- The @Maybe Polytype@ and @Maybe Requirements@ fields is only + -- for annotating the type of a bind after typechecking; there + -- is no surface syntax that allows directly annotating a bind + -- with either one. + SBind (Maybe LocVar) (Maybe ty) (Maybe Polytype) (Maybe Requirements) (Syntax' ty) (Syntax' ty) + | -- | Delay evaluation of a term, written @{...}@. Swarm is an + -- eager language, but in some cases (e.g. for @if@ statements + -- and recursive bindings) we need to delay evaluation. The + -- counterpart to @{...}@ is @force@, where @force {t} = t@. + -- Note that 'Force' is just a constant, whereas 'SDelay' has to + -- be a special syntactic form so its argument can get special + -- treatment during evaluation. + SDelay (Syntax' ty) + | -- | Record literals @[x1 = e1, x2 = e2, x3, ...]@ Names @x@ + -- without an accompanying definition are sugar for writing + -- @x=x@. + SRcd (Map Var (Maybe (Syntax' ty))) + | -- | Record projection @e.x@ + SProj (Syntax' ty) Var + | -- | Annotate a term with a type + SAnnotate (Syntax' ty) Polytype + | -- | Run the given command, then suspend and wait for a new REPL + -- input. + SSuspend (Syntax' ty) + deriving + ( Eq + , Show + , Functor + , Foldable + , Data + , Generic + , -- | 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 + -- them. Once we have finished solving everything we need to do a + -- final traversal over all the types in the AST to substitute away + -- all the unification variables (and generalize, i.e. stick 'forall' + -- on, as appropriate). See the call to 'mapM' in + -- Swarm.Language.Typecheck.runInfer. + Traversable + ) + +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/CommandMetadata.hs b/src/swarm-lang/Swarm/Language/Syntax/CommandMetadata.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax/CommandMetadata.hs @@ -0,0 +1,43 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Command metadata for documentation +module Swarm.Language.Syntax.CommandMetadata where + +import Data.Aeson (ToJSON) +import GHC.Generics (Generic) + +data SensingType + = RobotSensing + | EntitySensing + | WorldCondition + deriving (Eq, Ord, Enum, Bounded, Show, Generic, ToJSON) + +data QueryType + = -- | empirical knowledge + Sensing SensingType + | -- | The random number generator + PRNG + | -- | a priori knowledge + APriori + deriving (Eq, Ord, Show, Generic, ToJSON) + +data RobotChangeType + = PositionChange + | InventoryChange + | ExistenceChange + | BehaviorChange + deriving (Eq, Ord, Enum, Bounded, Show, Generic, ToJSON) + +data MutationType + = Cosmetic + | LogEmission + | EntityChange + | RobotChange RobotChangeType + deriving (Eq, Ord, Show, Generic, ToJSON) + +data CommandEffect + = Query QueryType + | MetaEffect + | Mutation MutationType + deriving (Eq, Ord, Show, Generic, ToJSON) diff --git a/src/swarm-lang/Swarm/Language/Syntax/Comments.hs b/src/swarm-lang/Swarm/Language/Syntax/Comments.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax/Comments.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types for working with comments in Swarm programming language. +module Swarm.Language.Syntax.Comments ( + CommentType (..), + CommentSituation (..), + isStandalone, + Comment (..), + Comments (..), + beforeComments, + afterComments, +) where + +import Control.Lens (AsEmpty, makeLenses, pattern Empty) +import Data.Aeson qualified as A +import Data.Aeson.Types hiding (Key) +import Data.Data (Data) +import Data.Sequence (Seq) +import Data.Text hiding (filter, length, map) +import GHC.Generics (Generic) +import Swarm.Language.Syntax.Loc + +-- | Line vs block comments. +data CommentType = LineComment | BlockComment + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Data, 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) + +-- | Test whether a comment is a standalone comment or not. +isStandalone :: Comment -> Bool +isStandalone = (== StandaloneComment) . commentSituation + +-- | A comment is retained as some text plus metadata (source +-- location, comment type, + comment situation). While parsing we +-- record all comments out-of-band, for later re-insertion into the +-- AST. +data Comment = Comment + { commentSrcLoc :: SrcLoc + , commentType :: CommentType + , commentSituation :: CommentSituation + , commentText :: Text + } + deriving (Eq, Show, Generic, Data, ToJSON, FromJSON) + +-- | 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) + +makeLenses ''Comments + +instance ToJSON Comments where + toJSON = A.genericToJSON A.defaultOptions + omitField = \case + Empty -> True + _ -> False + +instance FromJSON Comments where + parseJSON = A.genericParseJSON A.defaultOptions + omittedField = Just Empty + +instance Semigroup Comments where + Comments b1 a1 <> Comments b2 a2 = Comments (b1 <> b2) (a1 <> a2) + +instance Monoid Comments where + mempty = Comments mempty mempty + +instance AsEmpty Comments diff --git a/src/swarm-lang/Swarm/Language/Syntax/Constants.hs b/src/swarm-lang/Swarm/Language/Syntax/Constants.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax/Constants.hs @@ -0,0 +1,913 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Module provides Types representing built-in functions and commands. +module Swarm.Language.Syntax.Constants ( + Const (..), + allConst, + ConstInfo (..), + ConstDoc (..), + ConstMeta (..), + MBinAssoc (..), + MUnAssoc (..), + constInfo, + arity, + isCmd, + isUserFunc, + isOperator, + isBuiltinFunction, + isTangible, + isLong, + maxSniffRange, + maxScoutRange, + maxStrideRange, + maxPathRange, + globalMaxVolume, +) where + +import Data.Aeson.Types hiding (Key) +import Data.Data (Data) +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 qualified as T +import GHC.Generics (Generic) +import Swarm.Language.Syntax.CommandMetadata +import Swarm.Util (showT) + +------------------------------------------------------------ +-- Constants +------------------------------------------------------------ + +-- | Constants, representing various built-in functions and commands. +-- +-- IF YOU ADD A NEW CONSTANT, be sure to also update: +-- 1. the 'constInfo' function (below) +-- 2. the capability checker ("Swarm.Language.Capability") +-- 3. the type checker ("Swarm.Language.Typecheck") +-- 4. the runtime ("Swarm.Game.Step") +-- 5. the emacs mode syntax highlighter (@contribs/swarm-mode.el@) +-- +-- GHC will warn you about incomplete pattern matches for the first +-- four, and CI will warn you about the last, so in theory it's not +-- really possible to forget. Note you do not need to update the +-- parser or pretty-printer, since they are auto-generated from +-- 'constInfo'. +data Const + = -- Trivial actions + + -- | Do nothing. This is different than 'Wait' + -- in that it does not take up a time step. + Noop + | -- | Wait for a number of time steps without doing anything. + Wait + | -- | Self-destruct. + Selfdestruct + | -- Basic actions + + -- | Move forward one step. + Move + | -- | Move backward one step. + Backup + | -- | Measure the size of the enclosed volume + Volume + | -- | Describe a path to the destination. + Path + | -- | Push an entity forward one step. + Push + | -- | Move forward multiple steps. + Stride + | -- | Turn in some direction. + Turn + | -- | Grab an item from the current location. + Grab + | -- | Harvest an item from the current location. + Harvest + | -- | Scatter seeds of a plant + Sow + | -- | Ignite a combustible item + Ignite + | -- | Try to place an item at the current location. + Place + | -- | Obtain the relative location of another robot. + Ping + | -- | Give an item to another robot at the current location. + Give + | -- | Equip a device on oneself. + Equip + | -- | Unequip an equipped device, returning to inventory. + Unequip + | -- | Make an item. + Make + | -- | Sense whether we have a certain item. + Has + | -- | Sense whether we have a certain device equipped. + Equipped + | -- | Sense how many of a certain item we have. + Count + | -- | Drill through an entity. + Drill + | -- | Use an entity with another. + Use + | -- | Construct a new robot. + Build + | -- | Deconstruct an old robot. + Salvage + | -- | Reprogram a robot that has executed it's command + -- with a new command + Reprogram + | -- | Emit a message. + Say + | -- | Listen for a message from other robots. + Listen + | -- | Emit a log message. + Log + | -- | View a certain robot. + View + | -- | Set color and what characters are used for display. + Appear + | -- | Create an entity out of thin air. Only + -- available in creative mode. + Create + | -- | Tell a robot to halt. + Halt + | -- Sensing / generation + + -- | Get current time + Time + | -- Detect whether a robot is within line-of-sight in a direction + 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 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 + TagMembers + | -- | Locate the closest instance of a given entity within the rectangle + -- specified by opposite corners, relative to the current location. + Detect + | -- | Count the number of a given entity within the rectangle + -- specified by opposite corners, relative to the current location. + Resonate + | -- | Count the number entities within the rectangle + -- specified by opposite corners, relative to the current location. + Density + | -- | Get the distance to the closest instance of the specified entity. + Sniff + | -- | Get the direction to the closest instance of the specified entity. + Chirp + | -- | Register a location to interrupt a `wait` upon changes + Watch + | -- | Register a (remote) location to interrupt a `wait` upon changes + Surveil + | -- | Get the current heading. + Heading + | -- | See if we can move forward or not. + Blocked + | -- | Scan a nearby cell + Scan + | -- | Upload knowledge to another robot + Upload + | -- | See if a specific entity is here. + Ishere + | -- | Check whether the current cell is empty + Isempty + | -- | Get a reference to oneself + Self + | -- | Get the robot's parent + Parent + | -- | Get a reference to the base + Base + | -- | Meet a nearby robot + Meet + | -- | Meet all nearby robots + MeetAll + | -- | Get the robot's display name + Whoami + | -- | Set the robot's display name + Setname + | -- | Get a uniformly random integer. + Random + | -- Modules + + -- | Run a program loaded from a file. + Run + | -- Language built-ins + + -- | If-expressions. + If + | -- | Left injection. + Inl + | -- | Right injection. + Inr + | -- | Case analysis on a sum type. + Case + | -- | First projection. + Fst + | -- | Second projection. + Snd + | -- | Force a delayed evaluation. + Force + | -- | Return for the cmd monad. + Return + | -- | Try/catch block + Try + | -- | Undefined + Undefined + | -- | User error + Fail + | -- Arithmetic unary operators + + -- | Logical negation. + Not + | -- | Arithmetic negation. + Neg + | -- Comparison operators + + -- | Logical equality comparison + Eq + | -- | Logical inequality comparison + Neq + | -- | Logical lesser-then comparison + Lt + | -- | Logical greater-then comparison + Gt + | -- | Logical lesser-or-equal comparison + Leq + | -- | Logical greater-or-equal comparison + Geq + | -- Arithmetic binary operators + + -- | Logical or. + Or + | -- | Logical and. + And + | -- | Arithmetic addition operator + Add + | -- | Arithmetic subtraction operator + Sub + | -- | Arithmetic multiplication operator + Mul + | -- | Arithmetic division operator + Div + | -- | Arithmetic exponentiation operator + Exp + | -- String operators + + -- | Turn an arbitrary value into a string + Format + | -- | Concatenate string values + Concat + | -- | Count number of characters. + Chars + | -- | Split string into two parts. + Split + | -- | Get the character at an index. + CharAt + | -- | Create a singleton text value with the given character code. + ToChar + | -- Function composition with nice operators + + -- | Application operator - helps to avoid parentheses: + -- @f $ g $ h x = f (g (h x))@ + AppF + | -- Concurrency + + -- | Swap placed entity with one in inventory. Essentially atomic grab and place. + Swap + | -- | When executing @atomic c@, a robot will not be interrupted, + -- that is, no other robots will execute any commands while + -- the robot is executing @c@. + Atomic + | -- | Like @atomic@, but with no restriction on program size. + Instant + | -- Keyboard input + + -- | Create `key` values. + Key + | -- | Install a new keyboard input handler. + InstallKeyHandler + | -- God-like commands that are omnipresent or omniscient. + + -- | Teleport a robot to the given position. + Teleport + | -- | Run a command as if you were another robot. + As + | -- | Find an actor by name. + RobotNamed + | -- | Find an actor by number. + RobotNumbered + | -- | Check if an entity is known. + Knows + deriving (Eq, Ord, Enum, Bounded, Data, Show, Generic, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + +allConst :: [Const] +allConst = enumerate + +data ConstInfo = ConstInfo + { syntax :: Text + , fixity :: Int + , constMeta :: ConstMeta + , constDoc :: ConstDoc + , tangibility :: Tangibility + } + deriving (Eq, Ord, Show) + +data ConstDoc = ConstDoc + { effectInfo :: Set CommandEffect + -- ^ NOTE: The absence of effects implies a "pure computation". + , briefDoc :: Text + , longDoc :: Text + } + deriving (Eq, Ord, Show) + +data ConstMeta + = -- | Function with arity of which some are commands + ConstMFunc + -- | Arity + Int + -- | Is a command? + Bool + | -- | Unary operator with fixity and associativity. + ConstMUnOp MUnAssoc + | -- | Binary operator with fixity and associativity. + ConstMBinOp MBinAssoc + deriving (Eq, Ord, Show) + +-- | The meta type representing associativity of binary operator. +data MBinAssoc + = -- | Left associative binary operator (see 'Control.Monad.Combinators.Expr.InfixL') + L + | -- | Non-associative binary operator (see 'Control.Monad.Combinators.Expr.InfixN') + N + | -- | Right associative binary operator (see 'Control.Monad.Combinators.Expr.InfixR') + R + deriving (Eq, Ord, Show) + +-- | The meta type representing associativity of unary operator. +data MUnAssoc + = -- | Prefix unary operator (see 'Control.Monad.Combinators.Expr.Prefix') + P + | -- | Suffix unary operator (see 'Control.Monad.Combinators.Expr.Suffix') + S + deriving (Eq, Ord, Show) + +-- | Whether a command is tangible or not. Tangible commands have +-- some kind of effect on the external world; at most one tangible +-- command can be executed per tick. Intangible commands are things +-- like sensing commands, or commands that solely modify a robot's +-- internal state; multiple intangible commands may be executed per +-- tick. In addition, tangible commands can have a 'Length' (either +-- 'Short' or 'Long') indicating whether they require only one, or +-- possibly more than one, tick to execute. Long commands are +-- excluded from @atomic@ blocks to avoid freezing the game. +data Tangibility = Intangible | Tangible Length + deriving (Eq, Ord, Show, Read) + +-- | For convenience, @short = Tangible Short@. +short :: Tangibility +short = Tangible Short + +-- | For convenience, @long = Tangible Long@. +long :: Tangibility +long = Tangible Long + +-- | The length of a tangible command. Short commands take exactly +-- one tick to execute. Long commands may require multiple ticks. +data Length = Short | Long + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +-- | The arity of a constant, /i.e./ how many arguments it expects. +-- The runtime system will collect arguments to a constant (see +-- 'Swarm.Language.Value.VCApp') until it has enough, then dispatch +-- the constant's behavior. +arity :: Const -> Int +arity c = case constMeta $ constInfo c of + ConstMUnOp {} -> 1 + ConstMBinOp {} -> 2 + ConstMFunc a _ -> a + +-- | Whether a constant represents a /command/. Constants which are +-- not commands are /functions/ which are interpreted as soon as +-- they are evaluated. Commands, on the other hand, are not +-- interpreted until being /executed/, that is, when meeting an +-- 'FExec' frame. When evaluated, commands simply turn into a +-- 'VCApp'. +isCmd :: Const -> Bool +isCmd c = case constMeta $ constInfo c of + ConstMFunc _ cmd -> cmd + _ -> False + +-- | Function constants user can call with reserved words ('wait',...). +isUserFunc :: Const -> Bool +isUserFunc c = case constMeta $ constInfo c of + ConstMFunc {} -> True + _ -> False + +-- | Whether the constant is an operator. Useful predicate for documentation. +isOperator :: Const -> Bool +isOperator c = case constMeta $ constInfo c of + ConstMUnOp {} -> True + ConstMBinOp {} -> True + ConstMFunc {} -> False + +-- | Whether the constant is a /function/ which is interpreted as soon +-- as it is evaluated, but *not* including operators. +-- +-- Note: This is used for documentation purposes and complements 'isCmd' +-- and 'isOperator' in that exactly one will accept a given constant. +isBuiltinFunction :: Const -> Bool +isBuiltinFunction c = case constMeta $ constInfo c of + ConstMFunc _ cmd -> not cmd + _ -> False + +-- | Whether the constant is a /tangible/ command, that has an +-- external effect on the world. At most one tangible command may be +-- executed per tick. +isTangible :: Const -> Bool +isTangible c = case tangibility (constInfo c) of + Tangible {} -> True + _ -> False + +-- | Whether the constant is a /long/ command, that is, a tangible +-- command which could require multiple ticks to execute. Such +-- commands cannot be allowed in @atomic@ blocks. +isLong :: Const -> Bool +isLong c = case tangibility (constInfo c) of + Tangible Long -> True + _ -> False + +-- | Information about constants used in parsing and pretty printing. +-- +-- It would be more compact to represent the information by testing +-- whether the constants are in certain sets, but using pattern +-- matching gives us warning if we add more constants. +constInfo :: Const -> ConstInfo +constInfo c = case c of + Wait -> + command 0 long $ + shortDoc + (Set.singleton $ Mutation $ RobotChange BehaviorChange) + "Wait for a number of time steps." + Noop -> + command 0 Intangible . doc Set.empty "Do nothing." $ + [ "This is different than `Wait` in that it does not take up a time step." + , "It is useful for commands like if, which requires you to provide both branches." + , "Usually it is automatically inserted where needed, so you do not have to worry about it." + ] + Selfdestruct -> + command 0 short + . doc + (Set.singleton $ Mutation $ RobotChange ExistenceChange) + "Self-destruct a robot." + $ [ "Useful to not clutter the world." + , "This destroys the robot's inventory, so consider `salvage` as an alternative." + ] + Move -> + command 0 short $ + shortDoc + (Set.singleton $ Mutation $ RobotChange PositionChange) + "Move forward one step." + Backup -> + command 0 short $ + shortDoc + (Set.singleton $ Mutation $ RobotChange PositionChange) + "Move backward one step." + Volume -> + command 1 short + . doc + (Set.singleton $ Query $ Sensing EntitySensing) + "Measure enclosed volume." + $ [ "Specify the max volume to check for." + , "Returns either the measured volume bounded by \"unwalkable\" cells," + , "or `unit` if the search exceeds the limit." + , T.unwords + [ "There is also an implicit hard-coded maximum of" + , T.pack $ show globalMaxVolume + ] + ] + Path -> + command 2 short + . doc + (Set.singleton $ Query $ Sensing EntitySensing) + "Obtain shortest path to the destination." + $ [ "Optionally supply a distance limit as the first argument." + , "Supply either a location (`inL`) or an entity (`inR`) as the second argument." + , "If a path exists, returns the immediate direction to proceed along and the remaining distance." + ] + Push -> + command 1 short + . doc + (Set.fromList [Mutation EntityChange, Mutation $ RobotChange PositionChange]) + "Push an entity forward one step." + $ [ "Both entity and robot moves forward one step." + , "Destination must not contain an entity." + ] + Stride -> + command 1 short + . doc + (Set.singleton $ Mutation $ RobotChange PositionChange) + "Move forward multiple steps." + $ [ T.unwords ["Has a max range of", T.pack $ show maxStrideRange, "units."] + ] + Turn -> + command 1 short $ + shortDoc + (Set.singleton $ Mutation $ RobotChange PositionChange) + "Turn in some direction." + Grab -> + command 0 short $ + shortDoc + (Set.fromList [Mutation EntityChange, Mutation $ RobotChange InventoryChange]) + "Grab an item from the current location." + Harvest -> + command 0 short . doc (Set.fromList [Mutation EntityChange, Mutation $ RobotChange InventoryChange]) "Harvest an item from the current location." $ + [ "Leaves behind a growing seed if the harvested item is growable." + , "Otherwise it works exactly like `grab`." + ] + Sow -> + command 1 short . doc (Set.singleton $ Mutation EntityChange) "Plant a seed at current location" $ + [ "The entity this matures into may be something else." + ] + Ignite -> + command 1 short + . doc + (Set.singleton $ Mutation EntityChange) + "Ignite a combustible item in the specified direction." + $ [ "Combustion persists for a random duration and may spread." + ] + Place -> + command 1 short + . doc + (Set.fromList [Mutation EntityChange, Mutation $ RobotChange InventoryChange]) + "Place an item at the current location." + $ ["The current location has to be empty for this to work."] + Ping -> + command 1 short + . doc + (Set.singleton $ Query $ Sensing RobotSensing) + "Obtain the relative location of another robot." + $ [ "The other robot must be within transmission range, accounting for antennas installed on either end, and the invoking robot must be oriented in a cardinal direction." + , "The location (x, y) is given relative to one's current orientation:" + , "Positive x value is to the right, negative left. Likewise, positive y value is forward, negative back." + ] + Give -> + command 2 short $ + shortDoc + (Set.singleton $ Mutation $ RobotChange InventoryChange) + "Give an item to another actor nearby." + Equip -> + command 1 short $ + shortDoc + (Set.fromList [Mutation $ RobotChange InventoryChange, Mutation $ RobotChange BehaviorChange]) + "Equip a device on oneself." + Unequip -> + command 1 short $ + shortDoc + (Set.fromList [Mutation $ RobotChange InventoryChange, Mutation $ RobotChange BehaviorChange]) + "Unequip an equipped device, returning to inventory." + Make -> + command 1 long $ + shortDoc + (Set.singleton $ Mutation $ RobotChange InventoryChange) + "Make an item using a recipe." + Has -> + command 1 Intangible $ + shortDoc + (Set.singleton $ Query $ Sensing RobotSensing) + "Sense whether the robot has a given item in its inventory." + Equipped -> + command 1 Intangible $ + shortDoc + (Set.singleton $ Query $ Sensing RobotSensing) + "Sense whether the robot has a specific device equipped." + Count -> + command 1 Intangible $ + shortDoc + (Set.singleton $ Query $ Sensing RobotSensing) + "Get the count of a given item in a robot's inventory." + Reprogram -> + command 2 long + . doc + (Set.singleton $ Mutation $ RobotChange BehaviorChange) + "Reprogram another robot with a new command." + $ ["The other robot has to be nearby and idle."] + Drill -> + command 1 long + . doc + (Set.fromList [Mutation EntityChange, Mutation $ RobotChange InventoryChange]) + "Drill through an entity." + $ [ "Usually you want to `drill forward` when exploring to clear out obstacles." + , "When you have found a source to drill, you can stand on it and `drill down`." + , "See what recipes with drill you have available." + , "The `drill` command may return the name of an entity added to your inventory." + ] + 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." + ] + Build -> + command 1 long . doc (Set.singleton $ Mutation $ RobotChange ExistenceChange) "Construct a new robot." $ + [ "You can specify a command for the robot to execute." + , "If the command requires devices they will be taken from your inventory and " + <> "equipped on the new robot." + ] + Salvage -> + command 0 long . doc (Set.singleton $ Mutation $ RobotChange ExistenceChange) "Deconstruct an old robot." $ + ["Salvaging a robot will give you its inventory, equipped devices and log."] + Say -> + command 1 short . doc (Set.singleton $ Mutation $ RobotChange BehaviorChange) "Emit a message." $ + [ "The message will be in the robot's log (if it has one) and the global log." + , "You can view the message that would be picked by `listen` from the global log " + <> "in the messages panel, along with your own messages and logs." + , "This means that to see messages from other robots you have to be able to listen for them, " + <> "so once you have a listening device equipped messages will be added to your log." + , "In creative mode, there is of course no such limitation." + ] + Listen -> + command 1 long . doc (Set.singleton $ Query $ Sensing RobotSensing) "Listen for a message from other actors." $ + [ "It will take the first message said by the closest actor." + , "You do not need to actively listen for the message to be logged though, " + <> "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." + 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." + ] + Appear -> + command 2 short . doc (Set.singleton $ Mutation Cosmetic) "Set how the robot is displayed." $ + [ "You can either specify one character or five (one for each direction: down, north, east, south, west)." + , "The default is \"X^>v<\"." + , "The second argument is for optionally setting a display attribute (i.e. color)." + ] + Create -> + command 1 short . doc (Set.fromList [Mutation EntityChange, Mutation $ RobotChange InventoryChange]) "Create an item out of thin air." $ + ["Only available in creative mode."] + Halt -> command 1 short $ shortDoc (Set.singleton $ Mutation $ RobotChange BehaviorChange) "Tell a robot to halt." + Time -> + command 0 Intangible $ + shortDoc + (Set.singleton $ Query $ Sensing WorldCondition) + "Get the current time." + Scout -> + command 1 short . doc (Set.singleton $ Query $ Sensing RobotSensing) "Detect whether a robot is within line-of-sight in a direction." $ + [ "Perception is blocked by 'Opaque' entities." + , T.unwords ["Has a max range of", T.pack $ show maxScoutRange, "units."] + ] + Whereami -> + command 0 Intangible $ + 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." + ] + 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" $ + [ "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." + ] + Detect -> + command 2 Intangible . doc (Set.singleton $ Query $ Sensing EntitySensing) "Detect an entity within a rectangle." $ + ["Locate the closest instance of a given entity within the rectangle specified by opposite corners, relative to the current location."] + Resonate -> + command 2 Intangible . doc (Set.singleton $ Query $ Sensing EntitySensing) "Count specific entities within a rectangle." $ + [ "Applies a strong magnetic field over a given area and stimulates the matter within, generating a non-directional radio signal. A receiver tuned to the resonant frequency of the target entity is able to measure its quantity." + , "Counts the entities within the rectangle specified by opposite corners, relative to the current location." + ] + Density -> + command 1 Intangible . doc (Set.singleton $ Query $ Sensing EntitySensing) "Count all entities within a rectangle." $ + [ "Applies a strong magnetic field over a given area and stimulates the matter within, generating a non-directional radio signal. A receiver measured the signal intensity to measure the quantity." + , "Counts the entities within the rectangle specified by opposite corners, relative to the current location." + ] + Sniff -> + command 1 short . doc (Set.singleton $ Query $ Sensing EntitySensing) "Determine distance to entity." $ + [ "Measures concentration of airborne particles to infer distance to a certain kind of entity." + , "If none is detected, returns (-1)." + , T.unwords ["Has a max range of", T.pack $ show maxSniffRange, "units."] + ] + Chirp -> + command 1 short . doc (Set.singleton $ Query $ Sensing EntitySensing) "Determine direction to entity." $ + [ "Uses a directional sonic emitter and microphone tuned to the acoustic signature of a specific entity to determine its direction." + , "Returns 'down' if out of range or the direction is indeterminate." + , "Provides absolute directions if \"compass\" equipped, relative directions otherwise." + , T.unwords ["Has a max range of", T.pack $ show maxSniffRange, "units."] + ] + Watch -> + command 1 short . doc (Set.singleton $ Query $ Sensing EntitySensing) "Interrupt `wait` upon location changes." $ + [ "Place seismic detectors to alert upon entity changes to the specified location." + , "Supply a direction, as with the `scan` command, to specify a nearby location." + , "Can be invoked more than once until the next `wait` command, at which time the only the registered locations that are currently nearby are preserved." + , "Any change to entities at the monitored locations will cause the robot to wake up before the `wait` timeout." + ] + Surveil -> + command 1 Intangible $ + doc + (Set.singleton $ Query $ Sensing EntitySensing) + "Interrupt `wait` upon (remote) location changes." + [ "Like `watch`, but instantaneous and with no restriction on distance." + , "Supply absolute coordinates." + ] + Heading -> command 0 Intangible $ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Get the current heading." + Blocked -> command 0 Intangible $ shortDoc (Set.singleton $ Query $ Sensing EntitySensing) "See if the robot can move forward." + Scan -> + command 1 Intangible . doc (Set.singleton $ Query $ Sensing EntitySensing) "Scan a nearby location for entities." $ + [ "Adds the entity (not actor) to your inventory with count 0 if there is any." + , "If you can use sum types, you can also inspect the result directly." + ] + Upload -> command 1 short $ shortDoc (Set.singleton $ Mutation $ RobotChange BehaviorChange) "Upload a robot's known entities and log to another robot." + Ishere -> command 1 Intangible $ shortDoc (Set.singleton $ Query $ Sensing EntitySensing) "See if a specific entity is in the current location." + Isempty -> + command 0 Intangible . doc (Set.singleton $ Query $ Sensing EntitySensing) "Check if the current location is empty." $ + [ "Detects whether or not the current location contains an entity." + , "Does not detect robots or other actors." + ] + Self -> function 0 $ shortDoc (Set.singleton $ Query APriori) "Get a reference to the current robot." + Parent -> function 0 $ shortDoc (Set.singleton $ Query APriori) "Get a reference to the robot's parent." + Base -> function 0 $ shortDoc (Set.singleton $ Query APriori) "Get a reference to the base." + Meet -> command 0 Intangible $ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Get a reference to a nearby actor, if there is one." + MeetAll -> command 0 Intangible $ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Return a list of all the nearby actors." + Whoami -> command 0 Intangible $ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Get the robot's display name." + Setname -> command 1 short $ shortDoc (Set.singleton $ Mutation $ RobotChange BehaviorChange) "Set the robot's display name." + Random -> + 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`." + 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." + If -> + function 3 . doc Set.empty "If-Then-Else function." $ + ["If the bool predicate is true then evaluate the first expression, otherwise the second."] + 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." + 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." + Add -> binaryOp "+" 6 L $ shortDoc Set.empty "Add the given integer values." + And -> binaryOp "&&" 3 R $ shortDoc Set.empty "Logical and (true if both values are true)." + Or -> binaryOp "||" 2 R $ shortDoc Set.empty "Logical or (true if either value is true)." + Sub -> binaryOp "-" 6 L $ shortDoc Set.empty "Subtract the given integer values." + Mul -> binaryOp "*" 7 L $ shortDoc Set.empty "Multiply the given integer values." + Div -> binaryOp "/" 7 L $ shortDoc Set.empty "Divide the left integer value by the right one, rounding down." + Exp -> binaryOp "^" 8 R $ shortDoc Set.empty "Raise the left integer value to the power of the right one." + Eq -> binaryOp "==" 4 N $ shortDoc Set.empty "Check that the left value is equal to the right one." + Neq -> binaryOp "!=" 4 N $ shortDoc Set.empty "Check that the left value is not equal to the right one." + Lt -> binaryOp "<" 4 N $ shortDoc Set.empty "Check that the left value is lesser than the right one." + Gt -> binaryOp ">" 4 N $ shortDoc Set.empty "Check that the left value is greater than the right one." + 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." + 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 -> + function 2 . doc Set.empty "Split the text into two at given position." $ + [ "To be more specific, the following holds for all `text` values `s1` and `s2`:" + , "`(s1,s2) == split (chars s1) (s1 ++ s2)`" + , "So split can be used to undo concatenation if you know the length of the original string." + ] + CharAt -> + function 2 . doc Set.empty "Get the character at a given index." $ + [ "Gets the character (as an `int` representing a Unicode codepoint) at a specific index in a `text` value. Valid indices are 0 through `chars t - 1`." + , "Throws an exception if given an out-of-bounds index." + ] + ToChar -> + function 1 . doc Set.empty "Create a singleton `text` value from the given character code." $ + [ "That is, `chars (toChar c) == 1` and `charAt 0 (toChar c) == c`." + ] + 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:" + , "`f $ g $ h x = f (g (h x))`" + ] + Swap -> + command 1 short . doc (Set.fromList [Mutation EntityChange, Mutation $ RobotChange InventoryChange]) "Swap placed entity with one in inventory." $ + [ "This essentially works like atomic grab and place." + , "Use this to avoid race conditions where more robots grab, scan or place in one location." + ] + Atomic -> + command 1 Intangible . doc (Set.singleton MetaEffect) "Execute a block of commands atomically." $ + [ "When executing `atomic c`, a robot will not be interrupted, that is, no other robots will execute any commands while the robot is executing @c@." + ] + Instant -> + command 1 Intangible . doc (Set.singleton MetaEffect) "Execute a block of commands instantly." $ + [ "Like `atomic`, but with no restriction on program size." + ] + Key -> + function 1 . doc Set.empty "Create a key value from a text description." $ + [ "The key description can optionally start with modifiers like 'C-', 'M-', 'A-', or 'S-', followed by either a regular key, or a special key name like 'Down' or 'End'" + , "For example, 'M-C-x', 'Down', or 'S-4'." + , "Which key combinations are actually possible to type may vary by keyboard and terminal program." + ] + InstallKeyHandler -> + command 2 Intangible . doc (Set.singleton $ Mutation $ RobotChange BehaviorChange) "Install a keyboard input handler." $ + [ "The first argument is a hint line that will be displayed when the input handler is active." + , "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." + 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." + Knows -> command 1 Intangible $ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Check if the robot knows about an entity." + where + doc e b ls = ConstDoc e b (T.unlines ls) + shortDoc e b = ConstDoc e b "" + unaryOp s p side d = + ConstInfo + { syntax = s + , fixity = p + , constMeta = ConstMUnOp side + , constDoc = d + , tangibility = Intangible + } + binaryOp s p side d = + ConstInfo + { syntax = s + , fixity = p + , constMeta = ConstMBinOp side + , constDoc = d + , tangibility = Intangible + } + command a f d = + ConstInfo + { syntax = lowShow c + , fixity = 11 + , constMeta = ConstMFunc a True + , constDoc = d + , tangibility = f + } + function a d = + ConstInfo + { syntax = lowShow c + , fixity = 11 + , constMeta = ConstMFunc a False + , constDoc = d + , tangibility = Intangible + } + + lowShow :: Show a => a -> Text + lowShow = toLower . showT + +-- | Maximum perception distance for +-- 'Chirp' and 'Sniff' commands +maxSniffRange :: Int32 +maxSniffRange = 256 + +maxScoutRange :: Int +maxScoutRange = 64 + +maxStrideRange :: Int +maxStrideRange = 64 + +maxPathRange :: Integer +maxPathRange = 128 + +-- | Checked upon invocation of the command, +-- before flood fill computation, to ensure +-- the search has a reasonable bound. +-- +-- The user is warned in the failure message +-- that there exists a global limit. +globalMaxVolume :: Integer +globalMaxVolume = 64 * 64 diff --git a/src/swarm-lang/Swarm/Language/Syntax/Loc.hs b/src/swarm-lang/Swarm/Language/Syntax/Loc.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax/Loc.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types for working with locations of something in source code. +module Swarm.Language.Syntax.Loc ( + SrcLoc (..), + LocVar (..), + srcLocBefore, +) where + +import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) +import Data.Data (Data) +import GHC.Generics (Generic) +import Swarm.Language.Context (Var) +import Swarm.Util.JSON (optionsUntagged) + +------------------------------------------------------------ +-- SrcLoc +------------------------------------------------------------ + +-- | The location of something in the textual source code (recorded as +-- an interval measured in terms of indices into the input stream). +data SrcLoc + = NoLoc + | -- | Half-open interval from start (inclusive) to end (exclusive) + SrcLoc Int Int + deriving (Eq, Ord, Show, Data, Generic) + +instance ToJSON SrcLoc where + toJSON = genericToJSON optionsUntagged + +instance FromJSON SrcLoc where + parseJSON = genericParseJSON optionsUntagged + +-- | @x <> y@ is the smallest 'SrcLoc' that subsumes both @x@ and @y@. +instance Semigroup SrcLoc where + NoLoc <> l = l + l <> NoLoc = l + SrcLoc s1 e1 <> SrcLoc s2 e2 = SrcLoc (min s1 s2) (max e1 e2) + +-- | @mempty@ is a special value which means we have no location +-- information. +instance Monoid SrcLoc where + mempty = NoLoc + +-- | Check whether one @SrcLoc@ starts at or 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 + +-- | 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) diff --git a/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs b/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Pattern synonyms for untyped terms +module Swarm.Language.Syntax.Pattern ( + Syntax, + TSyntax, + USyntax, + sLoc, + sTerm, + sType, + sComments, + pattern Syntax, + pattern CSyntax, + pattern STerm, + pattern TRequirements, + pattern TPair, + pattern TLam, + pattern TApp, + pattern (:$:), + pattern TLet, + pattern TTydef, + pattern TBind, + pattern TDelay, + pattern TRcd, + pattern TProj, + pattern TAnnotate, + pattern TSuspend, + Term, + TTerm, + UTerm, + noLoc, +) where + +import Control.Lens (makeLenses, pattern Empty) +import Data.Map.Strict (Map) +import Data.Text hiding (filter, length, map) +import Swarm.Language.Requirements.Type (Requirements) +import Swarm.Language.Syntax.AST +import Swarm.Language.Syntax.Comments +import Swarm.Language.Syntax.Loc +import Swarm.Language.Types + +-- | Syntax without type annotations. +type Syntax = Syntax' () + +type Term = Term' () + +type TSyntax = Syntax' Polytype +type TTerm = Term' Polytype + +type USyntax = Syntax' UType +type UTerm = Term' UType + +-- | Raw parsed syntax, without comments or type annotations. +pattern Syntax :: SrcLoc -> Term -> Syntax +pattern Syntax l t = Syntax' l t Empty () + +{-# COMPLETE Syntax #-} + +-- | Untyped syntax with assocated comments. +pattern CSyntax :: SrcLoc -> Term -> Comments -> Syntax +pattern CSyntax l t cs = Syntax' l t cs () + +{-# COMPLETE CSyntax #-} + +makeLenses ''Syntax' + +noLoc :: Term -> Syntax +noLoc = Syntax mempty + +-- | Match an untyped term without annotations. +pattern STerm :: Term -> Syntax +pattern STerm t <- + CSyntax _ t _ + where + STerm t = Syntax mempty t + +pattern TRequirements :: Text -> Term -> Term +pattern TRequirements x t = SRequirements x (STerm t) + +-- | Match a TPair without annotations. +pattern TPair :: Term -> Term -> Term +pattern TPair t1 t2 = SPair (STerm t1) (STerm t2) + +-- | Match a TLam without annotations. +pattern TLam :: Var -> Maybe Type -> Term -> Term +pattern TLam v ty t <- SLam (lvVar -> v) ty (STerm t) + where + TLam v ty t = SLam (LV NoLoc v) ty (STerm t) + +-- | Match a TApp without annotations. +pattern TApp :: Term -> Term -> Term +pattern TApp t1 t2 = SApp (STerm t1) (STerm t2) + +infixl 0 :$: + +-- | Convenient infix pattern synonym for application. +pattern (:$:) :: Term -> Syntax -> Term +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) + where + TLet ls r v mty mreq t1 t2 = SLet ls r (LV NoLoc v) mty mreq (STerm t1) (STerm t2) + +-- | Match a STydef without annotations. +pattern TTydef :: Var -> 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) + +-- | Match a TBind without annotations. +pattern TBind :: Maybe Var -> Maybe Polytype -> Maybe Requirements -> Term -> Term -> Term +pattern TBind mv mty mreq t1 t2 <- SBind (fmap lvVar -> mv) _ mty mreq (STerm t1) (STerm t2) + where + TBind mv mty mreq t1 t2 = SBind (LV NoLoc <$> mv) Nothing mty mreq (STerm t1) (STerm t2) + +-- | Match a TDelay without annotations. +pattern TDelay :: Term -> Term +pattern TDelay t = SDelay (STerm t) + +-- | Match a TRcd without annotations. +pattern TRcd :: Map Var (Maybe Term) -> Term +pattern TRcd m <- SRcd ((fmap . fmap) _sTerm -> m) + where + TRcd m = SRcd ((fmap . fmap) STerm m) + +pattern TProj :: Term -> Var -> Term +pattern TProj t x = SProj (STerm t) x + +-- | Match a TAnnotate without annotations. +pattern TAnnotate :: Term -> Polytype -> Term +pattern TAnnotate t pt = SAnnotate (STerm t) pt + +-- | Match a TSuspend without annotations. +pattern TSuspend :: Term -> Term +pattern TSuspend t = SSuspend (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 #-} diff --git a/src/swarm-lang/Swarm/Language/Syntax/Util.hs b/src/swarm-lang/Swarm/Language/Syntax/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Syntax/Util.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Helper functions for working with @Terms@ and @Syntax@ +module Swarm.Language.Syntax.Util ( + mkOp, + mkOp', + unfoldApps, + mkTuple, + unTuple, + + -- * Erasure + erase, + eraseS, + + -- * Term traversal + freeVarsS, + freeVarsT, + freeVarsV, + mapFreeS, + locVarToSyntax', + asTree, + measureAstSize, +) where + +import Control.Lens (Traversal', para, universe, (%~), (^.), pattern Empty) +import Control.Monad (void) +import Data.Data (Data) +import Data.List.NonEmpty (NonEmpty) +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 + +-- Setup for doctests + +-- $setup +-- >>> import Control.Lens ((^.)) +-- >>> import Swarm.Language.Syntax.Constants +-- >>> import Swarm.Language.Syntax.Loc +-- >>> import Swarm.Language.Syntax.Pattern +-- >>> import Swarm.Language.Syntax.AST + +-- | 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 + 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 + +-- | Make an infix operation, discarding any location information +mkOp' :: Const -> Term -> Term -> Term +mkOp' c t1 = TApp (TApp (TConst c) t1) + +-- | Turn function application chain into a list. +-- +-- >>> syntaxWrap f = fmap (^. sTerm) . f . Syntax NoLoc +-- >>> syntaxWrap unfoldApps (mkOp' Mul (TInt 1) (TInt 2)) -- 1 * 2 +-- TConst Mul :| [TInt 1,TInt 2] +unfoldApps :: Syntax' ty -> NonEmpty (Syntax' ty) +unfoldApps trm = NonEmpty.reverse . flip NonEmpty.unfoldr trm $ \case + 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) + +-- | Decompose a nested tuple into a list of components. +unTuple :: Syntax' ty -> [Syntax' ty] +unTuple = \case + Syntax' _ (SPair s1 s2) _ _ -> s1 : unTuple s2 + s -> [s] + +------------------------------------------------------------ +-- Type erasure +------------------------------------------------------------ + +-- | Erase the type annotations from a 'Syntax' or 'Term' tree. +erase :: Functor t => t ty -> t () +erase = void + +-- | Erase all annotations from a 'Syntax' node, turning it into a +-- bare 'Term'. +eraseS :: Syntax' ty -> Term +eraseS (Syntax' _ t _ _) = erase t + +------------------------------------------------------------ +-- Free variable traversals +------------------------------------------------------------ + +-- | Traversal over those subterms of a term which represent free +-- variables. The S suffix indicates that it is a `Traversal' over +-- the `Syntax` nodes (which contain type and source location info) +-- containing free variables inside a larger `Syntax` value. Note +-- that if you want to get the list of all `Syntax` nodes +-- representing free variables, you can do so via @'toListOf' +-- 'freeVarsS'@. +freeVarsS :: forall ty. Traversal' (Syntax' ty) (Syntax' ty) +freeVarsS f = go S.empty + where + -- go :: Applicative f => Set Var -> Syntax' ty -> f (Syntax' ty) + go bound s@(Syntax' l t ty cmts) = case t of + TUnit -> pure s + TConst {} -> pure s + TDir {} -> pure s + TInt {} -> pure s + TAntiInt {} -> pure s + TText {} -> pure s + TAntiText {} -> pure s + TBool {} -> pure s + TRobot {} -> pure s + TRef {} -> pure s + TRequireDevice {} -> pure s + TRequire {} -> 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 -> + let bound' = S.insert (lvVar x) bound + in rewrap $ SLet ls r x xty 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 + SDelay s1 -> rewrap $ SDelay <$> go bound s1 + SRcd m -> rewrap $ SRcd <$> (traverse . traverse) (go bound) m + 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 + where + rewrap s' = Syntax' l <$> s' <*> pure ty <*> pure cmts + +-- | Like 'freeVarsS', but traverse over the 'Term's containing free +-- variables. More direct if you don't need to know the types or +-- source locations of the variables. Note that if you want to get +-- the list of all `Term`s representing free variables, you can do +-- so via @'toListOf' 'freeVarsT'@. +freeVarsT :: forall ty. Traversal' (Syntax' ty) (Term' ty) +freeVarsT = freeVarsS . sTerm + +-- | Traversal over the free variables of a term. Like 'freeVarsS' +-- and 'freeVarsT', but traverse over the variable names themselves. +-- Note that if you want to get the set of all free variable names, +-- you can do so via @'Data.Set.Lens.setOf' 'freeVarsV'@. +freeVarsV :: Traversal' (Syntax' ty) Var +freeVarsV = freeVarsT . (\f -> \case TVar x -> TVar <$> f x; t -> pure t) + +-- | Apply a function to all free occurrences of a particular +-- variable. +mapFreeS :: Var -> (Syntax' ty -> Syntax' ty) -> Syntax' ty -> Syntax' ty +mapFreeS x f = freeVarsS %~ (\t -> case t ^. sTerm of TVar y | y == x -> f t; _ -> t) + +-- | Transform the AST into a Tree datatype. Useful for +-- pretty-printing (e.g. via "Data.Tree.drawTree"). +asTree :: Data a => Syntax' a -> Tree (Syntax' a) +asTree = para Node + +-- | Each constructor is a assigned a value of 1, plus +-- any recursive syntax it entails. +measureAstSize :: Data a => Syntax' a -> Int +measureAstSize = length . filter (not . isNoop) . universe + +-- | Don't count "noop" nodes towards the code size. They are usually +-- inserted automatically, either in @{}@ or after a bare @def@. +isNoop :: Syntax' a -> Bool +isNoop = \case + Syntax' _ (TConst Noop) _ _ -> True + _ -> False + +locVarToSyntax' :: LocVar -> ty -> Syntax' ty +locVarToSyntax' (LV s v) = Syntax' s (TVar v) Empty diff --git a/src/swarm-lang/Swarm/Language/Text/Markdown.hs b/src/swarm-lang/Swarm/Language/Text/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Text/Markdown.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Simple Markdown AST and related utilities. +-- +-- Parameterising 'Document' with the type of +-- inline code and code blocks allows us to +-- inspect and validate Swarm code in descriptions. +-- +-- See 'Swarm.TUI.View.Util.drawMarkdown' for +-- rendering the descriptions as brick widgets. +module Swarm.Language.Text.Markdown ( + -- ** Markdown document + Document (..), + Paragraph (..), + Node (..), + TxtAttr (..), + fromTextM, + fromText, + docToText, + docToMark, + + -- ** Token stream + StreamNode' (..), + StreamNode, + ToStream (..), + toText, + + -- ** Utilities + findCode, + chunksOf, +) where + +import Commonmark qualified as Mark +import Commonmark.Extensions qualified as Mark (rawAttributeSpec) +import Control.Applicative ((<|>)) +import Control.Arrow (left) +import Control.Lens ((%~), (&), _head, _last) +import Data.Char (isSpace) +import Data.Functor.Identity (Identity (..)) +import Data.List.Split (chop) +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Tuple.Extra (both, first) +import Data.Vector (toList) +import Data.Yaml +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) + +-- | The top-level markdown document. +newtype Document c = Document {paragraphs :: [Paragraph c]} + deriving (Eq, Show, Functor, Foldable, Traversable) + deriving (Semigroup, Monoid) via [Paragraph c] + +-- | Markdown paragraphs that contain inline leaf nodes. +-- +-- The idea is that paragraphs do not have line breaks, +-- and so the inline elements follow each other. +-- In particular inline code can be followed by text without +-- space between them (e.g. @\`logger\`s@). +newtype Paragraph c = Paragraph {nodes :: [Node c]} + deriving (Eq, Show, Functor, Foldable, Traversable) + deriving (Semigroup, Monoid) via [Node c] + +mapP :: (Node c -> Node c) -> Paragraph c -> Paragraph c +mapP f (Paragraph ns) = Paragraph (map f ns) + +pureP :: Node c -> Paragraph c +pureP = Paragraph . (: []) + +-- | Inline leaf nodes. +-- +-- The raw node is from the raw_annotation extension, +-- and can be used for types/entities/invalid code. +data Node c + = LeafText (Set TxtAttr) Text + | LeafRaw String Text + | LeafCode c + | LeafCodeBlock String c + deriving (Eq, Show, Functor, Foldable, Traversable) + +txt :: Text -> Node c +txt = LeafText mempty + +addTextAttribute :: TxtAttr -> Node c -> Node c +addTextAttribute a (LeafText as t) = LeafText (Set.insert a as) t +addTextAttribute _ n = n + +normalise :: (Eq c, Semigroup c) => Paragraph c -> Paragraph c +normalise (Paragraph a) = Paragraph $ go a + where + go = \case + [] -> [] + (n : ns) -> let (n', ns') = mergeSame n ns in n' : go ns' + mergeSame = \case + l@(LeafText attrs1 t1) -> \case + (LeafText attrs2 t2 : rss) | attrs1 == attrs2 -> mergeSame (LeafText attrs1 $ t1 <> t2) rss + rs -> (l, rs) + l -> (l,) + +-- | Simple text attributes that make it easier to find key info in descriptions. +data TxtAttr = Strong | Emphasis + deriving (Eq, Show, Ord) + +instance Mark.Rangeable (Paragraph c) where + ranged _ = id + +instance Mark.HasAttributes (Paragraph c) where + addAttributes _ = id + +instance Mark.Rangeable (Document c) where + ranged _ = id + +instance Mark.HasAttributes (Document c) where + addAttributes _ = id + +instance GHC.Exts.IsList (Document a) where + type Item (Document a) = Paragraph a + toList = paragraphs + fromList = Document + +instance GHC.Exts.IsString (Document Syntax) where + fromString = fromText . T.pack + +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) + +-- | Surround some text in double quotes if it is not empty. +quoteMaybe :: Text -> Text +quoteMaybe t = if T.null t then t else T.concat ["\"", t, "\""] + +instance Mark.IsInline (Paragraph Text) where + lineBreak = pureP $ txt "\n" + softBreak = pureP $ txt " " + str = pureP . txt + entity = Mark.str + escapedChar c = Mark.str $ T.pack ['\\', c] + emph = mapP $ addTextAttribute Emphasis + strong = mapP $ addTextAttribute Strong + link dest title desc = pureP (txt "[") <> desc <> pureP (txt $ "](" <> dest <> quoteMaybe title <> ")") + image dest title desc = pureP (txt "!") <> Mark.link dest title desc + code = pureP . LeafCode + rawInline (Mark.Format f) = pureP . LeafRaw (T.unpack f) + +instance Mark.IsBlock (Paragraph Text) (Document Text) where + paragraph = Document . (: []) + plain = Mark.paragraph + thematicBreak = mempty + 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 + referenceLinkDefinition = mempty + list _type _spacing = mconcat + +parseSyntax :: Text -> Either String Syntax +parseSyntax t = case readTerm t of + Left e -> Left (T.unpack e) + Right Nothing -> Left "empty code" + Right (Just s) -> case processParsedTerm s of + -- Just run the typechecker etc. to make sure the term typechecks + Left e -> Left (T.unpack $ prettyTypeErrText t e) + -- ...but if it does, we just go back to using the original parsed + -- (*unelaborated*) AST. See #1496. + Right _ -> Right s + +findCode :: Document Syntax -> [Syntax] +findCode = concatMap (mapMaybe codeOnly . nodes) . paragraphs + where + codeOnly = \case + LeafCode s -> Just s + LeafCodeBlock _i s -> Just s + _l -> Nothing + +instance ToJSON (Paragraph Syntax) where + toJSON = String . toText + +instance ToJSON (Document Syntax) where + toJSON = String . docToMark + +instance FromJSON (Document Syntax) where + parseJSON v = parseDoc v <|> parsePars v + where + parseDoc = withText "markdown" fromTextM + parsePars = withArray "markdown paragraphs" $ \a -> do + (ts :: [Text]) <- mapM parseJSON $ toList a + fromTextM $ T.intercalate "\n\n" ts + +-- | Parse Markdown document, but throw on invalid code. +fromText :: Text -> Document Syntax +fromText = either error id . fromTextE + +-- | Read Markdown document and parse&validate the code. +-- +-- If you want only the document with code as `Text`, +-- use the 'fromTextPure' function. +fromTextM :: MonadFail m => Text -> m (Document Syntax) +fromTextM = either fail pure . fromTextE + +fromTextE :: Text -> Either String (Document Syntax) +fromTextE t = fromTextPure t >>= traverse parseSyntax + +-- | Read Markdown document without code validation. +fromTextPure :: Text -> Either String (Document Text) +fromTextPure t = do + let spec = Mark.rawAttributeSpec <> Mark.defaultSyntaxSpec <> Mark.rawAttributeSpec + let runSimple = left show . runIdentity + Document tokenizedDoc <- runSimple $ Mark.commonmarkWith spec "markdown" t + return . Document $ normalise <$> tokenizedDoc + +-------------------------------------------------------------- +-- DIY STREAM +-------------------------------------------------------------- + +-- | Convert 'Document' to 'Text'. +-- +-- Note that this will strip some markdown, emphasis and bold marks. +-- If you want to get markdown again, use 'docToMark'. +docToText :: PrettyPrec a => Document a -> Text +docToText = T.intercalate "\n\n" . map toText . paragraphs + +-- | This is the naive and easy way to get text from markdown document. +toText :: ToStream a => a -> Text +toText = streamToText . toStream + +-- | Token stream that can be easily converted to text or brick widgets. +-- +-- TODO: #574 Code blocks should probably be handled separately. +data StreamNode' t + = TextNode (Set TxtAttr) t + | CodeNode t + | RawNode String t + deriving (Eq, Show, Functor) + +type StreamNode = StreamNode' Text + +unStream :: StreamNode' t -> (t -> StreamNode' t, t) +unStream = \case + TextNode a t -> (TextNode a, t) + CodeNode t -> (CodeNode, t) + RawNode a t -> (RawNode a, t) + +-- | Get chunks of nodes not exceeding length and broken at word boundary. +chunksOf :: Int -> [StreamNode] -> [[StreamNode]] +chunksOf n = chop (splitter True n) + where + nodeLength :: StreamNode -> Int + nodeLength = T.length . snd . unStream + splitter :: Bool -> Int -> [StreamNode] -> ([StreamNode], [StreamNode]) + splitter start i = \case + [] -> ([], []) + (tn : ss) -> + let l = nodeLength tn + in if l <= i + then first (tn :) $ splitter False (i - l) ss + else let (tn1, tn2) = cut start i tn in ([tn1], tn2 : ss) + cut :: Bool -> Int -> StreamNode -> (StreamNode, StreamNode) + cut start i tn = + let (con, t) = unStream tn + endSpace = T.takeWhileEnd isSpace t + startSpace = T.takeWhile isSpace t + twords = T.words t & _head %~ (startSpace <>) & _last %~ (<> endSpace) + in case splitWordsAt i twords of + ([], []) -> (con "", con "") + ([], ws@(ww : wws)) -> + both (con . T.unwords) $ + -- In case single word (e.g. web link) does not fit on line we must put + -- it there and guarantee progress (otherwise chop will cycle) + if start then ([T.take i ww], T.drop i ww : wws) else ([], ws) + splitted -> both (con . T.unwords) splitted + +splitWordsAt :: Int -> [Text] -> ([Text], [Text]) +splitWordsAt i = \case + [] -> ([], []) + (w : ws) -> + let l = T.length w + in if l < i + then first (w :) $ splitWordsAt (i - l - 1) ws + else ([], w : ws) + +streamToText :: [StreamNode] -> Text +streamToText = T.concat . map nodeToText + where + nodeToText = \case + TextNode _a t -> t + RawNode _s t -> t + CodeNode stx -> stx + +-- | Convert elements to one dimensional stream of nodes, +-- that is easy to format and layout. +-- +-- If you want to split the stream at line length, use +-- the 'chunksOf' function afterward. +class ToStream a where + toStream :: a -> [StreamNode] + +instance PrettyPrec a => ToStream (Node a) where + toStream = \case + LeafText a t -> [TextNode a t] + LeafCode t -> [CodeNode (prettyTextLine t)] + LeafRaw s t -> [RawNode s t] + LeafCodeBlock _i t -> [CodeNode (prettyText t)] + +instance PrettyPrec a => ToStream (Paragraph a) where + toStream = concatMap toStream . nodes + +-------------------------------------------------------------- +-- Markdown +-------------------------------------------------------------- + +nodeToMark :: PrettyPrec a => Node a -> Text +nodeToMark = \case + LeafText a t -> foldl attr t a + LeafRaw _ c -> wrap "`" c + LeafCode c -> wrap "`" (prettyText c) + LeafCodeBlock f c -> codeBlock f $ prettyText c + where + codeBlock f t = wrap "```" $ T.pack f <> "\n" <> t <> "\n" + wrap c t = c <> t <> c + attr t a = case a of + Emphasis -> wrap "_" t + Strong -> wrap "**" t + +paragraphToMark :: PrettyPrec a => Paragraph a -> Text +paragraphToMark = foldMap nodeToMark . nodes + +-- | Convert 'Document' to markdown text. +docToMark :: PrettyPrec a => Document a -> Text +docToMark = T.intercalate "\n\n" . map paragraphToMark . paragraphs diff --git a/src/swarm-lang/Swarm/Language/Typecheck.hs b/src/swarm-lang/Swarm/Language/Typecheck.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Typecheck.hs @@ -0,0 +1,1251 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Type inference for the Swarm language. For the approach used here, +-- see +-- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/ . +module Swarm.Language.Typecheck ( + -- * Type errors + ContextualTypeErr (..), + TypeErr (..), + InvalidAtomicReason (..), + + -- * Type provenance + Source (..), + withSource, + Join, + getJoin, + + -- * Typechecking stack + TCFrame (..), + LocatedTCFrame (..), + TCStack, + withFrame, + + -- * Typechecking monad + fresh, + + -- * Unification + instantiate, + skolemize, + generalize, + + -- * Type inference + inferTop, + infer, + inferConst, + check, + isSimpleUType, +) where + +import Control.Arrow ((***)) +import Control.Carrier.Error.Either (ErrorC, runError) +import Control.Carrier.Reader (ReaderC, runReader) +import Control.Carrier.Throw.Either (ThrowC, runThrow) +import Control.Category ((>>>)) +import Control.Effect.Catch (Catch, catchError) +import Control.Effect.Error (Error) +import Control.Effect.Reader +import Control.Effect.Throw +import Control.Lens ((^.)) +import Control.Lens.Indexed (itraverse) +import Control.Monad (forM_, void, when, (<=<), (>=>)) +import Control.Monad.Free (Free (..)) +import Data.Data (Data, gmapM) +import Data.Foldable (fold, traverse_) +import Data.Functor.Identity +import Data.Generics (mkM) +import Data.Map (Map, (!)) +import Data.Map qualified as M +import Data.Maybe +import Data.Set (Set, (\\)) +import Data.Set qualified as S +import Data.Text qualified as T +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.Parser.QQ (tyQ) +import Swarm.Language.Requirements.Analysis (requirements) +import Swarm.Language.Requirements.Type (ReqCtx) +import Swarm.Language.Syntax +import Swarm.Language.Types +import Prelude hiding (lookup) + +------------------------------------------------------------ +-- Typechecking stack + +-- | A frame to keep track of something we were in the middle of doing +-- during typechecking. +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 + deriving (Show) + +-- | A typechecking stack frame together with the relevant @SrcLoc@. +data LocatedTCFrame = LocatedTCFrame SrcLoc TCFrame + deriving (Show) + +-- | A typechecking stack keeps track of what we are currently in the +-- middle of doing during typechecking. +type TCStack = [LocatedTCFrame] + +-- | Push a frame on the typechecking stack. +withFrame :: Has (Reader TCStack) sig m => SrcLoc -> TCFrame -> m a -> m a +withFrame l f = local (LocatedTCFrame l f :) + +------------------------------------------------------------ +-- Type source + +-- | The source of a type during typechecking. +data Source + = -- | An expected type that was "pushed down" from the context. + Expected + | -- | An actual/inferred type that was "pulled up" from a term. + Actual + deriving (Show, Eq, Ord, Bounded, Enum) + +-- | Generic eliminator for 'Source'. Choose the first argument if +-- the 'Source' is 'Expected', and the second argument if 'Actual'. +withSource :: Source -> a -> a -> a +withSource Expected e _ = e +withSource Actual _ a = a + +-- | A value along with its source (expected vs actual). +type Sourced a = (Source, a) + +-- | A "join" where an expected thing meets an actual thing. +newtype Join a = Join (Source -> a) + deriving (Functor) + +instance Foldable Join where + foldMap :: Monoid m => (a -> m) -> Join a -> m + foldMap f j = f a1 <> f a2 + where + (a1, a2) = getJoin j + +instance Traversable Join where + traverse :: Applicative f => (a -> f b) -> Join a -> f (Join b) + traverse f j = joined <$> f a1 <*> f a2 + where + (a1, a2) = getJoin j + +instance (Show a) => Show (Join a) where + show (getJoin -> (e, a)) = "(expected: " <> show e <> ", actual: " <> show a <> ")" + +type TypeJoin = Join UType + +-- | Create a 'Join' from an expected thing and an actual thing (in that order). +joined :: a -> a -> Join a +joined expect actual = Join (\case Expected -> expect; Actual -> actual) + +-- | Create a 'Join' from a 'Sourced' thing together with another +-- thing (which is assumed to have the opposite 'Source'). +mkJoin :: Sourced a -> a -> Join a +mkJoin (src, a1) a2 = Join $ \s -> if s == src then a1 else a2 + +-- | Convert a 'Join' into a pair of (expected, actual). +getJoin :: Join a -> (a, a) +getJoin (Join j) = (j Expected, j Actual) + +------------------------------------------------------------ +-- Type checking + +fromUSyntax :: + ( Has Unification sig m + , Has (Reader UCtx) sig m + , Has (Throw ContextualTypeErr) sig m + ) => + USyntax -> + m TSyntax +fromUSyntax = mapM (checkPredicative <=< (fmap fromU . generalize)) + +finalizeUSyntax :: + ( Has Unification sig m + , Has (Reader UCtx) sig m + , Has (Throw ContextualTypeErr) sig m + ) => + USyntax -> + m TSyntax +finalizeUSyntax = applyBindings >=> fromUSyntax + +-- | Version of 'runTC' which is generic in the base monad. +runTC' :: + Algebra sig m => + TCtx -> + ReqCtx -> + TDCtx -> + ReaderC UCtx (ReaderC TCStack (ErrorC ContextualTypeErr (U.UnificationC (ReaderC ReqCtx (ReaderC TDCtx m))))) USyntax -> + m (Either ContextualTypeErr TSyntax) +runTC' ctx reqCtx tdctx = + (>>= finalizeUSyntax) + >>> runReader (toU ctx) + >>> runReader [] + >>> runError + >>> U.runUnification + >>> runReader reqCtx + >>> runReader tdctx + >>> fmap reportUnificationError + +-- | Run a top-level inference computation, returning either a +-- 'ContextualTypeErr' or a fully resolved 'TSyntax'. +runTC :: + TCtx -> + ReqCtx -> + TDCtx -> + ReaderC UCtx (ReaderC TCStack (ErrorC ContextualTypeErr (U.UnificationC (ReaderC ReqCtx (ReaderC TDCtx Identity))))) USyntax -> + Either ContextualTypeErr TSyntax +runTC tctx reqCtx tdctx = runTC' tctx reqCtx tdctx >>> runIdentity + +checkPredicative :: Has (Throw ContextualTypeErr) sig m => Maybe a -> m a +checkPredicative = maybe (throwError (mkRawTypeErr Impredicative)) pure + +reportUnificationError :: Either UnificationError (Either ContextualTypeErr a) -> Either ContextualTypeErr a +reportUnificationError = either (Left . mkRawTypeErr . UnificationErr) id + +-- | Look up a variable in the ambient type context, either throwing +-- an 'UnboundVar' error if it is not found, or opening its +-- associated 'UPolytype' with fresh unification variables via +-- 'instantiate'. +lookup :: + ( Has (Throw ContextualTypeErr) sig m + , Has (Reader TCStack) sig m + , Has (Reader UCtx) sig m + , Has Unification sig m + ) => + SrcLoc -> + Var -> + m UType +lookup loc x = do + ctx <- ask @UCtx + maybe (throwTypeErr loc $ UnboundVar x) instantiate (Ctx.lookup x ctx) + +-- | Catch any thrown type errors and re-throw them with an added source +-- location. +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 + +------------------------------------------------------------ +-- Dealing with variables: free variables, fresh variables, +-- substitution + +-- | A class for getting the free unification variables of a thing. +class FreeUVars a where + freeUVars :: Has Unification sig m => a -> m (Set IntVar) + +-- | We can get the free unification variables of a 'UType'. +instance FreeUVars UType where + 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 + +-- | We can get the free variables in any polytype in a context. +instance FreeUVars UCtx where + freeUVars = fmap S.unions . mapM freeUVars . M.elems . unCtx + +-- | Generate a fresh unification variable. +fresh :: Has Unification sig m => m UType +fresh = Pure <$> U.freshIntVar + +-- | Perform a substitution over a 'UType', substituting for both type +-- and unification variables. Note that since 'UType's do not have +-- any binding constructs, we don't have to worry about ignoring +-- bound variables; all variables in a 'UType' are free. +substU :: Map (Either Var IntVar) UType -> UType -> UType +substU m = + ucata + (\v -> fromMaybe (Pure v) (M.lookup (Right v) m)) + ( \case + TyVarF v -> fromMaybe (UTyVar v) (M.lookup (Left v) m) + f -> Free f + ) + +-- | Make sure no skolem variables escape. +noSkolems :: + ( Has Unification sig m + , Has (Reader TCStack) sig m + , Has (Throw ContextualTypeErr) sig m + ) => + SrcLoc -> + Poly UType -> + m () +noSkolems l (Forall xs upty) = do + upty' <- applyBindings upty + let tyvs = + ucata + (const S.empty) + (\case TyVarF v -> S.singleton v; f -> fold f) + upty' + ftyvs = tyvs `S.difference` S.fromList xs + forM_ (S.lookupMin ftyvs) $ throwTypeErr l . EscapedSkolem + +-- ~~~~ Note [lookupMin to get an arbitrary element] +-- +-- `S.lookupMin :: Set a -> Maybe a` returns the smallest +-- element of a set, or Nothing if the set is empty. We don't +-- actually care about getting the *smallest* type variable, but +-- lookupMin is a convenient way to say "just get one element if +-- any exist". The forM_ is actually over the Maybe so it represents +-- doing the throwTypeErr either zero or one time, depending on +-- whether lookupMin returns Nothing or Just. + +-- | @unify t expTy actTy@ ensures that the given two types are equal. +-- If we know the actual term @t@ which is supposed to have these +-- types, we can use it to generate better error messages. +unify :: + ( Has Unification sig m + , Has (Throw ContextualTypeErr) sig m + , Has (Reader TCStack) sig m + ) => + Maybe Syntax -> + TypeJoin -> + m UType +unify ms j = do + res <- expected =:= actual + case res of + Left _ -> do + j' <- traverse U.applyBindings j + throwTypeErr NoLoc $ Mismatch ms j' + Right ty -> return ty + where + (expected, actual) = getJoin j + +-- | The 'HasBindings' class is for anything which has +-- unification variables in it and to which we can usefully apply +-- 'applyBindings'. +class HasBindings u where + applyBindings :: Has Unification sig m => u -> m u + +instance HasBindings UType where + applyBindings = U.applyBindings + +instance HasBindings UPolytype where + applyBindings (Forall xs u) = Forall xs <$> applyBindings u + +instance HasBindings UCtx where + applyBindings = mapM applyBindings + +instance (HasBindings u, Data u) => HasBindings (Term' u) where + applyBindings = gmapM (mkM (applyBindings @(Syntax' u))) + +instance (HasBindings u, Data u) => HasBindings (Syntax' u) where + applyBindings (Syntax' l t cs u) = Syntax' l <$> applyBindings t <*> pure cs <*> applyBindings u + +------------------------------------------------------------ +-- Converting between mono- and polytypes + +-- | 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 + xs' <- mapM (const fresh) xs + return $ substU (M.fromList (zip (map Left xs) xs')) 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 + +-- | 'generalize' is the opposite of 'instantiate': add a 'Forall' +-- which closes over all free type and unification variables. +-- +-- Pick nice type variable names instead of reusing whatever fresh +-- names happened to be used for the free variables. +generalize :: (Has Unification sig m, Has (Reader UCtx) sig m) => UType -> m UPolytype +generalize uty = do + uty' <- applyBindings uty + ctx <- ask @UCtx + tmfvs <- freeUVars uty' + ctxfvs <- freeUVars ctx + let fvs = S.toList $ tmfvs \\ ctxfvs + alphabet = ['a' .. 'z'] + -- Infinite supply of pretty names a, b, ..., z, a0, ... z0, a1, ... z1, ... + 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 + (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 + +-- | Errors that can occur during type checking. The idea is that +-- each error carries information that can be used to help explain +-- what went wrong (though the amount of information carried can and +-- should be very much improved in the future); errors can then +-- separately be pretty-printed to display them to the user. +data TypeErr + = -- | An undefined variable was encountered. + UnboundVar Var + | -- | A kind error was encountered. + KindErr KindError + | -- | A Skolem variable escaped its local context. + EscapedSkolem Var + | -- | Occurs check failure, i.e. infinite type. + 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 + | -- | Lambda argument type mismatch. + LambdaArgMismatch TypeJoin + | -- | Record field mismatch, i.e. based on the expected type we + -- were expecting a record with certain fields, but found one with + -- a different field set. + FieldsMismatch (Join (Set Var)) + | -- | A definition was encountered not at the top level. + DefNotTopLevel Term + | -- | A term was encountered which we cannot infer the type of. + -- This should never happen. + CantInfer Term + | -- | We can't infer the type of a record projection @r.x@ if we + -- don't concretely know the type of the record @r@. + CantInferProj Term + | -- | An attempt to project out a nonexistent field + UnknownProj Var Term + | -- | An invalid argument was provided to @atomic@. + InvalidAtomic InvalidAtomicReason Term + | -- | Some unification variables ended up in a type, probably due to + -- impredicativity. See https://github.com/swarm-game/swarm/issues/351 . + Impredicative + deriving (Show) + +-- | Various reasons the body of an @atomic@ might be invalid. +data InvalidAtomicReason + = -- | The argument has too many tangible commands. + TooManyTicks Int + | -- | The argument uses some way to duplicate code: @def@, @let@, or lambda. + AtomicDupingThing + | -- | The argument referred to a variable with a non-simple type. + NonSimpleVarType Var UPolytype + | -- | The argument had a nested @atomic@ + NestedAtomic + | -- | The argument contained a long command + LongConst + | -- | The argument contained a suspend + AtomicSuspend + deriving (Show) + +------------------------------------------------------------ +-- Type decomposition + +-- | Decompose a type that is supposed to be the application of a +-- given type constructor to a single type argument. Also take the +-- term which is supposed to have that type, for use in error +-- messages. +decomposeTyConApp1 :: + ( Has Unification sig m + , Has (Throw ContextualTypeErr) sig m + , Has (Reader TDCtx) sig m + , Has (Reader TCStack) sig m + ) => + TyCon -> + Syntax -> + Sourced UType -> + m UType +decomposeTyConApp1 c t (src, UTyConApp (TCUser u) as) = do + ty2 <- expandTydef u as + decomposeTyConApp1 c t (src, ty2) +decomposeTyConApp1 c _ (_, UTyConApp c' [a]) + | c == c' = return a +decomposeTyConApp1 c t ty = do + a <- fresh + _ <- unify (Just t) (mkJoin ty (UTyConApp c [a])) + return a + +decomposeCmdTy + , decomposeDelayTy :: + ( Has Unification sig m + , Has (Throw ContextualTypeErr) sig m + , Has (Reader TDCtx) sig m + , Has (Reader TCStack) sig m + ) => + Syntax -> + Sourced UType -> + m UType +decomposeCmdTy = decomposeTyConApp1 TCCmd +decomposeDelayTy = decomposeTyConApp1 TCDelay + +-- | 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. +decomposeTyConApp2 :: + ( Has Unification sig m + , Has (Throw ContextualTypeErr) sig m + , Has (Reader TDCtx) sig m + , Has (Reader TCStack) sig m + ) => + TyCon -> + Syntax -> + Sourced UType -> + m (UType, UType) +decomposeTyConApp2 c t (src, UTyConApp (TCUser u) as) = do + ty2 <- expandTydef u as + decomposeTyConApp2 c t (src, ty2) +decomposeTyConApp2 c _ (_, UTyConApp c' [ty1, ty2]) + | c == c' = return (ty1, ty2) +decomposeTyConApp2 c t ty = do + a1 <- fresh + a2 <- fresh + _ <- unify (Just t) (mkJoin ty (UTyConApp c [a1, a2])) + return (a1, a2) + +decomposeFunTy + , decomposeProdTy :: + ( Has Unification sig m + , Has (Throw ContextualTypeErr) sig m + , Has (Reader TDCtx) sig m + , Has (Reader TCStack) sig m + ) => + Syntax -> + Sourced UType -> + m (UType, UType) +decomposeFunTy = decomposeTyConApp2 TCFun +decomposeProdTy = decomposeTyConApp2 TCProd + +------------------------------------------------------------ +-- Type inference / checking + +-- | Top-level type inference function: given a context of definition +-- 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 + +-- | Infer the type of a term, returning a type-annotated term. +-- +-- The only cases explicitly handled in 'infer' are those where +-- pushing an expected type down into the term can't possibly help, +-- e.g. most primitives, function application, and binds. +-- +-- For most everything else we prefer 'check' because it can often +-- result in better and more localized type error messages. +-- +-- Note that we choose to do kind checking inline as we go during +-- typechecking. This has pros and cons. The benefit is that we get +-- to piggyback on the existing source location tracking and +-- typechecking stack, so we can generate better error messages. The +-- 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 +-- being checked. +infer :: + ( Has (Reader UCtx) sig m + , Has (Reader ReqCtx) sig m + , Has (Reader TDCtx) sig m + , Has (Reader TCStack) sig m + , Has Unification sig m + , Has (Error ContextualTypeErr) sig m + ) => + Syntax -> + m (Syntax' UType) +infer s@(CSyntax l t cs) = addLocToTypeErr l $ case t of + -- Primitives, i.e. things for which we immediately know the only + -- possible correct type, and knowing an expected type would provide + -- no extra information. + TUnit -> return $ Syntax' l TUnit cs UTyUnit + TConst c -> Syntax' l (TConst c) cs <$> (instantiate . toU $ inferConst c) + TDir d -> return $ Syntax' l (TDir d) cs UTyDir + TInt n -> return $ Syntax' l (TInt n) cs UTyInt + TAntiInt x -> return $ Syntax' l (TAntiInt x) cs UTyInt + TText x -> return $ Syntax' l (TText x) cs UTyText + 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) + SRequirements x t1 -> do + t1' <- infer t1 + return $ Syntax' l (SRequirements x t1') cs (UTyCmd UTyUnit) + + -- We should never encounter a TRef since they do not show up in + -- surface syntax, only as values while evaluating (*after* + -- typechecking). + TRef _ -> throwTypeErr l $ CantInfer t + -- Just look up variables in the context. + TVar x -> Syntax' l (TVar x) cs <$> lookup l x + -- It is helpful to handle lambdas in inference mode as well as + -- checking mode; in particular, we can handle lambdas with an + -- explicit type annotation on the argument. Just infer the body + -- 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)) + + -- 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 + -- 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 + -- applied is either (1) a primitive or variable whose type we can + -- easily infer, or (2) a nested application; in the second case in + -- particular, handling applications in inference mode means we can + -- stay in inference mode the whole way down the left-hand side of + -- the chain of applications. If we handled applications in + -- checking mode, we would constantly flip back and forth between + -- inference & checking and generate a fresh unification variable + -- 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) + + -- Then check that the argument has the right type. + x' <- check x argTy + + -- Call applyBindings explicitly, so that anything we learned + -- about unification variables while checking the type of the + -- argument can flow to later steps. This is especially helpful + -- while checking applications of polymorphic multi-argument + -- functions such as 'if'. Without this call to 'applyBindings', + -- type mismatches between the branches of an 'if' tend to get + -- caught in the unifier, resulting in vague "can't unify" + -- messages (for example, "if true {3} {move}" yields "can't + -- unify Int and Cmd Unit"). With this 'applyBindings' call, we + -- get more specific errors about how the second branch was + -- expected to have the same type as the first (e.g. "expected + -- `move` to have type `Int`, but it actually has type `Cmd + -- Unit`). + resTy' <- applyBindings resTy + + return $ Syntax' l (SApp f' x') cs resTy' + + -- We handle binds in inference mode for a similar reason to + -- application. + -- + -- There is no way to annotate a bind with types or requirements in + -- the surface syntax, so the second through fourth fields are + -- necessarily Nothing. + SBind mx _ _ _ c1 c2 -> do + c1' <- withFrame l TCBindL $ infer c1 + a <- decomposeCmdTy c1 (Actual, c1' ^. sType) + genA <- generalize a + c2' <- + maybe id ((`withBinding` genA) . lvVar) mx + . withFrame l TCBindR + $ 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 + -- ensure it's a command type anyway. Otherwise something + -- like 'move; 3' would be accepted with type int. + _ <- decomposeCmdTy c2 (Actual, c2' ^. sType) + + -- NOTE: it is probably not correct to say that the variable bound + -- in a monadic bind has no requirements. But as long as it is + -- some kind of primitive value type (Int, Bool, etc.) it really + -- doesn't matter, since it will already be evaluated, so using it + -- in the future really does incur no requirements. It would only + -- matter if someone used something like + -- + -- f <- (c : Cmd (Cmd Int)); ... f ... + -- + -- so that f ends up with a type like Cmd Int. But we already + -- don't handle that kind of thing correctly anyway. The real fix + -- will have to wait for #231. + let binderReqs = mempty + + return $ Syntax' l (SBind mx (Just a) Nothing (Just binderReqs) c1' c2') cs (c2' ^. sType) + + -- Handle record projection in inference mode. Knowing the expected + -- type of r.x doesn't really help since we must infer the type of r + -- first anyway. + SProj t1 x -> do + t1' <- infer t1 + case t1' ^. sType of + UTyRcd 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) + + -- 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')) + + -- 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 + -- Typecheck against skolemized polytype. + uty <- skolemize upty + _ <- check c uty + -- Make sure no skolem variables have escaped. + ask @UCtx >>= mapM_ (noSkolems l) + -- 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 + + -- Fallback: to infer the type of anything else, make up a fresh unification + -- variable for its type and check against it. + _ -> do + sTy <- fresh + check s sTy + +-- | Infer the type of a constant. +inferConst :: Const -> Polytype +inferConst c = case c of + Wait -> [tyQ| Int -> Cmd Unit |] + Noop -> [tyQ| Cmd Unit |] + Selfdestruct -> [tyQ| Cmd Unit |] + Move -> [tyQ| Cmd Unit |] + Backup -> [tyQ| Cmd Unit |] + Volume -> [tyQ| Int -> Cmd (Unit + Int) |] + Path -> [tyQ| (Unit + Int) -> ((Int * Int) + Text) -> Cmd (Unit + (Dir * Int)) |] + Push -> [tyQ| Cmd Unit |] + Stride -> [tyQ| Int -> Cmd Unit |] + Turn -> [tyQ| Dir -> Cmd Unit |] + Grab -> [tyQ| Cmd Text |] + Harvest -> [tyQ| Cmd Text |] + Sow -> [tyQ| Text -> Cmd Unit |] + Ignite -> [tyQ| Dir -> Cmd Unit |] + Place -> [tyQ| Text -> Cmd Unit |] + Ping -> [tyQ| Actor -> Cmd (Unit + (Int * Int)) |] + Give -> [tyQ| Actor -> Text -> Cmd Unit |] + Equip -> [tyQ| Text -> Cmd Unit |] + Unequip -> [tyQ| Text -> Cmd Unit |] + Make -> [tyQ| Text -> Cmd Unit |] + Has -> [tyQ| Text -> Cmd Bool |] + Equipped -> [tyQ| Text -> Cmd Bool |] + Count -> [tyQ| Text -> Cmd Int |] + Reprogram -> [tyQ| Actor -> {Cmd a} -> Cmd Unit |] + Build -> [tyQ| {Cmd a} -> Cmd Actor |] + Drill -> [tyQ| Dir -> Cmd (Unit + Text) |] + Use -> [tyQ| Text -> Dir -> Cmd (Unit + Text) |] + Salvage -> [tyQ| Cmd Unit |] + Say -> [tyQ| Text -> Cmd Unit |] + Listen -> [tyQ| Cmd Text |] + Log -> [tyQ| Text -> Cmd Unit |] + View -> [tyQ| Actor -> Cmd Unit |] + Appear -> [tyQ| Text -> (Unit + Text) -> Cmd Unit |] + Create -> [tyQ| Text -> Cmd Unit |] + Halt -> [tyQ| Actor -> Cmd Unit |] + 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))) |] + Floorplan -> [tyQ| Text -> Cmd (Int * Int) |] + HasTag -> [tyQ| Text -> Text -> Cmd Bool |] + TagMembers -> [tyQ| Text -> Int -> Cmd (Int * Text) |] + 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 |] + Sniff -> [tyQ| Text -> Cmd Int |] + Chirp -> [tyQ| Text -> Cmd Dir |] + Watch -> [tyQ| Dir -> Cmd Unit |] + Surveil -> [tyQ| (Int * Int) -> Cmd Unit |] + Heading -> [tyQ| Cmd Dir |] + Blocked -> [tyQ| Cmd Bool |] + Scan -> [tyQ| Dir -> Cmd (Unit + Text) |] + Upload -> [tyQ| Actor -> Cmd Unit |] + Ishere -> [tyQ| Text -> Cmd Bool |] + Isempty -> [tyQ| Cmd Bool |] + Self -> [tyQ| Actor |] + Parent -> [tyQ| Actor |] + Base -> [tyQ| Actor |] + Meet -> [tyQ| Cmd (Unit + Actor) |] + MeetAll -> [tyQ| Cmd (rec l. Unit + Actor * l) |] + Whoami -> [tyQ| Cmd Text |] + Setname -> [tyQ| Text -> Cmd Unit |] + Random -> [tyQ| Int -> Cmd Int |] + Run -> [tyQ| Text -> Cmd Unit |] + 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 |] + Force -> [tyQ| {a} -> a |] + Return -> [tyQ| a -> Cmd a |] + Try -> [tyQ| {Cmd a} -> {Cmd a} -> Cmd a |] + Undefined -> [tyQ| a |] + Fail -> [tyQ| Text -> a |] + Not -> [tyQ| Bool -> Bool |] + Neg -> [tyQ| Int -> Int |] + Eq -> cmpBinT + Neq -> cmpBinT + Lt -> cmpBinT + Gt -> cmpBinT + Leq -> cmpBinT + Geq -> cmpBinT + And -> [tyQ| Bool -> Bool -> Bool|] + Or -> [tyQ| Bool -> Bool -> Bool|] + Add -> arithBinT + Sub -> arithBinT + Mul -> arithBinT + Div -> arithBinT + Exp -> arithBinT + Format -> [tyQ| a -> Text |] + Concat -> [tyQ| Text -> Text -> Text |] + Chars -> [tyQ| Text -> Int |] + Split -> [tyQ| Int -> Text -> (Text * Text) |] + CharAt -> [tyQ| Int -> Text -> Int |] + ToChar -> [tyQ| Int -> Text |] + AppF -> [tyQ| (a -> b) -> a -> b |] + Swap -> [tyQ| Text -> Cmd Text |] + Atomic -> [tyQ| Cmd a -> Cmd a |] + Instant -> [tyQ| Cmd a -> Cmd a |] + Key -> [tyQ| Text -> Key |] + InstallKeyHandler -> [tyQ| Text -> (Key -> Cmd Unit) -> Cmd Unit |] + Teleport -> [tyQ| Actor -> (Int * Int) -> Cmd Unit |] + As -> [tyQ| Actor -> {Cmd a} -> Cmd a |] + RobotNamed -> [tyQ| Text -> Cmd Actor |] + RobotNumbered -> [tyQ| Int -> Cmd Actor |] + Knows -> [tyQ| Text -> Cmd Bool |] + where + cmpBinT = [tyQ| a -> a -> Bool |] + arithBinT = [tyQ| Int -> Int -> Int |] + +-- | @check t ty@ checks that @t@ has type @ty@, returning a +-- type-annotated AST if so. +-- +-- We try to stay in checking mode as far as possible, decomposing +-- the expected type as we go and pushing it through the recursion. +check :: + ( Has (Reader UCtx) sig m + , Has (Reader ReqCtx) sig m + , Has (Reader TDCtx) sig m + , Has (Reader TCStack) sig m + , Has Unification sig m + , Has (Error ContextualTypeErr) sig m + ) => + Syntax -> + UType -> + m (Syntax' UType) +check s@(CSyntax l t cs) expected = addLocToTypeErr l $ case t of + -- If t : ty, then {t} : {ty}. + SDelay s1 -> do + ty1 <- decomposeDelayTy s (Expected, expected) + s1' <- check s1 ty1 + return $ Syntax' l (SDelay s1') cs (UTyDelay ty1) + + -- To check the type of a pair, make sure the expected type is a + -- product type, and push the two types down into the left and right. + SPair s1 s2 -> do + (ty1, ty2) <- decomposeProdTy s (Expected, expected) + s1' <- check s1 ty1 + s2' <- check s2 ty2 + return $ Syntax' l (SPair s1' s2') cs (UTyProd ty1 ty2) + + -- 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) + + -- 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'. + + TConst c :$: at + | c `elem` [Atomic, Instant] -> do + argTy <- decomposeCmdTy s (Expected, expected) + at' <- check at (UTyCmd argTy) + atomic' <- infer (Syntax l (TConst c)) + -- It's important that we typecheck the subterm @at@ *before* we + -- check that it is a valid argument to @atomic@: this way we can + -- ensure that we have already inferred the types of any variables + -- referenced. + -- + -- When c is Atomic we validate that the argument to atomic is + -- guaranteed to operate within a single tick. When c is Instant + -- we skip this check. + when (c == Atomic) $ validAtomic at + 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 + -- 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 + 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. + Just pty -> do + let upty = toU pty + uty <- skolemize upty + t1' <- withBinding (lvVar x) upty $ check t1 uty + return (upty, t1') + + -- Check the requirements of t1. + tdCtx <- ask @TDCtx + reqCtx <- ask @ReqCtx + let Syntax' _ tt1 _ _ = t1 + reqs = requirements tdCtx reqCtx tt1 + + -- 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 + -- not persist to the next REPL input, which could be surprising. + -- + -- On the other hand, 'let x = y in x + 3' is perfectly fine. + when (ls == LSDef) $ void $ decomposeCmdTy t2 (Expected, expected) + + -- Now check the type of the body, under a context extended with + -- the type and requirements of the bound variable. + t2' <- + withBinding (lvVar x) upty $ + withBinding (lvVar x) reqs $ + check t2 expected + + -- Make sure no skolem variables have escaped. + ask @UCtx >>= mapM_ (noSkolems l) + + -- Annotate a 'def' with requirements, but not 'let'. The reason + -- is so that let introduces truly "local" bindings which never + -- persist, but def introduces "global" bindings. Variables bound + -- in the environment can only be used to typecheck future REPL + -- 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) + -- 5 + -- > x + -- 3 + -- > let y : Int = 3 in y + 2 + -- 5 + -- > y + -- 1:1: Unbound variable y + -- > let y = 3 in def x = 5 end; return (x + y) + -- 8 + -- > y + -- 1:1: Unbound variable y + -- > x + -- 5 + let mreqs = case ls of + LSDef -> Just reqs + LSLet -> Nothing + + -- Return the annotated let. + return $ Syntax' l (SLet ls r x mxTy 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) + -- 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' + + -- To check a record, ensure the expected type is a record type, + -- ensure all the right fields are present, and push the expected + -- types of all the fields down into recursive checks. + -- + -- We have to be careful here --- if the expected type is not + -- manifestly a record type but might unify with one (i.e. if the + -- expected type is a variable) then we can't generate type + -- variables for its subparts and push them, we have to switch + -- completely into inference mode. See Note [Checking and inference + -- for record literals]. + SRcd fields + | UTyRcd tyMap <- expected -> do + let expectedFields = M.keysSet tyMap + actualFields = M.keysSet fields + when (actualFields /= expectedFields) $ + throwTypeErr l $ + FieldsMismatch (joined expectedFields actualFields) + m' <- itraverse (\x ms -> check (fromMaybe (STerm (TVar x)) ms) (tyMap ! x)) fields + return $ Syntax' l (SRcd (Just <$> m')) cs expected + + -- The type of @suspend t@ is @Cmd T@ if @t : T@. + SSuspend s1 -> do + argTy <- decomposeCmdTy s (Expected, expected) + s1' <- check s1 argTy + return $ Syntax' l (SSuspend s1') cs expected + + -- Fallback: switch into inference mode, and check that the type we + -- get is what we expected. + _ -> do + Syntax' l' t' _ actual <- infer s + Syntax' l' t' cs <$> unify (Just s) (joined expected actual) + +-- ~~~~ Note [Checking and inference for record literals] +-- +-- We need to handle record literals in both inference and checking +-- mode. By way of contrast, with a pair, if we are in checking +-- mode and the expected type is not manifestly a product type, we +-- can just generate fresh unification variables for the types of +-- the two components, generate a constraint that the expected type +-- is equal to a product type of these two fresh types, and continue +-- in checking mode on both sides. With records, however, we cannot +-- do that; if we are checking a record and the expected type is not +-- manifestly a record type, we must simply switch into inference +-- mode. However, it is still helpful to be able to handle records +-- in checking mode too, since if we know a record type it is +-- helpful to be able to push the field types down into the fields. + +------------------------------------------------------------ +-- Special atomic checking + +-- | Ensure a term is a valid argument to @atomic@. Valid arguments +-- may not contain @def@, @let@, or lambda. Any variables which are +-- referenced must have a primitive, first-order type such as +-- @Text@ or @Int@ (in particular, no functions, @Cmd@, or +-- @delay@). We simply assume that any locally bound variables are +-- OK without checking their type: the only way to bind a variable +-- locally is with a binder of the form @x <- c1; c2@, where @c1@ is +-- some primitive command (since we can't refer to external +-- variables of type @Cmd a@). If we wanted to do something more +-- sophisticated with locally bound variables we would have to +-- inline this analysis into typechecking proper, instead of having +-- it be a separate, out-of-band check. +-- +-- The goal is to ensure that any argument to @atomic@ is guaranteed +-- to evaluate and execute in some small, finite amount of time, so +-- that it's impossible to write a term which runs atomically for an +-- indefinite amount of time and freezes the rest of the game. Of +-- course, nothing prevents one from writing a large amount of code +-- inside an @atomic@ block; but we want the execution time to be +-- linear in the size of the code. +-- +-- We also ensure that the atomic block takes at most one tick, +-- i.e. contains at most one tangible command. For example, @atomic +-- (move; move)@ is invalid, since that would allow robots to move +-- twice as fast as usual by doing both actions in one tick. +validAtomic :: + ( Has (Reader UCtx) sig m + , Has (Reader TCStack) sig m + , Has Unification sig m + , Has (Throw ContextualTypeErr) sig m + ) => + Syntax -> + m () +validAtomic s@(Syntax l t) = do + n <- analyzeAtomic S.empty s + when (n > 1) $ throwTypeErr l $ InvalidAtomic (TooManyTicks n) t + +-- | Analyze an argument to @atomic@: ensure it contains no nested +-- atomic blocks and no references to external variables, and count +-- how many tangible commands it will execute. +analyzeAtomic :: + ( Has (Reader UCtx) sig m + , Has (Reader TCStack) sig m + , Has Unification sig m + , Has (Throw ContextualTypeErr) sig m + ) => + Set Var -> + Syntax -> + m Int +analyzeAtomic locals (Syntax l t) = case t of + -- Literals, primitives, etc. that are fine and don't require a tick + -- to evaluate + TUnit {} -> return 0 + TDir {} -> return 0 + TInt {} -> return 0 + TAntiInt {} -> return 0 + TText {} -> return 0 + TAntiText {} -> return 0 + TBool {} -> return 0 + TRobot {} -> return 0 + TRequireDevice {} -> return 0 + TRequire {} -> return 0 + SRequirements {} -> return 0 + STydef {} -> return 0 + -- Constants. + TConst c + -- Nested 'atomic' is not allowed. + | c == Atomic -> throwTypeErr l $ InvalidAtomic NestedAtomic t + -- We cannot allow long commands (commands that may require more + -- than one tick to execute) since that could freeze the game. + | isLong c -> throwTypeErr l $ InvalidAtomic LongConst t + -- Otherwise, return 1 or 0 depending on whether the command is + -- tangible. + | otherwise -> return $ if isTangible c then 1 else 0 + -- Special case for if: number of tangible commands is the *max* of + -- the branches instead of the sum, since exactly one of them will be + -- 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. + SPair s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2 + SApp s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2 + SDelay 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 + SRcd m -> sum <$> mapM analyzeField (M.assocs m) + where + analyzeField :: + ( Has (Reader UCtx) sig m + , Has (Reader TCStack) sig m + , Has Unification sig m + , Has (Throw ContextualTypeErr) sig m + ) => + (Var, Maybe Syntax) -> + m Int + analyzeField (x, Nothing) = analyzeAtomic locals (STerm (TVar x)) + analyzeField (_, Just s) = analyzeAtomic locals s + SProj {} -> return 0 + -- Variables are allowed if bound locally, or if they have a simple type. + TVar x + | x `S.member` locals -> return 0 + | otherwise -> do + mxTy <- Ctx.lookup x <$> ask @UCtx + case mxTy of + -- If the variable is undefined, return 0 to indicate the + -- atomic block is valid, because we'd rather have the error + -- caught by the real name+type checking. + Nothing -> return 0 + Just xTy -> do + -- Use applyBindings to make sure that we apply as much + -- information as unification has learned at this point. In + -- theory, continuing to typecheck other terms elsewhere in + -- the program could give us further information about xTy, + -- so we might have incomplete information at this point. + -- However, since variables referenced in an atomic block + -- must necessarily have simple types, it's unlikely this + -- will really make a difference. The alternative, more + -- "correct" way to do this would be to simply emit some + -- constraints at this point saying that xTy must be a + -- simple type, and check later that the constraint holds, + -- after performing complete type inference. However, since + -- the current approach is much simpler, we'll stick with + -- this until such time as we have concrete examples showing + -- that the more correct, complex way is necessary. + xTy' <- applyBindings xTy + if isSimpleUPolytype xTy' + then return 0 + else throwTypeErr l $ InvalidAtomic (NonSimpleVarType x xTy') t + -- No lambda, `let` or `def` allowed! + SLam {} -> throwTypeErr l $ InvalidAtomic AtomicDupingThing t + SLet {} -> throwTypeErr l $ InvalidAtomic AtomicDupingThing t + -- We should never encounter a TRef since they do not show up in + -- surface syntax, only as values while evaluating (*after* + -- typechecking). + TRef {} -> throwTypeErr l $ CantInfer t + -- An explicit type annotation doesn't change atomicity + SAnnotate s _ -> analyzeAtomic locals s + -- We should never encounter a suspend since it cannot be written + -- explicitly in the surface syntax. + SSuspend {} -> throwTypeErr l $ InvalidAtomic AtomicSuspend t + +-- | A simple polytype is a simple type with no quantifiers. +isSimpleUPolytype :: UPolytype -> Bool +isSimpleUPolytype (Forall [] ty) = isSimpleUType ty +isSimpleUPolytype _ = False + +-- | A simple type is a sum or product of base types. +isSimpleUType :: UType -> Bool +isSimpleUType = \case + UTyBase {} -> True + UTyVar {} -> False + UTySum ty1 ty2 -> isSimpleUType ty1 && isSimpleUType ty2 + UTyProd ty1 ty2 -> isSimpleUType ty1 && isSimpleUType ty2 + UTyFun {} -> False + UTyCmd {} -> False + UTyDelay {} -> False + -- Make the pattern-match coverage checker happy + Pure {} -> False + Free {} -> False diff --git a/src/swarm-lang/Swarm/Language/Typed.hs b/src/swarm-lang/Swarm/Language/Typed.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Typed.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Language.Typed (Typed (..), value, polytype, requires) where + +import Control.Lens (makeLenses) +import Data.Aeson (ToJSON) +import Data.Aeson.Types (FromJSON) +import GHC.Generics (Generic) +import Swarm.Language.Requirements.Type (Requirements) +import Swarm.Language.Types (Polytype) + +-- | A value, or a hole, or something else that has its type & requirements fixed +data Typed v = Typed + { _value :: v + , _polytype :: Polytype + , _requires :: Requirements + } + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +makeLenses ''Typed diff --git a/src/swarm-lang/Swarm/Language/Types.hs b/src/swarm-lang/Swarm/Language/Types.hs new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Types.hs @@ -0,0 +1,650 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types for the Swarm programming language and related utilities. +module Swarm.Language.Types ( + -- * Basic definitions + + -- ** Base types and type constructors + BaseTy (..), + baseTyName, + TyCon (..), + Arity (..), + tcArity, + Var, + + -- ** Type structure functor + TypeF (..), + + -- ** Recursive types + Nat (..), + natToInt, + unfoldRec, + SubstRec (..), + + -- * @Type@ + Type, + tyVars, + pattern TyConApp, + pattern TyBase, + pattern TyVar, + pattern TyVoid, + pattern TyUnit, + pattern TyInt, + pattern TyText, + pattern TyDir, + pattern TyBool, + pattern TyActor, + pattern TyKey, + pattern (:+:), + pattern (:*:), + pattern (:->:), + pattern TyRcd, + pattern TyCmd, + pattern TyDelay, + pattern TyUser, + pattern TyRec, + + -- * @UType@ + IntVar (..), + UType, + pattern UTyConApp, + pattern UTyBase, + pattern UTyVar, + pattern UTyVoid, + pattern UTyUnit, + pattern UTyInt, + pattern UTyText, + pattern UTyDir, + pattern UTyBool, + pattern UTyActor, + pattern UTyKey, + pattern UTySum, + pattern UTyProd, + pattern UTyFun, + pattern UTyRcd, + pattern UTyCmd, + pattern UTyDelay, + pattern UTyUser, + pattern UTyRec, + + -- ** Utilities + ucata, + mkVarName, + fuvs, + + -- * Polytypes + Poly (..), + Polytype, + pattern PolyUnit, + UPolytype, + + -- * Contexts + TCtx, + UCtx, + + -- * User type definitions + TydefInfo (..), + tydefType, + tydefArity, + substTydef, + expandTydef, + elimTydef, + TDCtx, + + -- * WHNF + whnfType, + + -- * The 'WithU' class + WithU (..), +) where + +import Control.Algebra (Has, run) +import Control.Carrier.Reader (runReader) +import Control.Effect.Reader (Reader, ask) +import Control.Lens (makeLenses, view) +import Control.Monad.Free +import Data.Aeson (FromJSON (..), FromJSON1 (..), ToJSON (..), ToJSON1 (..), genericLiftParseJSON, genericLiftToJSON, genericParseJSON, genericToJSON) +import Data.Data (Data) +import Data.Eq.Deriving (deriveEq1) +import Data.Fix +import Data.Foldable (fold) +import Data.Kind qualified +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as M +import Data.Maybe (fromMaybe) +import Data.Ord.Deriving (deriveOrd1) +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 Swarm.Language.Context qualified as Ctx +import Swarm.Util (parens, showT) +import Swarm.Util.JSON (optionsMinimize, optionsUnwrapUnary) +import Text.Show.Deriving (deriveShow1) +import Witch + +------------------------------------------------------------ +-- Base types +------------------------------------------------------------ + +-- | Base types. +data BaseTy + = -- | The void type, with no inhabitants. + BVoid + | -- | The unit type, with a single inhabitant. + BUnit + | -- | Signed, arbitrary-size integers. + BInt + | -- | Unicode strings. + BText + | -- | Directions. + BDir + | -- | Booleans. + BBool + | -- | "Actors", i.e. anything that can do stuff. Internally, these + -- are all just "robots", but we give them a more generic + -- in-game name because they could represent other things like + -- aliens, animals, seeds, ... + BActor + | -- | Keys, i.e. things that can be pressed on the keyboard + BKey + deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic, FromJSON, ToJSON) + +baseTyName :: BaseTy -> Text +baseTyName = into @Text . drop 1 . show + +------------------------------------------------------------ +-- Type constructors +------------------------------------------------------------ + +-- | Type constructors. +data TyCon + = -- | Base types are (nullary) type constructors. + TCBase BaseTy + | -- | Command types. + TCCmd + | -- | Delayed computations. + TCDelay + | -- | Sum types. + TCSum + | -- | Product types. + TCProd + | -- | Function types. + TCFun + | -- | User-defined type constructor. + TCUser Var + deriving (Eq, Ord, Show, Data, Generic) + +instance ToJSON TyCon where + toJSON = genericToJSON optionsMinimize + +instance FromJSON TyCon where + parseJSON = genericParseJSON optionsMinimize + +-- | 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) + +instance ToJSON Arity where + toJSON = genericToJSON optionsUnwrapUnary + +instance FromJSON Arity where + parseJSON = genericParseJSON optionsUnwrapUnary + +------------------------------------------------------------ +-- Types +------------------------------------------------------------ + +-- | Peano naturals, for use as de Bruijn indices in recursive types. +data Nat where + NZ :: Nat + NS :: Nat -> Nat + deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON) + +natToInt :: Nat -> Int +natToInt NZ = 0 +natToInt (NS n) = 1 + natToInt n + +-- | A "structure functor" encoding the shape of type expressions. +-- Actual types are then represented by taking a fixed point of this +-- functor. We represent types in this way, via a "two-level type", +-- so that we can easily use generic recursion schemes to implement +-- things like substitution. +data TypeF t + = -- | A type constructor applied to some type arguments. For now, + -- all type constructor applications are required to be fully + -- saturated (higher kinds are not supported), so we just + -- directly store a list of all arguments (as opposed to + -- iterating binary application). + TyConF TyCon [t] + | -- | A type variable. + TyVarF Var + | -- | Record type. + TyRcdF (Map Var t) + | -- | A recursive type variable bound by an enclosing Rec, + -- represented by a de Bruijn index. + TyRecVarF Nat + | -- | Recursive type. The variable is just a suggestion for a name to use + -- 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) + +deriveEq1 ''TypeF +deriveOrd1 ''TypeF +deriveShow1 ''TypeF + +instance ToJSON1 TypeF where + liftToJSON = genericLiftToJSON optionsMinimize + +instance FromJSON1 TypeF where + liftParseJSON = genericLiftParseJSON optionsMinimize + +-- | @Type@ is now defined as the fixed point of 'TypeF'. It would be +-- annoying to manually apply and match against 'Fix' constructors +-- everywhere, so we provide pattern synonyms that allow us to work +-- 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) + +newtype IntVar = IntVar Int + deriving (Show, Data, Eq, Ord) + +-- | '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 +-- 'TypeF'). +-- +-- Just as with 'Type', we provide a bunch of pattern synonyms for +-- working with 'UType' as if it were defined directly. +type UType = Free TypeF IntVar + +-- | A generic /fold/ for things defined via 'Free' (including, in +-- particular, 'UType'). +ucata :: Functor t => (v -> a) -> (t a -> a) -> Free t v -> a +ucata f _ (Pure v) = f v +ucata f g (Free t) = g (fmap (ucata f g) t) + +-- | A quick-and-dirty method for turning an 'IntVar' (used internally +-- 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)) + +-- | Get all the free unification variables in a 'UType'. +fuvs :: UType -> Set IntVar +fuvs = ucata S.singleton fold + +-- | For convenience, so we can write /e.g./ @"a"@ instead of @TyVar "a"@. +instance IsString Type where + fromString x = TyVar (from @String x) + +instance IsString UType where + fromString x = UTyVar (from @String x) + +------------------------------------------------------------ +-- Generic folding over type representations +------------------------------------------------------------ + +class Typical t where + foldT :: (TypeF t -> t) -> t -> t + rollT :: TypeF t -> t + fromType :: Type -> t + +instance Typical Type where + foldT = foldFix + rollT = Fix + fromType = id + +instance Typical UType where + foldT = ucata Pure + rollT = Free + fromType = toU + +------------------------------------------------------------ +-- 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) + +-- | A polytype without unification variables. +type Polytype = Poly Type + +-- | A polytype with unification variables. +type UPolytype = Poly UType + +------------------------------------------------------------ +-- WithU +------------------------------------------------------------ + +-- | In several cases we have two versions of something: a "normal" +-- version, and a @U@ version with unification variables in it +-- (/e.g./ 'Type' vs 'UType', 'Polytype' vs 'UPolytype', 'TCtx' vs +-- 'UCtx'). This class abstracts over the process of converting back +-- and forth between them. +-- +-- In particular, @'WithU' t@ represents the fact that the type @t@ +-- also has a @U@ counterpart, with a way to convert back and forth. +-- Note, however, that converting back may be "unsafe" in the sense +-- that it requires an extra burden of proof to guarantee that it is +-- used only on inputs that are safe. +class WithU t where + -- | The associated "@U@-version" of the type @t@. + type U t :: Data.Kind.Type + + -- | Convert from @t@ to its associated "@U@-version". This + -- direction is always safe (we simply have no unification + -- variables even though the type allows it). + toU :: t -> U t + + -- | Convert from the associated "@U@-version" back to @t@. + -- Generally, this direction requires somehow knowing that there + -- are no longer any unification variables in the value being + -- converted. + fromU :: U t -> Maybe t + +-- | 'Type' is an instance of 'WithU', with associated type 'UType'. +instance WithU Type where + type U Type = UType + toU = foldFix Free + fromU = ucata (const Nothing) (fmap wrapFix . sequence) + +-- | A 'WithU' instance can be lifted through any functor (including, +-- in particular, 'Ctx' and 'Poly'). +instance (WithU t, Traversable f) => WithU (f t) where + type U (f t) = f (U t) + toU = fmap toU + fromU = traverse fromU + +------------------------------------------------------------ +-- Pattern synonyms +------------------------------------------------------------ + +-------------------------------------------------- +-- Type + +pattern TyConApp :: TyCon -> [Type] -> Type +pattern TyConApp c tys = Fix (TyConF c tys) + +pattern TyBase :: BaseTy -> Type +pattern TyBase b = TyConApp (TCBase b) [] + +pattern TyVar :: Var -> Type +pattern TyVar v = Fix (TyVarF v) + +pattern TyVoid :: Type +pattern TyVoid = TyBase BVoid + +pattern TyUnit :: Type +pattern TyUnit = TyBase BUnit + +pattern TyInt :: Type +pattern TyInt = TyBase BInt + +pattern TyText :: Type +pattern TyText = TyBase BText + +pattern TyDir :: Type +pattern TyDir = TyBase BDir + +pattern TyBool :: Type +pattern TyBool = TyBase BBool + +pattern TyActor :: Type +pattern TyActor = TyBase BActor + +pattern TyKey :: Type +pattern TyKey = TyBase BKey + +infixr 5 :+: + +pattern (:+:) :: Type -> Type -> Type +pattern ty1 :+: ty2 = TyConApp TCSum [ty1, ty2] + +infixr 6 :*: + +pattern (:*:) :: Type -> Type -> Type +pattern ty1 :*: ty2 = TyConApp TCProd [ty1, ty2] + +infixr 1 :->: + +pattern (:->:) :: Type -> Type -> Type +pattern ty1 :->: ty2 = TyConApp TCFun [ty1, ty2] + +pattern TyRcd :: Map Var Type -> Type +pattern TyRcd m = Fix (TyRcdF m) + +pattern TyCmd :: Type -> Type +pattern TyCmd ty = TyConApp TCCmd [ty] + +pattern TyDelay :: Type -> Type +pattern TyDelay ty = TyConApp TCDelay [ty] + +pattern TyUser :: Var -> [Type] -> Type +pattern TyUser v tys = TyConApp (TCUser v) tys + +pattern TyRec :: Var -> Type -> Type +pattern TyRec x ty = Fix (TyRecF x ty) + +-------------------------------------------------- +-- UType + +pattern UTyConApp :: TyCon -> [UType] -> UType +pattern UTyConApp c tys = Free (TyConF c tys) + +pattern UTyBase :: BaseTy -> UType +pattern UTyBase b = UTyConApp (TCBase b) [] + +pattern UTyVar :: Var -> UType +pattern UTyVar v = Free (TyVarF v) + +pattern UTyVoid :: UType +pattern UTyVoid = UTyBase BVoid + +pattern UTyUnit :: UType +pattern UTyUnit = UTyBase BUnit + +pattern UTyInt :: UType +pattern UTyInt = UTyBase BInt + +pattern UTyText :: UType +pattern UTyText = UTyBase BText + +pattern UTyDir :: UType +pattern UTyDir = UTyBase BDir + +pattern UTyBool :: UType +pattern UTyBool = UTyBase BBool + +pattern UTyActor :: UType +pattern UTyActor = UTyBase BActor + +pattern UTyKey :: UType +pattern UTyKey = UTyBase BKey + +pattern UTySum :: UType -> UType -> UType +pattern UTySum ty1 ty2 = UTyConApp TCSum [ty1, ty2] + +pattern UTyProd :: UType -> UType -> UType +pattern UTyProd ty1 ty2 = UTyConApp TCProd [ty1, ty2] + +pattern UTyFun :: UType -> UType -> UType +pattern UTyFun ty1 ty2 = UTyConApp TCFun [ty1, ty2] + +pattern UTyRcd :: Map Var UType -> UType +pattern UTyRcd m = Free (TyRcdF m) + +pattern UTyCmd :: UType -> UType +pattern UTyCmd ty = UTyConApp TCCmd [ty] + +pattern UTyDelay :: UType -> UType +pattern UTyDelay ty = UTyConApp TCDelay [ty] + +pattern UTyUser :: Var -> [UType] -> UType +pattern UTyUser v tys = UTyConApp (TCUser v) tys + +pattern UTyRec :: Var -> UType -> UType +pattern UTyRec x ty = Free (TyRecF x ty) + +pattern PolyUnit :: Polytype +pattern PolyUnit = Forall [] (TyCmd TyUnit) + +------------------------------------------------------------ +-- Contexts +------------------------------------------------------------ + +-- | 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 + +-- | 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 definitions +------------------------------------------------------------ + +data TydefInfo = TydefInfo + { _tydefType :: Polytype + , _tydefArity :: Arity + } + deriving (Eq, Show, Generic, Data, FromJSON, ToJSON) + +makeLenses ''TydefInfo + +-- | A @TDCtx@ is a mapping from user-defined type constructor names +-- to their definitions and arities/kinds. +type TDCtx = Ctx TydefInfo + +-- | 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 +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 + +-- | 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) + where + argMap = M.fromList $ zip as tys + + substF tyF@(TyVarF x) = case M.lookup x argMap of + Nothing -> rollT tyF + Just ty' -> ty' + substF tyF = rollT tyF + +-- | Replace a type alias with its definition everywhere it occurs +-- 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 + where + substF = \case + TyConF (TCUser u) tys | u == x -> substTydef tdInfo tys + tyF -> rollT tyF + +------------------------------------------------------------ +-- Arity +------------------------------------------------------------ + +-- | The arity, /i.e./ number of type arguments, of each type +-- constructor. Eventually, if we generalize to higher-kinded +-- types, we'll need to upgrade this to return a full-fledged kind +-- instead of just an arity. +tcArity :: TDCtx -> TyCon -> Maybe Arity +tcArity tydefs = + fmap Arity . \case + TCBase _ -> Just 0 + TCCmd -> Just 1 + TCDelay -> Just 1 + 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) + +------------------------------------------------------------ +-- Reducing types to WHNF +------------------------------------------------------------ + +-- | Reduce a type to weak head normal form, i.e. keep unfold type +-- aliases and recursive types just until the top-level constructor +-- of the type is neither @rec@ nor an application of a 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 + 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 new file mode 100644 --- /dev/null +++ b/src/swarm-lang/Swarm/Language/Value.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Values and environments used for interpreting the Swarm language. +module Swarm.Language.Value ( + -- * Values + Value (..), + prettyValue, + valueToTerm, + + -- * Environments + Env, + emptyEnv, + envTypes, + envReqs, + envVals, + envTydefs, + lookupValue, + addBinding, + addValueBinding, + addTydef, +) where + +import Control.Lens hiding (Const) +import Data.Bool (bool) +import Data.List (foldl') +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Set.Lens (setOf) +import Data.Text (Text) +import GHC.Generics (Generic) +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) + +-- | A /value/ is a term that cannot (or does not) take any more +-- evaluation steps on its own. +data Value where + -- | The unit value. + VUnit :: Value + -- | An integer. + VInt :: Integer -> Value + -- | Literal text. + VText :: Text -> Value + -- | A direction. + VDir :: Direction -> Value + -- | A boolean. + VBool :: Bool -> Value + -- | A reference to a robot. + VRobot :: Int -> Value + -- | An injection into a sum type. False = left, True = right. + VInj :: Bool -> Value -> Value + -- | A pair. + VPair :: Value -> Value -> Value + -- | A /closure/, representing a lambda term along with an + -- environment containing bindings for any free variables in the + -- body of the lambda. + VClo :: Var -> Term -> Env -> Value + -- | An application of a constant to some value arguments, + -- potentially waiting for more arguments. If a constant + -- application is fully saturated (as defined by its 'arity'), + -- whether it is a value or not depends on whether or not it + -- represents a command (as defined by 'isCmd'). If a command + -- (e.g. 'Build'), it is a value, and awaits an 'Swarm.Game.CESK.FExec' frame + -- which will cause it to execute. Otherwise (e.g. 'If'), it is + -- not a value, and will immediately reduce. + VCApp :: Const -> [Value] -> Value + -- | An unevaluated bind expression, waiting to be executed, of the + -- form /i.e./ @c1 ; c2@ or @x <- c1; c2@. We also store an 'Env' + -- in which to interpret the commands. + VBind :: Maybe Var -> Maybe Polytype -> Maybe Requirements -> Term -> Term -> Env -> Value + -- | A (non-recursive) delayed term, along with its environment. If + -- a term would otherwise be evaluated but we don't want it to be + -- (/e.g./ as in the case of arguments to an 'if', or a recursive + -- binding), we can stick a 'TDelay' on it, which turns it into a + -- value. Delayed terms won't be evaluated until 'Force' is + -- applied to them. + VDelay :: Term -> Env -> Value + -- | A reference to a memory cell in the store. + VRef :: Int -> Value + -- | An indirection to a value stored in a memory cell. The + -- difference between VRef and VIndir is that VRef is a "real" + -- value (of Ref type), whereas VIndir is just a placeholder. If + -- a VRef is encountered during evaluation, it is the final + -- result; if VIndir is encountered during evaluation, the value + -- it points to should be looked up. + VIndir :: Int -> Value + -- | A record value. + VRcd :: Map Var Value -> Value + -- | A keyboard input. + VKey :: KeyCombo -> Value + -- | A 'requirements' command awaiting execution. + VRequirements :: Text -> Term -> Env -> Value + -- | A 'suspend' command awaiting execution. + VSuspend :: Term -> Env -> Value + -- | A special value representing a program that terminated with + -- an exception. + VExc :: Value + -- | A special value used temporarily as the value for a variable + -- bound by a recursive let, while its definition is being + -- evaluated. If the variable is ever referenced again while its + -- value is still 'VBlackhole', that means it depends on itself in + -- a way that would trigger an infinite loop, and we can signal an + -- error. (Of course, we + -- .) + VBlackhole :: Value + deriving (Eq, Show, Generic) + +-- | A value context is a mapping from variable names to their runtime +-- values. +type VCtx = Ctx Value + +-------------------------------------------------- +-- Environments +-------------------------------------------------- + +-- | An environment is a record that stores relevant information for +-- all the variables currently in scope. +data Env = Env + { _envTypes :: TCtx + -- ^ Map variables to their types. + , _envReqs :: ReqCtx + -- ^ Map variables to the capabilities required to evaluate/execute + -- them. + , _envVals :: VCtx + -- ^ Map variables to their values. + , _envTydefs :: TDCtx + -- ^ Type synonym definitions. + } + deriving (Eq, Show, Generic) + +makeLenses ''Env + +emptyEnv :: Env +emptyEnv = Env Ctx.empty Ctx.empty Ctx.empty Ctx.empty + +lookupValue :: Var -> Env -> Maybe Value +lookupValue x e = Ctx.lookup x (e ^. envVals) + +addBinding :: Var -> Typed Value -> Env -> Env +addBinding x v = at x ?~ v + +-- | Add a binding of a variable to a value *only* (no type and +-- requirements). NOTE that if we then try to look up the variable +-- name using the `At` instance for `Env`, it will report `Nothing`! +-- `lookupValue` will work though. +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 + +type instance Index Env = Ctx.Var +type instance IxValue Env = Typed Value + +instance Ixed Env +instance At Env where + at name = lens getter setter + where + getter ctx = + do + typ <- Ctx.lookup name (ctx ^. envTypes) + val <- Ctx.lookup name (ctx ^. envVals) + req <- Ctx.lookup name (ctx ^. envReqs) + return $ Typed val typ req + setter ctx Nothing = + ctx + & envTypes + %~ Ctx.delete name + & envVals + %~ Ctx.delete name + & envReqs + %~ Ctx.delete name + setter ctx (Just (Typed val typ req)) = + ctx + & envTypes + %~ Ctx.addBinding name typ + & envVals + %~ Ctx.addBinding name val + & envReqs + %~ Ctx.addBinding name req + +------------------------------------------------------------ +-- Pretty-printing for values +------------------------------------------------------------ + +-- | Pretty-print a value. +prettyValue :: Value -> Text +prettyValue = prettyText . valueToTerm + +-- | Inject a value back into a term. +valueToTerm :: Value -> Term +valueToTerm = \case + VUnit -> TUnit + VInt n -> TInt n + VText s -> TText s + VDir d -> TDir d + VBool b -> TBool b + VRobot r -> TRobot r + VInj s v -> TApp (TConst (bool Inl Inr s)) (valueToTerm v) + VPair v1 v2 -> TPair (valueToTerm v1) (valueToTerm v2) + VClo x t e -> + M.foldrWithKey + ( \y v -> case v of + VIndir {} -> id + _ -> TLet LSLet False y Nothing Nothing (valueToTerm v) + ) + (TLam x Nothing t) + (M.restrictKeys (Ctx.unCtx (e ^. envVals)) (S.delete x (setOf freeVarsV (Syntax' NoLoc t Empty ())))) + VCApp c vs -> foldl' TApp (TConst c) (reverse (map valueToTerm vs)) + VBind mx mty mreq c1 c2 _ -> TBind mx mty mreq c1 c2 + VDelay t _ -> TDelay t + VRef n -> TRef n + VIndir n -> TRef n + VRcd m -> TRcd (Just . valueToTerm <$> m) + VKey kc -> TApp (TConst Key) (TText (prettyKeyCombo kc)) + VRequirements x t _ -> TRequirements x t + VSuspend t _ -> TSuspend t + VExc -> TConst Undefined + VBlackhole -> TConst Undefined diff --git a/src/swarm-scenario/Swarm/Constant.hs b/src/swarm-scenario/Swarm/Constant.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Constant.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Constants used throughout the UI and game +-- +-- Constants used throughout the UI and game. +module Swarm.Constant where + +import Data.Text (Text) + +-- * Website constants + +-- $convention +-- By convention, all URL constants include trailing slashes +-- when applicable. + +swarmDiscord :: Text +swarmDiscord = "https://discord.gg/kp8MuSgkPw" + +-- | The URL for the Swarm repository. +swarmRepoUrl :: Text +swarmRepoUrl = "https://github.com/swarm-game/swarm/" + +-- | The URL for the Swarm wiki. +wikiUrl :: Text +wikiUrl = swarmRepoUrl <> "wiki/" + +-- | The URL for the Swarm commands cheat sheet. +wikiCheatSheet :: Text +wikiCheatSheet = wikiUrl <> "Commands-Cheat-Sheet" diff --git a/src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs b/src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs @@ -0,0 +1,138 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: All achievements enumerated +-- +-- Definitions of all possible achievements. +module Swarm.Game.Achievement.Definitions ( + -- * Achievements + CategorizedAchievement (..), + GlobalAchievement (..), + GameplayAchievement (..), + listAchievements, + + -- * Achievement info + ExpectedEffort (..), + Quotation (..), + FlavorText (..), + AchievementInfo (..), + ValidityConditions (..), + SystemTypeValidity (..), + GameplayModeValidity (..), +) where + +import Data.Aeson +import Data.List.Extra (enumerate) +import Data.Text (Text) +import GHC.Generics (Generic) +import Swarm.Language.Syntax (Syntax) +import Swarm.Language.Text.Markdown (Document) + +-- | How hard do we expect the achievement to be? +data ExpectedEffort + = Trivial + | Easy + | Moderate + | Gruelling + deriving (Eq, Ord, Show, Bounded, Enum, Generic, FromJSON, ToJSON) + +-- | A quotation to spice up the description of an achievement. +data Quotation = Quotation + { attribution :: Text + , content :: Text + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +-- | Flavor text to spice up the description of an achievement, either +-- freeform text or a quotation. +data FlavorText + = Freeform (Document Syntax) + | FTQuotation Quotation + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +data SystemTypeValidity + = ValidForSystemRobot + | OnlyPlayerRobot + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +data GameplayModeValidity + = ValidInCreativeMode + | ExcludesCreativeMode + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +data ValidityConditions = ValidityConditions SystemTypeValidity GameplayModeValidity + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +-- | Information about an achievement. See +-- "Swarm.Game.Achievement.Description" for a mapping from +-- achievements to an corresponding 'AchievementInfo' record. +data AchievementInfo = AchievementInfo + { title :: Text + -- ^ Guidelines: + -- + -- * prefer puns, pop culture references, etc. + -- * should be a phrase in Title Case. + -- * For achievements that are "obfuscated", this can be + -- a vague "clue" as to what the attainment entails. + , humorousElaboration :: Maybe FlavorText + -- ^ Explain the reference, e.g. in the form of a full quote + -- from a movie, or something you might find + -- in a fortune cookie + , attainmentProcess :: Document Syntax + -- ^ Precisely what must be done to obtain this achievement. + , effort :: ExpectedEffort + -- ^ How hard the achievement is expected to be. + , isObfuscated :: Bool + -- ^ Hides the attainment process until after the achievement is attained. + -- Best when the title + elaboration constitute a good clue. + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +-- | An achievement, categorized as either global or gameplay. +data CategorizedAchievement + = GlobalAchievement GlobalAchievement + | GameplayAchievement GameplayAchievement + deriving (Eq, Ord, Show, Generic) + +categorizedAchievementJsonOptions :: Options +categorizedAchievementJsonOptions = + defaultOptions + { sumEncoding = UntaggedValue + } + +instance ToJSON CategorizedAchievement where + toJSON = genericToJSON categorizedAchievementJsonOptions + +instance FromJSON CategorizedAchievement where + parseJSON = genericParseJSON categorizedAchievementJsonOptions + +-- | Achievements that entail some aggregate of actions across +-- scenarios, or are independent of any particular scenario. +data GlobalAchievement + = CompletedSingleTutorial + | CompletedAllTutorials + | LookedAtAboutScreen + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + +instance FromJSON GlobalAchievement +instance ToJSON GlobalAchievement + +-- | Achievements obtained while playing a single scenario. +data GameplayAchievement + = CraftedBitcoin + | RobotIntoWater + | AttemptSelfDestructBase + | DestroyedBase + | LoseScenario + | GetDisoriented + | SwapSame + | GaveToSelf + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + +instance FromJSON GameplayAchievement +instance ToJSON GameplayAchievement + +-- | List of all possible achievements. +listAchievements :: [CategorizedAchievement] +listAchievements = + map GlobalAchievement enumerate + <> map GameplayAchievement enumerate diff --git a/src/swarm-scenario/Swarm/Game/Device.hs b/src/swarm-scenario/Swarm/Game/Device.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Device.hs @@ -0,0 +1,134 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A device is an entity that provides capabilities. +-- +-- Some capabilities have a cost to exercise. +-- Items will be consumed from the inventory for +-- invoking a command that utilizes a given capability. +module Swarm.Game.Device ( + SingleEntityCapabilities, + MultiEntityCapabilities, + Capabilities (..), + DeviceUseCost (..), + ExerciseCost (..), + CommandsAndCost (..), + getCapabilitySet, + zeroCostCapabilities, + commandsForDeviceCaps, +) +where + +import Control.Applicative ((<|>)) +import Data.Function (on) +import Data.Hashable +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Vector qualified as V +import Data.Yaml +import GHC.Generics (Generic) +import Swarm.Game.Ingredients +import Swarm.Language.Capability (Capability, constByCaps) +import Swarm.Language.Syntax (Const) + +-- | The 'Capabilities e' wrapper type stores information of type @e@ for each +-- of some set of capabilities. +-- For example, @e@ could be a list of ingredients needed to exercise a +-- capability, or a set of devices capable of providing a capability. +newtype Capabilities e = Capabilities + { getMap :: Map Capability e + } + deriving (Show, Eq, Generic, ToJSON, Hashable, Functor, Foldable, Traversable) + +-- | Get the set of capabilities about which we are storing information. +getCapabilitySet :: Capabilities e -> Set Capability +getCapabilitySet (Capabilities m) = M.keysSet m + +-- | Records an 'ExerciseCost', i.e. list of consumed ingredients, per capability that can be exercised. This represents information about a single entity/device, which can provide multiple capabilities (with a different exercise cost for each). +type SingleEntityCapabilities e = Capabilities (ExerciseCost e) + +-- | Records a list of devices capable of providing each capability; +-- along with each device is recorded the 'ExerciseCost' needed to use +-- that device to achieve the given capability. +-- +-- See 'DeviceUseCost' for explanation of type parameters. +type MultiEntityCapabilities e en = Capabilities (NonEmpty (DeviceUseCost e en)) + +-- | Create a default 'SingleEntityCapabilities' map for a device which provides capabilities with no associated costs. +zeroCostCapabilities :: Set Capability -> SingleEntityCapabilities e +zeroCostCapabilities = Capabilities . M.fromSet (const $ ExerciseCost []) + +-- | Package together a capability and exercise cost; only used temporarily for parsing this information from JSON format. +data CapabilityCost e = CapabilityCost + { capability :: Capability + , cost :: IngredientList e + } + deriving (Generic, FromJSON) + +-- | First, attempt to parse capabilities as a list, interpreted as a set of capabilities with no exercise cost. +-- Otherwise, parse as a Map from capabilities to ingredients. +instance (FromJSON e) => FromJSON (SingleEntityCapabilities e) where + parseJSON x = + simpleList <|> (Capabilities <$> costMap) + where + simpleList = zeroCostCapabilities <$> parseJSON x + costMap = withArray "Capabilities" (fmap (M.fromList . map toMapEntry) . mapM parseJSON . V.toList) x + toMapEntry (CapabilityCost a b) = (a, ExerciseCost b) + +instance (Ord e, Semigroup e) => Semigroup (Capabilities e) where + Capabilities c1 <> Capabilities c2 = + Capabilities $ M.unionWith (<>) c1 c2 + +instance (Ord e, Semigroup e) => Monoid (Capabilities e) where + mempty = Capabilities mempty + +-- | Exercising a capability may have a cost, in the form of entities that must be consumed each time it is used. +newtype ExerciseCost e = ExerciseCost + { ingredients :: IngredientList e + } + deriving (Eq, Show, Generic, FromJSON, ToJSON, Hashable, Functor, Foldable, Traversable) + +-- | Sort 'ExerciseCost's by the total count of ingredients consumed. +instance (Eq e) => Ord (ExerciseCost e) where + compare = compare `on` (getCost . ingredients) + +-- | A device paired with a cost to use it. +-- +-- At scenario parse time, the type parameters @e@ and @en@ will stand for +-- 'Entity' and 'EntityName'. +-- This is because `ExerciseCost` is a member of the 'Entity' datatype, and +-- therefore can only refer to another 'Entity' by name before all 'Entity's +-- are parsed. +-- +-- However, after parse time, we are able to look up actual 'Entity' objects +-- by name, and therefore can instantiate 'ExerciseCost' with 'Entity' as +-- the type parameter. +-- Then the two type parameters of 'DeviceUseCost' are both of 'Entity' type. +data DeviceUseCost e en = DeviceUseCost + { device :: e + , useCost :: ExerciseCost en + } + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON, Functor, Foldable, Traversable) + +-- * Utils + +-- | A nonempty list of commands together with an exercise cost for using any of them (typically these will be a list of commands all requiring the same capability). +data CommandsAndCost e = CommandsAndCost + { commandCost :: ExerciseCost e + , enabledCommands :: NonEmpty Const + } + +-- | Given mapping from capabilities to their exercise costs provided by a single device, turn it into an mapping from capabilities to their exercise cost and enabled commands. +-- +-- NOTE: Because each 'Const' is mapped to at most one +-- 'Capability' by the 'constCaps' function, we know that +-- a given 'Const' will not appear more than once as a value in the 'Map' produced by +-- this function, i.e. for the capabilities provided by a single 'Entity` +-- ('SingleEntityCapabilities'). +commandsForDeviceCaps :: SingleEntityCapabilities e -> Capabilities (CommandsAndCost e) +commandsForDeviceCaps = Capabilities . M.mapMaybeWithKey f . getMap + where + f cap xc = + CommandsAndCost xc <$> M.lookup cap constByCaps diff --git a/src/swarm-scenario/Swarm/Game/Display.hs b/src/swarm-scenario/Swarm/Game/Display.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Display.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- Orphan Hashable instances needed to derive Hashable Display + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: TUI rendering of entities +-- +-- Utilities for describing how to display in-game entities in the TUI. +module Swarm.Game.Display ( + -- * The display record + Priority, + Attribute (..), + readAttribute, + Display, + ChildInheritance (..), + + -- ** Fields + defaultChar, + orientationMap, + curOrientation, + displayAttr, + displayPriority, + invisible, + childInheritance, + + -- ** Rendering + displayChar, + hidden, + + -- ** Construction + defaultTerrainDisplay, + defaultEntityDisplay, + defaultRobotDisplay, +) where + +import Control.Lens hiding (Const, from, (.=)) +import Control.Monad (when) +import Data.Hashable (Hashable) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Yaml +import GHC.Generics (Generic) +import Graphics.Text.Width +import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..)) +import Swarm.Util (maxOn, quote) +import Swarm.Util.Lens (makeLensesNoSigs) +import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE) + +-- | Display priority. Entities with higher priority will be drawn on +-- top of entities with lower priority. +type Priority = Int + +-- | An internal attribute name. +data Attribute = ADefault | ARobot | AEntity | AWorld Text + deriving (Eq, Ord, Show, Generic, Hashable) + +readAttribute :: Text -> Attribute +readAttribute = \case + "robot" -> ARobot + "entity" -> AEntity + "default" -> ADefault + w -> AWorld w + +instance FromJSON Attribute where + parseJSON = withText "attribute" $ pure . readAttribute + +instance ToJSON Attribute where + toJSON = \case + ADefault -> String "default" + ARobot -> String "robot" + AEntity -> String "entity" + AWorld w -> String w + +data ChildInheritance + = Invisible + | Inherit + | DefaultDisplay + deriving (Eq, Ord, Show, Generic, Hashable) + +-- | A record explaining how to display an entity in the TUI. +data Display = Display + { _defaultChar :: Char + , _orientationMap :: Map AbsoluteDir Char + , _curOrientation :: Maybe Direction + , _displayAttr :: Attribute + , _displayPriority :: Priority + , _invisible :: Bool + , _childInheritance :: ChildInheritance + } + deriving (Eq, Ord, Show, Generic, Hashable) + +instance Semigroup Display where + d1 <> d2 + | _invisible d1 = d2 + | _invisible d2 = d1 + | otherwise = maxOn _displayPriority d1 d2 + +makeLensesNoSigs ''Display + +-- | The default character to use for display. +defaultChar :: Lens' Display Char + +-- | For robots or other entities that have an orientation, this map +-- optionally associates different display characters with +-- different orientations. If an orientation is not in the map, +-- the 'defaultChar' will be used. +orientationMap :: Lens' Display (Map AbsoluteDir Char) + +-- | The display caches the current orientation of the entity, so we +-- know which character to use from the orientation map. +curOrientation :: Lens' Display (Maybe Direction) + +-- | The attribute to use for display. +displayAttr :: Lens' Display Attribute + +-- | This entity's display priority. Higher priorities are drawn +-- on top of lower. +displayPriority :: Lens' Display Priority + +-- | Whether the entity is currently invisible. +invisible :: Lens' Display Bool + +-- | For robots, whether children of this inherit the parent's display +childInheritance :: Lens' Display ChildInheritance + +instance FromJSON Display where + parseJSON v = runE (parseJSONE v) (defaultEntityDisplay ' ') + +instance FromJSONE Display Display where + parseJSONE = withObjectE "Display" $ \v -> do + defD <- getE + mc <- liftE $ v .:? "char" + + let c = fromMaybe (defD ^. defaultChar) mc + validateChar c + + let dOM = if isJust mc then mempty else defD ^. orientationMap + mapM_ validateChar $ M.elems dOM + + liftE $ do + let _defaultChar = c + _orientationMap <- v .:? "orientationMap" .!= dOM + _curOrientation <- v .:? "curOrientation" .!= (defD ^. curOrientation) + _displayAttr <- (v .:? "attr") .!= (defD ^. displayAttr) + _displayPriority <- v .:? "priority" .!= (defD ^. displayPriority) + _invisible <- v .:? "invisible" .!= (defD ^. invisible) + let _childInheritance = Inherit + pure Display {..} + where + validateChar c = + when (charWidth > 1) + . fail + . T.unpack + $ T.unwords + [ "Character" + , quote $ T.singleton c + , "is too wide:" + , T.pack $ show charWidth + ] + where + charWidth = safeWcwidth c + +instance ToJSON Display where + toJSON d = + object $ + [ "char" .= (d ^. defaultChar) + , "attr" .= (d ^. displayAttr) + , "priority" .= (d ^. 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) + +-- | Modify a display to use a @?@ character for entities that are +-- hidden/unknown. +hidden :: Display -> Display +hidden = (defaultChar .~ '?') . (curOrientation .~ Nothing) + +-- | The default way to display some terrain using the given character +-- and attribute, with priority 0. +defaultTerrainDisplay :: Attribute -> Display +defaultTerrainDisplay attr = + defaultEntityDisplay ' ' + & displayPriority .~ 0 + & displayAttr .~ attr + +-- | Construct a default display for an entity that uses only a single +-- display character, the default entity attribute, and priority 1. +defaultEntityDisplay :: Char -> Display +defaultEntityDisplay c = + Display + { _defaultChar = c + , _orientationMap = M.empty + , _curOrientation = Nothing + , _displayAttr = AEntity + , _displayPriority = 1 + , _invisible = False + , _childInheritance = Inherit + } + +-- | Construct a default robot display for a given orientation, with +-- display characters @"X^>v<"@, the default robot attribute, and +-- priority 10. +-- +-- Note that the 'defaultChar' is used for direction 'DDown' +-- and is overridden for the special base robot. +defaultRobotDisplay :: Display +defaultRobotDisplay = + Display + { _defaultChar = 'X' + , _orientationMap = + M.fromList + [ (DEast, '>') + , (DWest, '<') + , (DSouth, 'v') + , (DNorth, '^') + ] + , _curOrientation = Nothing + , _displayAttr = ARobot + , _displayPriority = 10 + , _invisible = False + , _childInheritance = Inherit + } + +instance Monoid Display where + mempty = defaultEntityDisplay ' ' & invisible .~ True diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -0,0 +1,863 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Object that exists in the world +-- +-- An 'Entity' represents an object that exists in the world. Each +-- entity has a way to be displayed, some metadata such as a name and +-- description, some properties, and possibly an inventory of other +-- entities. +-- +-- This module also defines the 'Inventory' type, since the two types +-- are mutually recursive (an inventory contains entities, which can +-- have inventories). +module Swarm.Game.Entity ( + -- * Entity properties + EntityName, + EntityProperty (..), + GrowthTime (..), + GrowthSpread (..), + Growth (..), + defaultGrowth, + Combustibility (..), + defaultCombustibility, + + -- * Entities + Entity, + mkEntity, + + -- ** Fields + -- $lenses + entityDisplay, + entityName, + entityPlural, + entityNameFor, + entityDescription, + entityTags, + entityOrientation, + entityGrowth, + entityCombustion, + entityYields, + entityProperties, + hasProperty, + entityCapabilities, + entityBiomes, + entityInventory, + entityHash, + + -- ** Entity map + EntityMap (..), + buildEntityMap, + lookupEntityE, + validateEntityAttrRefs, + loadEntities, + allEntities, + lookupEntityName, + devicesForCap, + + -- * Inventories + Inventory, + + -- ** Construction + empty, + singleton, + fromList, + fromElems, + + -- ** Lookup + lookup, + lookupByName, + countByName, + contains, + contains0plus, + elems, + isSubsetOf, + isEmpty, + inventoryCapabilities, + extantElemsWithCapability, + entitiesByCapability, + + -- ** Modification + insert, + insertCount, + delete, + deleteCount, + deleteAll, + union, + difference, +) where + +import Control.Algebra (Has) +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) +import Control.Carrier.Throw.Either (liftEither) +import Control.Effect.Lift (Lift, sendIO) +import Control.Effect.Throw (Throw, throwError) +import Control.Lens (Getter, Lens', lens, to, view, (^.)) +import Control.Monad (forM_, unless, (<=<)) +import Data.Bifunctor (first) +import Data.Char (toLower) +import Data.Either.Extra (maybeToEither) +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.Set (Set) +import Data.Set qualified as Set (fromList, member) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Yaml +import GHC.Generics (Generic) +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.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) + +------------------------------------------------------------ +-- Properties +------------------------------------------------------------ + +-- | A type representing entity names, currently a synonym for 'Text'. +-- In the future it is conceivable that it might become more complex. +type EntityName = Text + +-- | Various properties that an entity can have, which affect how +-- robots can interact with it. +data EntityProperty + = -- | Robots can't move onto a cell containing this entity. + Unwalkable + | -- | Robots can pick this up (via 'Swarm.Language.Syntax.Grab' or 'Swarm.Language.Syntax.Harvest'). + Pickable + | -- | Robots can 'Swarm.Language.Syntax.Push' this + Pushable + | -- | Obstructs the view of robots that attempt to "scout" + Opaque + | -- | Regrows from a seed after it is harvested. + Growable + | -- | Can burn when ignited (either via 'Swarm.Language.Syntax.Ignite' or by + -- an adjacent burning entity). + Combustible + | -- | Regenerates infinitely when grabbed or harvested. + Infinite + | -- | Robots drown if they walk on this without a boat. + Liquid + | -- | Robots automatically know what this is without having to scan it. + Known + deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable) + +instance ToJSON EntityProperty where + toJSON = String . from . map toLower . show + +instance FromJSON EntityProperty where + parseJSON = withText "EntityProperty" tryRead + where + tryRead :: Text -> Parser EntityProperty + tryRead t = case readMaybe . from . T.toTitle $ t of + Just c -> return c + Nothing -> failT ["Unknown entity property", t] + +data GrowthSpread = GrowthSpread + { spreadRadius :: Int + -- ^ in terms of manhattan distance + , spreadDensity :: Float + -- ^ average number of tiles within the + -- radius that will be seeded per + -- growth cycle + } + deriving (Eq, Ord, Show, Read, Generic, Hashable, ToJSON) + +instance FromJSON GrowthSpread where + parseJSON = withObject "GrowthSpread" $ \v -> do + spreadRadius <- v .: "radius" + spreadDensity <- v .: "density" + pure GrowthSpread {..} + +data Growth = Growth + { maturesTo :: Maybe EntityName + -- ^ Entity this turns into after growth is complete, + -- if something different than self + , growthSpread :: Maybe GrowthSpread + , growthTime :: GrowthTime + } + deriving (Eq, Ord, Show, Read, Generic, Hashable, ToJSON) + +instance FromJSON Growth where + parseJSON x = + (Growth Nothing Nothing <$> parseJSON x) + <|> parseFullGrowth x + where + parseFullGrowth = withObject "Growth" $ \v -> do + maturesTo <- v .:? "mature" + growthSpread <- v .:? "spread" + growthTime <- v .: "duration" + pure Growth {..} + +-- | How long an entity takes to regrow. This represents the minimum +-- and maximum amount of time taken by one growth stage (there are +-- two stages). The actual time for each stage will be chosen +-- uniformly at random between these two values. +newtype GrowthTime = GrowthTime (Integer, Integer) + deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON) + +-- | The default growth time (100, 200) for a growable entity with no +-- growth time specification. +defaultGrowthTime :: GrowthTime +defaultGrowthTime = GrowthTime (100, 200) + +defaultGrowth :: Growth +defaultGrowth = Growth Nothing Nothing defaultGrowthTime + +-- | Properties of combustion. +data Combustibility = Combustibility + { ignition :: Double + -- ^ Rate of ignition by a neighbor, per tick. + -- If this rate is denoted \(\lambda\), the probability of + -- ignition over a period of \(t\) ticks is \(1 - e^{-\lambda t}\). + -- See . + , duration :: (Integer, Integer) + -- ^ min and max tick counts for combustion to persist + , product :: Maybe EntityName + -- ^ what entity, if any, is left over after combustion + } + deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON) + +-- | The default combustion specification for a combustible entity +-- with no combustion specification: +-- +-- * ignition rate 0.5 +-- * duration (100, 200) +-- * product @ash@ +defaultCombustibility :: Combustibility +defaultCombustibility = Combustibility 0.5 (100, 200) (Just "ash") + +------------------------------------------------------------ +-- Entity +------------------------------------------------------------ + +-- | A record to hold information about an entity. +-- +-- The constructor for 'Entity' is intentionally not exported. To +-- construct one manually, use the 'mkEntity' function. +-- +-- There are two main constraints on the way entities are stored: +-- +-- 1. We want to be able to easily modify an entity in one +-- particular cell of the world (for example, painting one +-- tree red). +-- 2. In an inventory, we want to store identical entities only +-- once, along with a count. +-- +-- We could get (2) nicely by storing only names of entities, and +-- having a global lookup table from names to entity records. +-- However, storing names instead of actual entity records in the +-- world makes (1) more complex: every time we modify an entity we +-- would have to generate a fresh name for the modified entity and +-- add it to the global entity table. This approach is also +-- annoying because it means we can't just uses lenses to drill down +-- into the properties of an entity in the world or in an inventory, +-- but have to do an intermediate lookup in the global (mutable!) +-- entity table. +-- +-- On the other hand, if we just store entity records everywhere, +-- checking them for equality becomes expensive. Having an +-- inventory be a map with entities themselves as keys sounds awful. +-- +-- The solution we adopt here is that every @Entity@ record carries +-- along a hash value of all the other fields. We just assume that +-- these hashes are unique (a collision is of course possible but +-- extremely unlikely). Entities can be efficiently compared just +-- by looking at their hashes; they can be stored in a map using +-- hash values as keys; and we provide lenses which automatically +-- recompute the hash value when modifying a field of an entity +-- record. Note also that world storage is still efficient, too: +-- thanks to referential transparency, in practice most of the +-- entities stored in the world that are the same will literally +-- just be stored as pointers to the same shared record. +data Entity = Entity + { _entityHash :: Int + -- ^ A hash value computed from the other fields + , _entityDisplay :: Display + -- ^ The way this entity should be displayed on the world map. + , _entityName :: EntityName + -- ^ The name of the entity, used /e.g./ in an inventory display. + , _entityPlural :: Maybe Text + -- ^ The plural of the entity name, in case it is irregular. If + -- this field is @Nothing@, default pluralization heuristics + -- will be used (see 'plural'). + , _entityDescription :: Document Syntax + -- ^ A longer-form description. Each 'Text' value is one + -- paragraph. + , _entityTags :: Set Text + -- ^ A set of categories to which the entity belongs + , _entityOrientation :: Maybe Heading + -- ^ The entity's orientation (if it has one). For example, when + -- a robot moves, it moves in the direction of its orientation. + , _entityGrowth :: Maybe Growth + -- ^ If this entity grows, how long does it take? + , _entityCombustion :: Maybe Combustibility + -- ^ If this entity is combustible, how spreadable is it? + , _entityYields :: Maybe Text + -- ^ The name of a different entity obtained when this entity is + -- grabbed. + , _entityProperties :: Set EntityProperty + -- ^ Properties of the entity. + , _entityBiomes :: Set TerrainType + -- ^ Terrain in which growth may occur. Empty means no restrictions. + , _entityCapabilities :: SingleEntityCapabilities EntityName + -- ^ Capabilities provided by this entity. + , _entityInventory :: Inventory + -- ^ Inventory of other entities held by this entity. + } + -- Note that an entity does not have a location, because the + -- location of an entity is implicit in the way it is stored (by + -- location). + + deriving (Show, Generic) + +-- | The @Hashable@ instance for @Entity@ ignores the cached hash +-- value and simply combines the other fields. +instance Hashable Entity where + hashWithSalt s (Entity _ disp nm pl descr tags orient grow combust yld props biomes caps inv) = + s + `hashWithSalt` disp + `hashWithSalt` nm + `hashWithSalt` pl + `hashWithSalt` docToText descr + `hashWithSalt` tags + `hashWithSalt` orient + `hashWithSalt` grow + `hashWithSalt` combust + `hashWithSalt` yld + `hashWithSalt` props + `hashWithSalt` biomes + `hashWithSalt` caps + `hashWithSalt` inv + +-- | Entities are compared by hash for efficiency. +instance Eq Entity where + (==) = (==) `on` _entityHash + +-- | Entities are compared by hash for efficiency. +instance Ord Entity where + compare = compare `on` _entityHash + +-- | Recompute an entity's hash value. +rehashEntity :: Entity -> Entity +rehashEntity e = e {_entityHash = hash e} + +-- | Create an entity with no orientation, an empty inventory, +-- providing no capabilities (automatically filling in the hash +-- value). +mkEntity :: + -- | Display + Display -> + -- | Entity name + Text -> + -- | Entity description + Document Syntax -> + -- | Properties + [EntityProperty] -> + -- | Capabilities + Set Capability -> + Entity +mkEntity disp nm descr props caps = + rehashEntity $ + Entity + 0 + disp + nm + Nothing + descr + mempty + Nothing + Nothing + Nothing + Nothing + (Set.fromList props) + mempty + (zeroCostCapabilities caps) + empty + +------------------------------------------------------------ +-- Entity map +------------------------------------------------------------ + +-- | An 'EntityMap' is a data structure containing all the loaded +-- entities, allowing them to be looked up either by name or by what +-- capabilities they provide (if any). +-- +-- Also preserves the original definition order from the scenario +-- file and canonical definition list. +-- This enables scenario authors to specify iteration order of +-- the 'Swarm.Language.Syntax.TagMembers' command. +data EntityMap = EntityMap + { entitiesByName :: Map EntityName Entity + , entitiesByCap :: MultiEntityCapabilities Entity Entity + , entityDefinitionOrder :: [Entity] + } + 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'). +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) + +instance Monoid EntityMap where + mempty = EntityMap M.empty mempty [] + mappend = (<>) + +-- | Get a list of all the entities in the entity map. +allEntities :: EntityMap -> [Entity] +allEntities (EntityMap _ _ x) = x + +-- | Find an entity with the given name. +lookupEntityName :: Text -> EntityMap -> Maybe Entity +lookupEntityName nm = M.lookup nm . entitiesByName + +-- | Find all entities which are devices that provide the given +-- capability. +devicesForCap :: Capability -> EntityMap -> [Entity] +devicesForCap cap = maybe [] (NE.toList . NE.map device) . M.lookup cap . getMap . entitiesByCap + +-- | Validates references to 'Display' attributes +validateEntityAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m () +validateEntityAttrRefs validAttrs es = + forM_ namedEntities $ \(eName, ent) -> + case ent ^. entityDisplay . displayAttr of + AWorld n -> + unless (Set.member (WorldAttr $ T.unpack n) validAttrs) + . throwError + . CustomMessage + $ T.unwords + [ "Nonexistent attribute" + , quote n + , "referenced by entity" + , quote eName + ] + _ -> return () + where + namedEntities = map (view entityName &&& id) es + +-- | Build an 'EntityMap' from a list of entities. The idea is that +-- this will be called once at startup, when loading the entities +-- 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 + case combineEntityCapsM entsByName es of + Left x -> throwError $ CustomMessage x + Right ebc -> + return $ + EntityMap + { entitiesByName = entsByName + , entitiesByCap = ebc + , entityDefinitionOrder = es + } + where + namedEntities = map (view entityName &&& id) es + entsByName = M.fromList namedEntities + +-- Compare to 'combineEntityCapsM' +combineEntityCaps :: + [Entity] -> + MultiEntityCapabilities Entity EntityName +combineEntityCaps = mconcat . map mkForEntity + where + mkForEntity e = f <$> e ^. entityCapabilities + where + f = pure . DeviceUseCost e + +lookupEntityE :: Map Text b -> Text -> Either Text b +lookupEntityE em en = + maybeToEither err $ M.lookup en em + where + err = T.unwords [quote en, "is not a valid entity name"] + +combineEntityCapsM :: + Map EntityName Entity -> + [Entity] -> + Either Text (MultiEntityCapabilities Entity Entity) +combineEntityCapsM em = + fmap mconcat . mapM mkForEntity + where + transformCaps = (traverse . traverse) (lookupEntityE em) + + mkForEntity e = + fmap f <$> transformCaps (e ^. entityCapabilities) + where + f = pure . DeviceUseCost e + +------------------------------------------------------------ +-- Serialization +------------------------------------------------------------ + +instance FromJSON Entity where + parseJSON = withObject "Entity" $ \v -> do + let _entityHash = 0 + _entityDisplay <- v .: "display" + _entityName <- v .: "name" + _entityPlural <- v .:? "plural" + _entityDescription <- v .: "description" + _entityTags <- v .:? "tags" .!= mempty + _entityOrientation <- v .:? "orientation" + _entityGrowth <- v .:? "growth" + _entityCombustion <- v .:? "combustion" + _entityYields <- v .:? "yields" + _entityProperties <- v .:? "properties" .!= mempty + _entityBiomes <- v .:? "biomes" .!= mempty + _entityCapabilities <- v .:? "capabilities" .!= Capabilities mempty + let _entityInventory = empty + pure $ rehashEntity Entity {..} + +-- | If we have access to an 'EntityMap', we can parse the name of an +-- 'Entity' as a string and look it up in the map. +instance FromJSONE EntityMap Entity where + parseJSONE = withTextE "entity name" $ \name -> + E $ \em -> case lookupEntityName name em of + Nothing -> failT ["Unknown entity:", name] + Just e -> return e + +instance ToJSON Entity where + toJSON e = + object $ + [ "display" .= (e ^. entityDisplay) + , "name" .= (e ^. entityName) + , "description" .= (e ^. entityDescription) + , "tags" .= (e ^. entityTags) + ] + ++ ["plural" .= (e ^. entityPlural) | isJust (e ^. entityPlural)] + ++ ["orientation" .= (e ^. entityOrientation) | isJust (e ^. entityOrientation)] + ++ ["growth" .= (e ^. entityGrowth) | isJust (e ^. entityGrowth)] + ++ ["yields" .= (e ^. entityYields) | isJust (e ^. entityYields)] + ++ ["properties" .= (e ^. entityProperties) | not . null $ e ^. entityProperties] + ++ ["capabilities" .= (e ^. entityCapabilities) | not . M.null . getMap $ e ^. entityCapabilities] + +-- | Load entities from a data file called @entities.yaml@, producing +-- either an 'EntityMap' or a parse error. +loadEntities :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m EntityMap +loadEntities = do + let entityFile = "entities.yaml" + entityFailure = AssetNotLoaded (Data Entities) entityFile + fileName <- getDataFileNameSafe Entities entityFile + decoded <- + withThrow (entityFailure . CanNotParseYaml) . (liftEither <=< sendIO) $ + decodeFileEither fileName + + withThrow entityFailure $ validateEntityAttrRefs (M.keysSet worldAttributes) decoded + withThrow entityFailure $ buildEntityMap decoded + +------------------------------------------------------------ +-- Entity lenses +------------------------------------------------------------ + +-- $lenses +-- Our own custom lenses which properly recompute the cached hash +-- value each time something gets updated. See +-- https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ +-- for the approach used here. + +-- | Make a lens for Entity that recomputes the hash after setting. +hashedLens :: (Entity -> a) -> (Entity -> a -> Entity) -> Lens' Entity a +hashedLens get set = lens get (\e a -> rehashEntity $ set e a) + +-- | Get the hash of an entity. Note that this is a getter, not a +-- lens; the "Swarm.Game.Entity" module carefully maintains some +-- internal invariants ensuring that hashes work properly, and by +-- golly, no one else is going to mess that up. +entityHash :: Getter Entity Int +entityHash = to _entityHash + +-- | The 'Display' explaining how to draw this entity in the world display. +entityDisplay :: Lens' Entity Display +entityDisplay = hashedLens _entityDisplay (\e x -> e {_entityDisplay = x}) + +-- | The name of the entity. +entityName :: Lens' Entity EntityName +entityName = hashedLens _entityName (\e x -> e {_entityName = x}) + +-- | The irregular plural version of the entity's name, if there is +-- one. +entityPlural :: Lens' Entity (Maybe Text) +entityPlural = hashedLens _entityPlural (\e x -> e {_entityPlural = x}) + +-- | Get a version of the entity's name appropriate to the +-- number---the singular name for 1, and a plural name for any other +-- number. The plural name is obtained either by looking it up if +-- irregular, or by applying standard heuristics otherwise. +entityNameFor :: Int -> Getter Entity Text +entityNameFor 1 = entityName +entityNameFor _ = to $ \e -> + case e ^. entityPlural of + Just pl -> pl + Nothing -> plural (e ^. entityName) + +-- | A longer, free-form description of the entity. Each 'Text' value +-- represents a paragraph. +entityDescription :: Lens' Entity (Document Syntax) +entityDescription = hashedLens _entityDescription (\e x -> e {_entityDescription = x}) + +-- | A set of categories to which the entity belongs +entityTags :: Lens' Entity (Set Text) +entityTags = hashedLens _entityTags (\e x -> e {_entityTags = x}) + +-- | The direction this entity is facing (if it has one). +entityOrientation :: Lens' Entity (Maybe Heading) +entityOrientation = hashedLens _entityOrientation (\e x -> e {_entityOrientation = x}) + +-- | How long this entity takes to grow, if it regrows. +entityGrowth :: Lens' Entity (Maybe Growth) +entityGrowth = hashedLens _entityGrowth (\e x -> e {_entityGrowth = x}) + +-- | Susceptibility to and duration of combustion +entityCombustion :: Lens' Entity (Maybe Combustibility) +entityCombustion = hashedLens _entityCombustion (\e x -> e {_entityCombustion = x}) + +-- | The name of a different entity yielded when this entity is +-- grabbed, if any. +entityYields :: Lens' Entity (Maybe Text) +entityYields = hashedLens _entityYields (\e x -> e {_entityYields = x}) + +-- | The properties enjoyed by this entity. +entityProperties :: Lens' Entity (Set EntityProperty) +entityProperties = hashedLens _entityProperties (\e x -> e {_entityProperties = x}) + +-- | Test whether an entity has a certain property. +hasProperty :: Entity -> EntityProperty -> Bool +hasProperty e p = p `elem` (e ^. entityProperties) + +-- | The capabilities this entity provides when equipped. +entityCapabilities :: Lens' Entity (SingleEntityCapabilities EntityName) +entityCapabilities = hashedLens _entityCapabilities (\e x -> e {_entityCapabilities = x}) + +-- | The inventory of other entities carried by this entity. +entityBiomes :: Lens' Entity (Set TerrainType) +entityBiomes = hashedLens _entityBiomes (\e x -> e {_entityBiomes = x}) + +-- | The inventory of other entities carried by this entity. +entityInventory :: Lens' Entity Inventory +entityInventory = hashedLens _entityInventory (\e x -> e {_entityInventory = x}) + +------------------------------------------------------------ +-- Inventory +------------------------------------------------------------ + +-- | An inventory is really just a bag/multiset of entities. That is, +-- it contains some entities, along with the number of times each +-- occurs. Entities can be looked up directly, or by name. +data Inventory = Inventory + { -- Main map + counts :: IntMap (Count, Entity) + , -- Mirrors the main map; just caching the ability to look up by + -- name. + byName :: Map Text IntSet + , -- Cached hash of the inventory, using a homomorphic hashing scheme + -- (see https://github.com/swarm-game/swarm/issues/229). + -- + -- Invariant: equal to Sum_{(k,e) \in counts} (k+1) * (e ^. entityHash). + -- The k+1 is so the hash distinguishes between having a 0 count of something + -- and not having it as a key in the map at all. + inventoryHash :: Int + } + deriving (Show, Generic, FromJSON, ToJSON) + +instance Hashable Inventory where + -- Just return cached hash value. + hash = inventoryHash + hashWithSalt s = hashWithSalt s . inventoryHash + +-- | Inventories are compared by hash for efficiency. +instance Eq Inventory where + (==) = (==) `on` hash + +-- | Look up an entity in an inventory, returning the number of copies +-- contained. +lookup :: Entity -> Inventory -> Count +lookup e (Inventory cs _ _) = maybe 0 fst $ IM.lookup (e ^. entityHash) cs + +-- | Look up an entity by name in an inventory, returning a list of +-- matching entities. Note, if this returns some entities, it does +-- /not/ mean we necessarily have any in our inventory! It just +-- means we /know about/ them. If you want to know whether you have +-- any, use 'lookup' and see whether the resulting 'Count' is +-- 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) + +-- | 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 +-- just picks the first one returned from 'lookupByName'. +countByName :: Text -> Inventory -> Count +countByName name inv = + maybe 0 (`lookup` inv) (listToMaybe (lookupByName name inv)) + +-- | The empty inventory. +empty :: Inventory +empty = Inventory IM.empty M.empty 0 + +-- | Create an inventory containing one entity. +singleton :: Entity -> Inventory +singleton = flip insert empty + +-- | Insert an entity into an inventory. If the inventory already +-- contains this entity, then only its count will be incremented. +insert :: Entity -> Inventory -> Inventory +insert = insertCount 1 + +-- | Create an inventory from a list of entities. +fromList :: [Entity] -> Inventory +fromList = foldl' (flip insert) empty + +-- | Create an inventory from a list of entities and their counts. +fromElems :: [(Count, Entity)] -> Inventory +fromElems = foldl' (flip (uncurry insertCount)) empty + +-- | Insert a certain number of copies of an entity into an inventory. +-- If the inventory already contains this entity, then only its +-- count will be incremented. +insertCount :: Count -> Entity -> Inventory -> Inventory +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) + (h + (k + extra) * (e ^. entityHash)) -- homomorphic hashing + where + -- Include the hash of an entity once just for "knowing about" it; + -- then include the hash once per actual copy of the entity. In + -- other words, having k copies of e in the inventory contributes + -- (k+1)*(e ^. entityHash) to the inventory hash. The reason for + -- doing this is so that the inventory hash changes even when we + -- insert 0 copies of something, since having 0 copies of something + -- is different than not having it as a key at all; having 0 copies + -- signals that we at least "know about" the entity. + extra = if (e ^. entityHash) `IM.member` cs then 0 else 1 + +-- | Check whether an inventory contains at least one of a given entity. +contains :: Inventory -> Entity -> Bool +contains inv e = lookup e inv > 0 + +-- | Check whether an inventory has an entry for the given entity, +-- even if there are 0 copies. In particular this is used to +-- indicate whether a robot "knows about" an entity. +contains0plus :: Entity -> Inventory -> Bool +contains0plus e = isJust . IM.lookup (e ^. entityHash) . counts + +-- | Check if the first inventory is a subset of the second. +-- Note that entities with a count of 0 are ignored. +isSubsetOf :: Inventory -> Inventory -> Bool +isSubsetOf inv1 inv2 = all (\(n, e) -> lookup e inv2 >= n) (elems inv1) + +-- | Check whether an inventory is empty, meaning that it contains 0 +-- total entities (although it may still /know about/ some entities, that +-- is, have them as keys with a count of 0). +isEmpty :: Inventory -> Bool +isEmpty = all ((== 0) . fst) . elems + +-- | Compute the set of capabilities provided by the devices in an inventory. +inventoryCapabilities :: Inventory -> MultiEntityCapabilities Entity EntityName +inventoryCapabilities = combineEntityCaps . nonzeroEntities + +-- | List elements that have at least one copy in the inventory. +nonzeroEntities :: Inventory -> [Entity] +nonzeroEntities = map snd . filter ((> 0) . fst) . elems + +-- | List elements that possess a given Capability and +-- exist with nonzero count in the inventory. +extantElemsWithCapability :: Capability -> Inventory -> [Entity] +extantElemsWithCapability cap = + filter (M.member cap . getMap . (^. entityCapabilities)) . nonzeroEntities + +-- | Groups entities by the capabilities they offer. +entitiesByCapability :: Inventory -> Map Capability (NE.NonEmpty Entity) +entitiesByCapability inv = + binTuples entityCapabilityPairs + where + getCaps = M.keys . getMap . (^. entityCapabilities) + entityCapabilityPairs = concatMap ((\e -> map (,e) $ getCaps e) . snd) $ elems inv + +-- | Delete a single copy of a certain entity from an inventory. +delete :: Entity -> Inventory -> Inventory +delete = deleteCount 1 + +-- | Delete a specified number of copies of an entity from an inventory. +deleteCount :: Count -> Entity -> Inventory -> Inventory +deleteCount k e (Inventory cs byN h) = Inventory cs' byN h' + where + m = (fst <$> IM.lookup (e ^. entityHash) cs) ? 0 + cs' = IM.adjust removeCount (e ^. entityHash) cs + h' = h - min k m * (e ^. entityHash) + + removeCount :: (Count, a) -> (Count, a) + removeCount (n, a) = (max 0 (n - k), a) + +-- | Delete all copies of a certain entity from an inventory. +deleteAll :: Entity -> Inventory -> Inventory +deleteAll e (Inventory cs byN h) = + Inventory + (IM.adjust (first (const 0)) (e ^. entityHash) cs) + byN + (h - n * (e ^. entityHash)) + where + n = (fst <$> IM.lookup (e ^. entityHash) cs) ? 0 + +-- | Get the entities in an inventory and their associated counts. +elems :: Inventory -> [(Count, Entity)] +elems (Inventory cs _ _) = IM.elems cs + +-- | Union two inventories. +union :: Inventory -> Inventory -> Inventory +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) + (h1 + h2 - common) + where + -- Need to subtract off the sum of the hashes in common, because + -- of the way each entity with count k contributes (k+1) times its + -- hash. So if the two inventories share an entity e, just adding their + -- hashes would mean e now contributes (k+2) times its hash. + common = IS.foldl' (+) 0 $ IM.keysSet cs1 `IS.intersection` IM.keysSet cs2 + +-- | Subtract the second inventory from the first. +difference :: Inventory -> Inventory -> Inventory +difference inv1 = foldl' (flip (uncurry deleteCount)) inv1 . elems diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs @@ -0,0 +1,71 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Preserve color fidelity for non-TUI rendering +module Swarm.Game.Entity.Cosmetic where + +import Data.Colour.SRGB (RGB) +import Data.Word (Word8) + +data NamedColor + = White + | BrightRed + | Red + | Green + | Blue + | BrightYellow + | Yellow + deriving (Show) + +-- | 8-bit color +type RGBColor = RGB Word8 + +-- | High-fidelity color representation for rendering +-- outside of the TUI. +data TrueColor + = AnsiColor NamedColor + | Triple RGBColor + deriving (Show) + +-- | +-- A value of type @ColorLayers a@ represents the assignment of +-- foreground and\/or background color to an 'Entity' or terrain, +-- where @a@ may be a medium-independent (i.e. "authoritative") color +-- representation, or medium-specific (e.g. a @vty@ color). +-- The 'Functor' instance facilitates easy conversion from the +-- authoritative color to the specialized representation. +-- +-- Ignores @vty@ "styles", such as bold\/italic\/underline. +-- +-- This is intended to facilitate multiple rendering mediums: +-- +-- * Single pixel per world cell (one color must be chosen +-- between foreground and background, if both are specified) +-- * Pixel block per world cell (can show two colors in some stylized manner) +-- * Glyph per world cell (can render a colored display character on a colored background) +data ColorLayers a + = FgOnly a + | BgOnly a + | FgAndBg + -- | foreground + a + -- | background + a + deriving (Show, Functor) + +type PreservableColor = ColorLayers TrueColor + +getBackground :: ColorLayers a -> Maybe a +getBackground = \case + FgOnly _ -> Nothing + BgOnly x -> Just x + FgAndBg _ x -> Just x + +flattenBg :: ColorLayers a -> a +flattenBg = \case + FgOnly x -> x + BgOnly x -> x + FgAndBg _ x -> x + +newtype WorldAttr = WorldAttr String + deriving (Eq, Ord, Show) diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs @@ -0,0 +1,78 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Entity and terrain coloring. +-- +-- This module is the sole "ground truth" for color +-- assignment of entities and terrain. +-- More specifically, it sets colors for "attributes", +-- and the attributes are referenced by entities\/terrain. +module Swarm.Game.Entity.Cosmetic.Assignment where + +import Data.Bifunctor (bimap) +import Data.Colour.SRGB (RGB (..)) +import Data.Map (Map) +import Data.Map qualified as M +import Swarm.Game.Entity.Cosmetic + +-- * Entities and Terrain + +entity :: (WorldAttr, PreservableColor) +entity = (WorldAttr "entity", FgOnly $ AnsiColor White) + +water :: (WorldAttr, PreservableColor) +water = (WorldAttr "water", FgAndBg (AnsiColor White) (AnsiColor Blue)) + +rock :: (WorldAttr, PreservableColor) +rock = (WorldAttr "rock", FgOnly $ Triple $ RGB 80 80 80) + +plant :: (WorldAttr, PreservableColor) +plant = (WorldAttr "plant", FgOnly $ AnsiColor Green) + +dirt :: (WorldAttr, PreservableColor) +dirt = (WorldAttr "dirt", BgOnly $ Triple $ RGB 87 47 47) + +grass :: (WorldAttr, PreservableColor) +grass = (WorldAttr "grass", BgOnly $ Triple $ RGB 0 47 0) -- dark green + +stone :: (WorldAttr, PreservableColor) +stone = (WorldAttr "stone", BgOnly $ Triple $ RGB 47 47 47) + +ice :: (WorldAttr, PreservableColor) +ice = (WorldAttr "ice", BgOnly $ AnsiColor White) + +-- | Colors of entities in the world. +worldAttributes :: Map WorldAttr PreservableColor +worldAttributes = + M.fromList $ + -- these few are referenced elsewhere, + -- so they have their own toplevel definition + [ entity + , water + , rock + , plant + , dirt + , grass + , stone + , ice + ] + <> map + (bimap WorldAttr FgOnly) + [ ("device", AnsiColor BrightYellow) + , ("wood", Triple $ RGB 139 69 19) + , ("flower", Triple $ RGB 200 0 200) + , ("rubber", Triple $ RGB 245 224 179) + , ("copper", AnsiColor Yellow) + , ("copper'", Triple $ RGB 78 117 102) + , ("iron", Triple $ RGB 97 102 106) + , ("iron'", Triple $ RGB 183 65 14) + , ("quartz", AnsiColor White) + , ("silver", Triple $ RGB 192 192 192) + , ("gold", Triple $ RGB 255 215 0) + , ("snow", AnsiColor White) + , ("sand", Triple $ RGB 194 178 128) + , ("fire", AnsiColor BrightRed) + , ("red", AnsiColor Red) + , ("green", AnsiColor Green) + , ("blue", AnsiColor Blue) + ] diff --git a/src/swarm-scenario/Swarm/Game/Failure.hs b/src/swarm-scenario/Swarm/Game/Failure.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/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.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/Ingredients.hs b/src/swarm-scenario/Swarm/Game/Ingredients.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Ingredients.hs @@ -0,0 +1,20 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Ingredients ( + IngredientList, + Count, + getCost, +) where + +-- | A convenient synonym to remind us when an 'Int' is supposed to +-- represent /how many/ of something we have. +type Count = Int + +-- | An ingredient list is a list of entities with multiplicity. It +-- is polymorphic in the entity type so that we can use either +-- entity names when serializing, or actual entity objects while the +-- game is running. +type IngredientList e = [(Count, e)] + +getCost :: IngredientList e -> Int +getCost = sum . map fst diff --git a/src/swarm-scenario/Swarm/Game/Land.hs b/src/swarm-scenario/Swarm/Game/Land.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Land.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Terrain and Entities +module Swarm.Game.Land ( + TerrainEntityMaps (TerrainEntityMaps), + terrainMap, + entityMap, + loadEntitiesAndTerrain, +) where + +import Control.Algebra (Has) +import Control.Effect.Lift (Lift) +import Control.Effect.Throw (Throw) +import Control.Lens (makeLenses) +import GHC.Generics (Generic) +import Swarm.Game.Entity +import Swarm.Game.Failure (SystemFailure) +import Swarm.Game.Terrain + +data TerrainEntityMaps = TerrainEntityMaps + { _terrainMap :: TerrainMap + , _entityMap :: EntityMap + } + deriving (Show, Generic) + +makeLenses ''TerrainEntityMaps + +instance Semigroup TerrainEntityMaps where + TerrainEntityMaps tm1 em1 <> TerrainEntityMaps tm2 em2 = + TerrainEntityMaps (tm1 <> tm2) (em1 <> em2) + +instance Monoid TerrainEntityMaps where + mempty = TerrainEntityMaps mempty mempty + +loadEntitiesAndTerrain :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m TerrainEntityMaps +loadEntitiesAndTerrain = + TerrainEntityMaps <$> loadTerrain <*> loadEntities diff --git a/src/swarm-scenario/Swarm/Game/Recipe.hs b/src/swarm-scenario/Swarm/Game/Recipe.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Recipe.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Entity transformations, not limited to "crafting" +-- +-- A recipe represents some kind of process for transforming +-- some input entities into some output entities. +-- +-- Recipes support a number of different game mechanics, including: +-- +-- * crafting +-- * mining +-- * randomized "loot boxes" +-- * unlocking doors +-- +-- == Synchronous vs Async +-- Recipes can be completed either within the same tick +-- as execution is started, or execution may span +-- multiple ticks. It is possible for the execution +-- of multi-tick recipes to be interrupted in one way or +-- another, in which case the recipe fails without producing +-- the "outputs". +module Swarm.Game.Recipe ( + -- * Ingredient lists and recipes + IngredientList, + Recipe (..), + + -- ** Fields + recipeInputs, + recipeOutputs, + recipeCatalysts, + recipeTime, + recipeWeight, + + -- * Loading recipes + loadRecipes, + outRecipeMap, + inRecipeMap, + catRecipeMap, + + -- * Looking up recipes + MissingIngredient (..), + MissingType (..), + knowsIngredientsFor, + recipesFor, + make, + make', + findLacking, +) where + +import Control.Algebra (Has) +import Control.Arrow (left) +import Control.Effect.Lift (Lift, sendIO) +import Control.Effect.Throw (Throw, liftEither) +import Control.Lens hiding (from, (.=)) +import Control.Monad ((<=<)) +import Data.Bifunctor (second) +import Data.Either.Validation +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.Game.Entity as E +import Swarm.Game.Failure +import Swarm.Game.Ingredients +import Swarm.Game.ResourceLoading (getDataFileNameSafe) +import Swarm.Util.Effect (withThrow) +import Swarm.Util.Lens (makeLensesNoSigs) +import Swarm.Util.Yaml +import Witch + +-- | A recipe represents some kind of process where inputs are +-- transformed into outputs. +data Recipe e = Recipe + { _recipeInputs :: IngredientList e + , _recipeOutputs :: IngredientList e + , _recipeCatalysts :: IngredientList e + , _recipeTime :: Integer + , _recipeWeight :: Integer + } + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) + +deriving instance ToJSON (Recipe Entity) +deriving instance FromJSON (Recipe Entity) + +makeLensesNoSigs ''Recipe + +-- | The inputs to a recipe. +recipeInputs :: Lens' (Recipe e) (IngredientList e) + +-- | The outputs from a recipe. +recipeOutputs :: Lens' (Recipe e) (IngredientList e) + +-- | The time required to finish a recipe. +recipeTime :: Lens' (Recipe e) Integer + +-- | Other entities which the recipe requires you to have, but which +-- are not consumed by the recipe (e.g. a @\"furnace\"@). +recipeCatalysts :: Lens' (Recipe e) (IngredientList e) + +-- | How this recipe is weighted against other recipes. Any time +-- there are multiple valid recipes that fit certain criteria, one +-- of the recipes will be randomly chosen with probability +-- proportional to its weight. +recipeWeight :: Lens' (Recipe e) Integer + +------------------------------------------------------------ +-- Serializing +------------------------------------------------------------ + +instance ToJSON (Recipe Text) where + toJSON (Recipe ins outs cats time weight) = + object $ + [ "in" .= ins + , "out" .= outs + ] + ++ ["required" .= cats | not (null cats)] + ++ ["time" .= time | time /= 1] + ++ ["weight" .= weight | weight /= 1] + +instance FromJSON (Recipe Text) where + parseJSON = withObject "Recipe" $ \v -> do + _recipeInputs <- v .: "in" + _recipeOutputs <- v .: "out" + _recipeCatalysts <- v .:? "required" .!= [] + _recipeTime <- v .:? "time" .!= 1 + _recipeWeight <- v .:? "weight" .!= 1 + pure Recipe {..} + +-- | Given an 'EntityMap', turn a list of recipes containing /names/ +-- of entities into a list of recipes containing actual 'Entity' +-- records; or. +resolveRecipes :: EntityMap -> [Recipe Text] -> Validation [Text] [Recipe Entity] +resolveRecipes em = (traverse . traverse) (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) + +instance FromJSONE EntityMap (Recipe Entity) where + parseJSONE v = do + rt <- liftE $ parseJSON @(Recipe Text) v + em <- getE + let erEnt :: Validation [Text] (Recipe Entity) + erEnt = traverse (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) rt + case validationToEither erEnt of + Right rEnt -> return rEnt + Left err -> fail . from @Text . T.unlines $ err + +-- | Given an already loaded 'EntityMap', try to load a list of +-- recipes from the data file @recipes.yaml@. +loadRecipes :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + EntityMap -> + m [Recipe Entity] +loadRecipes em = do + fileName <- getDataFileNameSafe Recipes f + textRecipes <- + withThrow (AssetNotLoaded (Data Recipes) fileName . CanNotParseYaml) + . (liftEither <=< sendIO) + $ decodeFileEither @[Recipe Text] fileName + withThrow (AssetNotLoaded (Data Recipes) fileName . CustomMessage) + . liftEither + . left (T.append "Unknown entities in recipe(s): " . T.intercalate ", ") + . validationToEither + $ resolveRecipes em textRecipes + where + f = "recipes.yaml" + +------------------------------------------------------------ + +-- | Build a map of recipes either by inputs or outputs. +buildRecipeMap :: + Getter (Recipe Entity) (IngredientList Entity) -> + [Recipe Entity] -> + IntMap [Recipe Entity] +buildRecipeMap select recipeList = + IM.fromListWith (++) (map (second (: [])) (concatMap mk recipeList)) + where + mk r = [(e ^. entityHash, r) | (_, e) <- r ^. select] + +-- | Build a map of recipes indexed by output ingredients. +outRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity] +outRecipeMap = buildRecipeMap recipeOutputs + +-- | Build a map of recipes indexed by input ingredients. +inRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity] +inRecipeMap = buildRecipeMap recipeInputs + +-- | Build a map of recipes indexed by catalysts. +catRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity] +catRecipeMap = buildRecipeMap recipeCatalysts + +-- | Get a list of all the recipes for the given entity. Look up an +-- entity in either an 'inRecipeMap' or 'outRecipeMap' depending on +-- whether you want to know recipes that consume or produce the +-- given entity, respectively. +recipesFor :: IntMap [Recipe Entity] -> Entity -> [Recipe Entity] +recipesFor rm e = fromMaybe [] $ IM.lookup (e ^. entityHash) rm + +-- | Record information about something missing from a recipe. +data MissingIngredient = MissingIngredient MissingType Count Entity + deriving (Show, Eq) + +-- | What kind of thing is missing? +data MissingType = MissingInput | MissingCatalyst + deriving (Show, Eq) + +-- | Determines whether recipe inputs are satisfied by a +-- robot's inventory. +findLacking :: Inventory -> [(Count, Entity)] -> [(Count, Entity)] +findLacking robotInventory = filter ((> 0) . fst) . map countNeeded + where + countNeeded (need, entity) = (need - E.lookup entity robotInventory, entity) + +-- | Figure out which ingredients (if any) are lacking from an +-- inventory to be able to carry out the recipe. Catalysts are not +-- consumed and so can be used even when equipped. +missingIngredientsFor :: (Inventory, Inventory) -> Recipe Entity -> [MissingIngredient] +missingIngredientsFor (inv, ins) (Recipe inps _ cats _ _) = + mkMissing MissingInput (findLacking inv inps) + <> mkMissing MissingCatalyst (findLacking ins (findLacking inv cats)) + where + mkMissing k = map (uncurry (MissingIngredient k)) + +-- | Figure out if a recipe is available, /i.e./ if we at least know +-- about all the ingredients. Note it does not matter whether we have +-- enough of the ingredients. +knowsIngredientsFor :: (Inventory, Inventory) -> Recipe Entity -> Bool +knowsIngredientsFor (inv, ins) recipe = + knowsAll inv (recipe ^. recipeInputs) && knowsAll ins (recipe ^. recipeCatalysts) + where + knowsAll xs = all (E.contains xs . snd) + +-- | Try to make a recipe, deleting the recipe's inputs from the +-- inventory. Return either a description of which items are +-- lacking, if the inventory does not contain sufficient inputs, +-- or an inventory without inputs and function adding outputs if +-- it was successful. +make :: + -- | The robot's inventory and equipped devices + (Inventory, Inventory) -> + -- | The recipe we are trying to make + Recipe Entity -> + Either + [MissingIngredient] + (Inventory, IngredientList Entity, Recipe Entity) +make invs r = finish <$> make' invs r + where + finish (invTaken, out) = (invTaken, out, r) + +-- | Try to make a recipe, but do not insert it yet. +make' :: + (Inventory, Inventory) -> + Recipe Entity -> + Either + [MissingIngredient] + (Inventory, IngredientList Entity) +make' invs@(inv, _) r = + case missingIngredientsFor invs r of + [] -> + let removed = foldl' (flip (uncurry deleteCount)) inv (r ^. recipeInputs) + in Right (removed, r ^. recipeOutputs) + missing -> Left missing diff --git a/src/swarm-scenario/Swarm/Game/ResourceLoading.hs b/src/swarm-scenario/Swarm/Game/ResourceLoading.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/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.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 new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Robot.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A data type to represent robots. +module Swarm.Game.Robot ( + -- * Robots data + _robotID, + _robotLocation, + RobotMachine, + _machine, + RobotActivity, + _activityCounts, + RobotLogMember, + _robotLog, + RobotLogUpdatedMember, + _robotLogUpdated, + + -- * Robots + RobotPhase (..), + RID, + RobotR, + Robot, + TRobot, + + -- ** Lenses + robotEntity, + robotName, + trobotName, + unwalkableEntities, + robotCreatedAt, + robotDisplay, + robotLocation, + unsafeSetRobotLocation, + trobotLocation, + robotOrientation, + robotInventory, + equippedDevices, + inventoryHash, + robotCapabilities, + walkabilityContext, + robotID, + robotParentID, + robotHeavy, + systemRobot, + selfDestruct, + runningAtomic, + + -- ** Creation & instantiation + mkRobot, + + -- ** Query + robotKnows, + + -- ** Constants + hearingDistance, +) where + +import Control.Applicative ((<|>)) +import Control.Lens hiding (Const, contains) +import Data.Hashable (hashWithSalt) +import Data.Kind qualified +import Data.Text (Text) +import Data.Yaml (FromJSON (parseJSON), (.!=), (.:), (.:?)) +import GHC.Generics (Generic) +import Linear +import Swarm.Game.Device +import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible) +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Ingredients +import Swarm.Game.Land +import Swarm.Game.Location (Heading, Location, toDirection, toHeading) +import Swarm.Game.Robot.Walk +import Swarm.Game.Universe +import Swarm.Language.JSON () +import Swarm.Language.Syntax (Syntax, TSyntax) +import Swarm.Language.Text.Markdown (Document) +import Swarm.Util.Lens (makeLensesExcluding) +import Swarm.Util.Yaml +import System.Clock (TimeSpec) + +-- | A unique identifier for a robot. +type RID = Int + +-- | The phase of a robot description record. +data RobotPhase + = -- | The robot record has just been read in from a scenario + -- description; it represents a /template/ that may later be + -- instantiated as one or more concrete robots. + TemplateRobot + | -- | The robot record represents a concrete robot in the world. + ConcreteRobot + +-- | With a robot template, we may or may not have a location. With a +-- concrete robot we must have a location. +type family RobotLocation (phase :: RobotPhase) :: Data.Kind.Type where + RobotLocation 'TemplateRobot = Maybe (Cosmic Location) + RobotLocation 'ConcreteRobot = Cosmic Location + +-- | Robot templates have no ID; concrete robots definitely do. +type family RobotID (phase :: RobotPhase) :: Data.Kind.Type where + RobotID 'TemplateRobot = () + RobotID 'ConcreteRobot = RID + +type family RobotMachine (phase :: RobotPhase) :: Data.Kind.Type +type instance RobotMachine 'TemplateRobot = Maybe TSyntax + +type family RobotActivity (phase :: RobotPhase) :: Data.Kind.Type +type instance RobotActivity 'TemplateRobot = () + +type family RobotLogMember (phase :: RobotPhase) :: Data.Kind.Type +type instance RobotLogMember 'TemplateRobot = () + +type family RobotLogUpdatedMember (phase :: RobotPhase) :: Data.Kind.Type +type instance RobotLogUpdatedMember 'TemplateRobot = () + +-- | A value of type 'RobotR' is a record representing the state of a +-- single robot. The @f@ parameter is for tracking whether or not +-- the robot has been assigned a unique ID. +data RobotR (phase :: RobotPhase) = RobotR + { _robotEntity :: Entity + , _equippedDevices :: Inventory + , _robotCapabilities :: MultiEntityCapabilities Entity EntityName + -- ^ A cached view of the capabilities this robot has. + -- Automatically generated from '_equippedDevices'. + , _robotLog :: RobotLogMember phase + , _robotLogUpdated :: RobotLogUpdatedMember phase + , _robotLocation :: RobotLocation phase + , _robotID :: RobotID phase + , _robotParentID :: Maybe RID + , _robotHeavy :: Bool + , _machine :: RobotMachine phase + , _systemRobot :: Bool + , _selfDestruct :: Bool + , _activityCounts :: RobotActivity phase + , _runningAtomic :: Bool + , _unwalkableEntities :: WalkabilityExceptions EntityName + , _robotCreatedAt :: TimeSpec + } + deriving (Generic) + +deriving instance (Show (RobotLocation phase), Show (RobotID phase), Show (RobotMachine phase), Show (RobotActivity phase), Show (RobotLogMember phase), Show (RobotLogUpdatedMember phase)) => Show (RobotR phase) +deriving instance (Eq (RobotLocation phase), Eq (RobotID phase), Eq (RobotMachine phase), Eq (RobotActivity phase), Eq (RobotLogMember phase), Eq (RobotLogUpdatedMember phase)) => Eq (RobotR phase) + +-- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ +-- for the approach used here with lenses. + +makeLensesExcluding ['_robotCapabilities, '_equippedDevices, '_robotLog, '_robotLogUpdated, '_machine, '_activityCounts] ''RobotR + +-- | A template robot, i.e. a template robot record without a unique ID number, +-- and possibly without a location. +type TRobot = RobotR 'TemplateRobot + +-- | A concrete robot, with a unique ID number and a specific location. +type Robot = RobotR 'ConcreteRobot + +-- In theory we could make all these lenses over (RobotR phase), but +-- that leads to lots of type ambiguity problems later. In practice +-- we only need lenses for Robots. + +-- | Robots are not entities, but they have almost all the +-- characteristics of one (or perhaps we could think of robots as +-- very special sorts of entities), so for convenience each robot +-- carries an 'Entity' record to store all the information it has in +-- common with any 'Entity'. +-- +-- Note there are various lenses provided for convenience that +-- directly reference fields inside this record; for example, one +-- can use 'robotName' instead of writing @'robotEntity' +-- . 'entityName'@. +robotEntity :: Lens' (RobotR phase) Entity + +-- | Entities that the robot cannot move onto +unwalkableEntities :: Lens' Robot (WalkabilityExceptions EntityName) + +-- | The creation date of the robot. +robotCreatedAt :: Lens' Robot TimeSpec + +-- robotName and trobotName could be generalized to +-- @robotName' :: Lens' (RobotR phase) Text@. +-- However, type inference does not work +-- very well with the polymorphic version, so we export both +-- monomorphic versions instead. + +-- | The name of a robot. +robotName :: Lens' Robot Text +robotName = robotEntity . entityName + +-- | The name of a robot template. +trobotName :: Lens' TRobot Text +trobotName = robotEntity . entityName + +-- | The 'Display' of a robot. This is a special lens that +-- automatically sets the 'curOrientation' to the orientation of the +-- robot every time you do a @get@ operation. Technically this does +-- not satisfy the lens laws---in particular, the get/put law does +-- not hold. But we should think of the 'curOrientation' as being +-- simply a cache of the displayed entity's direction. +robotDisplay :: Lens' Robot Display +robotDisplay = lens getDisplay setDisplay + where + getDisplay r = + (r ^. robotEntity . entityDisplay) + & curOrientation .~ ((r ^. robotOrientation) >>= toDirection) + setDisplay r d = r & robotEntity . entityDisplay .~ d + +-- | The robot's current location, represented as @(x,y)@. This is only +-- a getter, since when changing a robot's location we must remember +-- to update the 'Swarm.Game.State.robotsByLocation' map as well. You can use the +-- 'Swarm.Game.Step.updateRobotLocation' function for this purpose. +robotLocation :: Getter Robot (Cosmic Location) + +-- | Set a robot's location. This is unsafe and should never be +-- called directly except by the 'Swarm.Game.Step.updateRobotLocation' function. +-- The reason is that we need to make sure the 'Swarm.Game.State.robotsByLocation' +-- map stays in sync. +unsafeSetRobotLocation :: Cosmic Location -> Robot -> Robot +unsafeSetRobotLocation loc r = r {_robotLocation = loc} + +-- | A template robot's location. Unlike 'robotLocation', this is a +-- lens, since when dealing with robot templates there is as yet no +-- 'Swarm.Game.State.robotsByLocation' map to keep up-to-date. +trobotLocation :: Lens' TRobot (Maybe (Cosmic Location)) +trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l}) + +-- | Which way the robot is currently facing. +robotOrientation :: Lens' Robot (Maybe Heading) +robotOrientation = robotEntity . entityOrientation + +-- | The robot's inventory. +robotInventory :: Lens' Robot Inventory +robotInventory = robotEntity . entityInventory + +-- | The (unique) ID number of the robot. This is only a Getter since +-- the robot ID is immutable. +robotID :: Getter Robot RID + +-- | The ID number of the robot's parent, that is, the robot that +-- built (or most recently reprogrammed) this robot, if there is +-- one. +robotParentID :: Lens' Robot (Maybe RID) + +-- | Is this robot extra heavy (thus requiring tank treads to move)? +robotHeavy :: Lens' Robot Bool + +-- | A separate inventory for equipped devices, which provide the +-- robot with certain capabilities. +-- +-- Note that every time the inventory of equipped devices is +-- modified, this lens recomputes a cached set of the capabilities +-- the equipped devices provide, to speed up subsequent lookups to +-- see whether the robot has a certain capability (see 'robotCapabilities') +equippedDevices :: Lens' Robot Inventory +equippedDevices = lens _equippedDevices setEquipped + where + setEquipped r inst = + r + { _equippedDevices = inst + , _robotCapabilities = inventoryCapabilities inst + } + +-- | A hash of a robot's entity record and equipped devices, to +-- facilitate quickly deciding whether we need to redraw the robot +-- info panel. +inventoryHash :: Getter Robot Int +inventoryHash = to (\r -> 17 `hashWithSalt` (r ^. (robotEntity . entityHash)) `hashWithSalt` (r ^. equippedDevices)) + +-- | Does a robot know of an entity's existence? +robotKnows :: Robot -> Entity -> Bool +robotKnows r e = contains0plus e (r ^. robotInventory) || contains0plus e (r ^. equippedDevices) + +-- | Get the set of capabilities this robot possesses. This is only a +-- getter, not a lens, because it is automatically generated from +-- the 'equippedDevices'. The only way to change a robot's +-- capabilities is to modify its 'equippedDevices'. +robotCapabilities :: Getter Robot (MultiEntityCapabilities Entity EntityName) +robotCapabilities = to _robotCapabilities + +-- | Is this robot a "system robot"? System robots are generated by +-- the system (as opposed to created by the user) and are not +-- subject to the usual capability restrictions. +systemRobot :: Lens' Robot Bool + +-- | Does this robot wish to self destruct? +selfDestruct :: Lens' Robot Bool + +-- | Is the robot currently running an atomic block? +runningAtomic :: Lens' Robot Bool +walkabilityContext :: Getter Robot WalkabilityContext +walkabilityContext = to $ + \x -> WalkabilityContext (getCapabilitySet $ _robotCapabilities x) (_unwalkableEntities x) + +-- | A general function for creating robots. +mkRobot :: + Maybe Int -> + -- | Name of the robot. + Text -> + -- | Description of the robot. + Document Syntax -> + -- | Initial location. + Maybe (Cosmic Location) -> + -- | Initial heading/direction. + Heading -> + -- | Robot display. + Display -> + -- | Initial CESK machine. + Maybe TSyntax -> + -- | Equipped devices. + [Entity] -> + -- | Initial inventory. + [(Count, Entity)] -> + -- | Should this be a system robot? + Bool -> + -- | Is this robot heavy? + Bool -> + -- | Unwalkable entities + WalkabilityExceptions EntityName -> + -- | Creation date + TimeSpec -> + TRobot +mkRobot pid name descr loc dir disp m devs inv sys heavy unwalkables ts = + RobotR + { _robotEntity = + mkEntity disp name descr [] mempty + & entityOrientation ?~ dir + & entityInventory .~ fromElems inv + , _equippedDevices = inst + , _robotCapabilities = inventoryCapabilities inst + , _robotLog = () + , _robotLogUpdated = () + , _robotLocation = loc + , _robotID = () + , _robotParentID = pid + , _robotHeavy = heavy + , _robotCreatedAt = ts + , _machine = m + , _systemRobot = sys + , _selfDestruct = False + , _activityCounts = () + , _runningAtomic = False + , _unwalkableEntities = unwalkables + } + where + inst = fromList devs + +newtype HeadingSpec = HeadingSpec + { getHeading :: Heading + } + +instance FromJSON HeadingSpec where + parseJSON x = fmap HeadingSpec $ (toHeading <$> parseJSON x) <|> parseJSON x + +-- | We can parse a robot from a YAML file if we have access to an +-- 'EntityMap' in which we can look up the names of entities. +instance FromJSONE TerrainEntityMaps TRobot where + parseJSONE = withObjectE "robot" $ \v -> do + -- Note we can't generate a unique ID here since we don't have + -- access to a 'State GameState' effect; a unique ID will be + -- filled in later when adding the robot to the world. + sys <- liftE $ v .:? "system" .!= False + let defDisplay = defaultRobotDisplay & invisible .~ sys + + mkRobot Nothing + <$> liftE (v .: "name") + <*> liftE (v .:? "description" .!= mempty) + <*> liftE (v .:? "loc") + <*> liftE (fmap getHeading $ v .:? "dir" .!= HeadingSpec zero) + <*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay) + <*> liftE (v .:? "program") + <*> localE (view entityMap) (v ..:? "devices" ..!= []) + <*> localE (view entityMap) (v ..:? "inventory" ..!= []) + <*> pure sys + <*> liftE (v .:? "heavy" .!= False) + <*> liftE (v .:? "walkable" ..!= emptyExceptions) + <*> pure 0 + +hearingDistance :: (Num i) => i +hearingDistance = 32 diff --git a/src/swarm-scenario/Swarm/Game/Robot/Walk.hs b/src/swarm-scenario/Swarm/Game/Robot/Walk.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Robot/Walk.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Walkability exceptions +module Swarm.Game.Robot.Walk where + +import Control.Monad (unless) +import Data.Aeson +import Data.List.NonEmpty qualified as NE +import Data.Set (Set) +import Data.Set qualified as S +import GHC.Generics (Generic) +import Swarm.Game.Entity (EntityName) +import Swarm.Language.Capability (Capability) + +-- | A 'Blacklist' that is empty is the typical behavior, +-- in which walkability is +-- fully determined by an entity's 'Unwalkable' or 'Liquid' property. +-- A 'Whitelist' ignores those properties, and even blank terrain +-- is considered unwalkable. +-- Note that a 'Whitelist' that is empty would allow no movement whatsoever. +data Inclusions a + = Whitelist a + | Blacklist a + deriving (Show, Eq, Functor, Generic, ToJSON) + +emptyExceptions :: Monoid a => Inclusions a +emptyExceptions = Blacklist mempty + +type WalkabilityExceptions a = Inclusions (Set a) + +instance (FromJSON a, Ord a) => FromJSON (WalkabilityExceptions a) where + parseJSON = withObject "walkable" $ \v -> do + whitelist <- v .:? "only" .!= [] + blacklist <- v .:? "never" .!= [] + + unless (null whitelist || null blacklist) $ + fail "Cannot specify both a whitelist and blacklist" + + let exceptionList = + maybe + (Blacklist blacklist) -- Note: empty blacklist is the typical case + (Whitelist . NE.toList) + (NE.nonEmpty whitelist) + + return $ S.fromList <$> exceptionList + +-- | Properties of a robot used to determine whether an entity is walkable +data WalkabilityContext + = WalkabilityContext + (Set Capability) + -- | which entities are unwalkable by this robot + (WalkabilityExceptions EntityName) + deriving (Show, Eq, Generic, ToJSON) diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Standalone worlds +-- +-- Scenarios are standalone worlds with specific starting and winning +-- 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), + staticPlacements, + structureDefs, + + -- ** Fields + scenarioMetadata, + scenarioOperation, + scenarioLandscape, + scenarioVersion, + scenarioName, + scenarioAuthor, + scenarioDescription, + scenarioCreative, + scenarioSeed, + scenarioAttrs, + scenarioTerrainAndEntities, + scenarioCosmetics, + scenarioRecipes, + scenarioKnown, + scenarioWorlds, + scenarioNavigation, + scenarioStructures, + scenarioRobots, + scenarioObjectives, + scenarioSolution, + scenarioStepsPerTick, + + -- * Loading from disk + loadScenario, + loadScenarioFile, + getScenarioPath, + loadStandaloneScenario, + GameStateInputs (..), + ScenarioInputs (..), + + -- * Utilities + arbitrateSeed, +) where + +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) +import Control.Carrier.Throw.Either (runThrow) +import Control.Effect.Lift (Lift, sendIO) +import Control.Effect.Throw +import Control.Lens hiding (from, (.=), (<.>)) +import Control.Monad (filterM, forM_, unless, (<=<)) +import Data.Aeson +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (catMaybes, isNothing, listToMaybe, mapMaybe) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +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.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.Overlay +import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..)) +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.Util (binTuples, commaList, failT, quote) +import Swarm.Util.Effect (ignoreWarnings, throwToMaybe, withThrow) +import Swarm.Util.Lens (makeLensesNoSigs) +import Swarm.Util.Yaml +import System.Directory (doesFileExist) +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 +data ScenarioMetadata = ScenarioMetadata + { _scenarioVersion :: Int + , _scenarioName :: Text + , _scenarioAuthor :: Maybe Text + } + deriving (Show, Generic) + +instance ToJSON ScenarioMetadata where + toEncoding = + genericToEncoding + defaultOptions + { fieldLabelModifier = drop 1 -- drops leading underscore + } + +makeLensesNoSigs ''ScenarioMetadata + +-- | The version number of the scenario schema. Currently, this +-- should always be 1, but it is ignored. In the future, this may +-- be used to convert older formats to newer ones, or simply to +-- print a nice error message when we can't read an older format. +scenarioVersion :: Lens' ScenarioMetadata Int + +-- | The name of the scenario. +scenarioName :: Lens' ScenarioMetadata Text + +-- | The author of the scenario. +scenarioAuthor :: Lens' ScenarioMetadata (Maybe Text) + +-- | Non-structural gameplay content of the scenario; +-- how it is to be played. +data ScenarioOperation = ScenarioOperation + { _scenarioCreative :: Bool + , _scenarioDescription :: Document Syntax + -- ^ Note: the description is in this record instead of + -- 'ScenarioMetadata' because it relates to the goals. + , _scenarioObjectives :: [Objective] + , _scenarioSolution :: Maybe TSyntax + , _scenarioRecipes :: [Recipe Entity] + , _scenarioStepsPerTick :: Maybe Int + } + deriving (Show) + +makeLensesNoSigs ''ScenarioOperation + +-- | A high-level description of the scenario, shown /e.g./ in the +-- menu. +scenarioDescription :: Lens' ScenarioOperation (Document Syntax) + +-- | Whether the scenario should start in creative mode. +scenarioCreative :: Lens' ScenarioOperation Bool + +-- | Any custom recipes used in this scenario. +scenarioRecipes :: Lens' ScenarioOperation [Recipe Entity] + +-- | A sequence of objectives for the scenario (if any). +scenarioObjectives :: Lens' ScenarioOperation [Objective] + +-- | An optional solution of the scenario, expressed as a +-- program of type @cmd a@. This is useful for automated +-- testing of the win condition. +scenarioSolution :: Lens' ScenarioOperation (Maybe TSyntax) + +-- | Optionally, specify the maximum number of steps each robot may +-- take during a single tick. +scenarioStepsPerTick :: Lens' ScenarioOperation (Maybe Int) + +-- | All cosmetic and structural content of the scenario. +data ScenarioLandscape = ScenarioLandscape + { _scenarioSeed :: Maybe Int + , _scenarioAttrs :: [CustomAttr] + , _scenarioTerrainAndEntities :: TerrainEntityMaps + , _scenarioCosmetics :: M.Map WorldAttr PreservableColor + , _scenarioKnown :: Set EntityName + , _scenarioWorlds :: NonEmpty WorldDescription + , _scenarioNavigation :: Navigation (M.Map SubworldName) Location + , _scenarioStructures :: StaticStructureInfo + , _scenarioRobots :: [TRobot] + } + deriving (Show) + +makeLensesNoSigs ''ScenarioLandscape + +-- | The seed used for the random number generator. If @Nothing@, use +-- a random seed / prompt the user for the seed. +scenarioSeed :: Lens' ScenarioLandscape (Maybe Int) + +-- | Custom attributes defined in the scenario. +scenarioAttrs :: Lens' ScenarioLandscape [CustomAttr] + +-- | Any custom terrain and entities used for this scenario, +-- combined with the default system terrain and entities. +scenarioTerrainAndEntities :: Lens' ScenarioLandscape TerrainEntityMaps + +-- | High-fidelity color map for entities +scenarioCosmetics :: Lens' ScenarioLandscape (M.Map WorldAttr PreservableColor) + +-- | List of entities that should be considered "known", so robots do +-- not have to scan them. +scenarioKnown :: Lens' ScenarioLandscape (Set EntityName) + +-- | The subworlds of the scenario. +-- The "root" subworld shall always be at the head of the list, by construction. +scenarioWorlds :: Lens' ScenarioLandscape (NonEmpty WorldDescription) + +-- | Information required for structure recognition +scenarioStructures :: Lens' ScenarioLandscape StaticStructureInfo + +-- | Waypoints and inter-world portals +scenarioNavigation :: Lens' ScenarioLandscape (Navigation (M.Map SubworldName) Location) + +-- | The starting robots for the scenario. Note this should +-- include the base. +scenarioRobots :: Lens' ScenarioLandscape [TRobot] + +-- | A 'Scenario' contains all the information to describe a +-- scenario. +data Scenario = Scenario + { _scenarioMetadata :: ScenarioMetadata + , _scenarioOperation :: ScenarioOperation + , _scenarioLandscape :: ScenarioLandscape + } + deriving (Show) + +makeLensesNoSigs ''Scenario + +-- | Authorship information about scenario not used at play-time +scenarioMetadata :: Lens' Scenario ScenarioMetadata + +-- | Non-structural gameplay content of the scenario; +-- how it is to be played. +scenarioOperation :: Lens' Scenario ScenarioOperation + +-- | All cosmetic and structural content of the scenario. +scenarioLandscape :: Lens' Scenario ScenarioLandscape + +-- * Parsing + +instance FromJSONE ScenarioInputs Scenario where + parseJSONE = withObjectE "scenario" $ \v -> do + -- parse custom terrain + tmRaw <- liftE (v .:? "terrains" .!= []) + + -- parse custom entities + emRaw <- liftE (v .:? "entities" .!= []) + + parsedAttrs <- liftE (v .:? "attrs" .!= []) + let mergedCosmetics = worldAttributes <> M.fromList (mapMaybe toHifiPair parsedAttrs) + attrsUnion = M.keysSet mergedCosmetics + + validatedTerrainObjects <- runValidation $ validateTerrainAttrRefs attrsUnion tmRaw + + let tm = mkTerrainMap validatedTerrainObjects + + runValidation $ validateEntityAttrRefs attrsUnion emRaw + + em <- runValidation $ buildEntityMap emRaw + + let scenarioSpecificTerrainEntities = TerrainEntityMaps tm em + + -- Save the passed in WorldMap for later + worldMap <- initWorldMap <$> getE + + -- Get rid of WorldMap from context locally, and combine + -- the default system TerrainMap and EntityMap + -- with any custom terrain/entities parsed above + localE initEntityTerrain $ withE scenarioSpecificTerrainEntities $ do + -- parse 'known' entity names and make sure they exist + known <- liftE (v .:? "known" .!= mempty) + 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] + + -- parse robots and build RobotMap + rs <- v ..: "robots" + let rsMap = buildRobotMap rs + + -- NOTE: These have not been merged with their children yet. + rootLevelSharedStructures :: InheritedStructureDefs <- + localE (,rsMap) $ + v ..:? "structures" ..!= [] + + -- TODO (#1611) This is inefficient; instead, we should + -- form a DAG of structure references and visit deepest first, + -- caching in a map as we go. + -- Then, if a given sub-structure is referenced more than once, we don't + -- have to re-assemble it. + -- + -- We should also make use of such a pre-computed map in the + -- invocation of 'mergeStructures' inside WorldDescription.hs. + mergedStructures <- + either (fail . T.unpack) return $ + mapM + (sequenceA . (id &&& (Assembly.mergeStructures mempty 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" ..!= [] + return $ rootWorld :| subworlds + + let worldsByName = binTuples $ NE.toList $ NE.map (worldName &&& id) allWorlds + dupedNames = M.keys $ M.filter ((> 1) . length) worldsByName + unless (null dupedNames) $ + failT + [ "Subworld names are not unique:" + , T.intercalate ", " $ map renderWorldName dupedNames + ] + + -- Validate robot locations + forM_ rs $ \r -> forM_ (r ^. trobotLocation) $ \rLoc -> + unless ((rLoc ^. subworld) `M.member` worldsByName) + . failT + $ [ "Robot" + , quote $ r ^. trobotName + , "specifies location in nonexistent subworld" + , renderQuotedWorldName (rLoc ^. subworld) <> "." + , "Valid subworlds are:" + , commaList $ map renderQuotedWorldName $ M.keys worldsByName + ] + + let mergedWaypoints = + M.fromList $ + map (worldName &&& runIdentity . waypoints . navigation) $ + NE.toList allWorlds + + mergedPortals <- + validatePortals + . Navigation mergedWaypoints + . M.unions + . map (portals . navigation) + $ NE.toList allWorlds + + let mergedNavigation = Navigation mergedWaypoints mergedPortals + recognizableGrids = filter Structure.isRecognizable namedGrids + + symmetryAnnotatedGrids <- mapM checkSymmetry recognizableGrids + + let structureInfo = + StaticStructureInfo symmetryAnnotatedGrids + . M.fromList + . NE.toList + $ NE.map (worldName &&& placedStructures) allWorlds + + seed <- liftE (v .:? "seed") + let landscape = + ScenarioLandscape + seed + parsedAttrs + combinedTEM + mergedCosmetics + (Set.fromList known) + allWorlds + mergedNavigation + structureInfo + rs + + metadata <- + ScenarioMetadata + <$> liftE (v .: "version") + <*> liftE (v .: "name") + <*> liftE (v .:? "author") + + playInfo <- + ScenarioOperation + <$> liftE (v .:? "creative" .!= False) + <*> liftE (v .:? "description" .!= "") + <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives) + <*> liftE (v .:? "solution") + <*> localE (view entityMap) (v ..:? "recipes" ..!= []) + <*> liftE (v .:? "stepsPerTick") + + return $ Scenario metadata playInfo landscape + where + runValidation f = case run . runThrow $ f of + Right x -> return x + Left x -> failT [prettyText @LoadingFailure x] + +-- * Loading scenarios + +getScenarioPath :: + (Has (Lift IO) sig m) => + FilePath -> + m (Maybe FilePath) +getScenarioPath scenario = do + libScenario <- throwToMaybe @SystemFailure $ getDataFileNameSafe Scenarios $ "scenarios" scenario + libScenarioExt <- throwToMaybe @SystemFailure $ getDataFileNameSafe Scenarios $ "scenarios" scenario <.> "yaml" + let candidates = catMaybes [Just scenario, libScenarioExt, libScenario] + listToMaybe <$> sendIO (filterM doesFileExist candidates) + +-- | Load a scenario with a given name from disk, given an entity map +-- to use. This function is used if a specific scenario is +-- requested on the command line. +loadScenario :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + FilePath -> + ScenarioInputs -> + m (Scenario, FilePath) +loadScenario scenario scenarioInputs = do + mfileName <- getScenarioPath scenario + fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName + (,fileName) <$> loadScenarioFile scenarioInputs fileName + +-- | Load a scenario from a file. +loadScenarioFile :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + ScenarioInputs -> + FilePath -> + m Scenario +loadScenarioFile scenarioInputs fileName = + (withThrow adaptError . (liftEither <=< sendIO)) $ + decodeFileEitherE scenarioInputs fileName + where + adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml + +loadStandaloneScenario :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + FilePath -> + m (Scenario, GameStateInputs) +loadStandaloneScenario fp = do + tem <- loadEntitiesAndTerrain + worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem + let scenarioInputs = ScenarioInputs worlds tem + recipes <- loadRecipes $ tem ^. entityMap + scene <- fst <$> loadScenario fp scenarioInputs + return (scene, GameStateInputs scenarioInputs recipes) + +data ScenarioInputs = ScenarioInputs + { initWorldMap :: WorldMap + -- ^ A collection of typechecked world DSL terms that are available to + -- be used in scenario definitions. + , initEntityTerrain :: TerrainEntityMaps + -- ^ The standard terrain/entity maps loaded from disk. Individual scenarios + -- may define additional terrain/entities which will get added to this map + -- when loading the scenario. + } + +data GameStateInputs = GameStateInputs + { gsiScenarioInputs :: ScenarioInputs + , gsiRecipes :: [Recipe Entity] + -- ^ The standard list of recipes loaded from disk. Individual scenarios + -- may define additional recipes which will get added to this list + -- when loading the scenario. + } + +-- | +-- Decide on a seed. In order of preference, we will use: +-- 1. seed value provided by the user +-- 2. seed value specified in the scenario description +-- 3. randomly chosen seed value +arbitrateSeed :: Maybe Seed -> ScenarioLandscape -> IO Seed +arbitrateSeed userSeed sLandscape = + case userSeed <|> sLandscape ^. scenarioSeed of + Just s -> return s + Nothing -> randomRIO (0, maxBound :: Int) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Goals of scenario +module Swarm.Game.Scenario.Objective ( + -- * Scenario objectives + PrerequisiteConfig (..), + Objective, + objectiveGoal, + objectiveTeaser, + objectiveCondition, + objectiveId, + objectiveOptional, + objectivePrerequisite, + objectiveHidden, + objectiveAchievement, + Announcement (..), + + -- * Objective completion tracking + ObjectiveCompletion, + initCompletion, + completedIDs, + incompleteObjectives, + completedObjectives, + unwinnableObjectives, + allObjectives, + addCompleted, + addUnwinnable, + addIncomplete, + extractIncomplete, +) +where + +import Control.Applicative ((<|>)) +import Control.Lens hiding (from, (<.>)) +import Data.Aeson +import Data.Set qualified as Set +import Data.Text (Text) +import GHC.Generics (Generic) +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Game.Achievement.Definitions qualified as AD +import Swarm.Game.Scenario.Objective.Logic as L +import Swarm.Language.JSON () +import Swarm.Language.Syntax (Syntax, TSyntax) +import Swarm.Language.Text.Markdown qualified as Markdown +import Swarm.Util.Lens (concatFold, makeLensesExcluding, makeLensesNoSigs) + +------------------------------------------------------------ +-- Scenario objectives +------------------------------------------------------------ + +data PrerequisiteConfig = PrerequisiteConfig + { previewable :: Bool + -- ^ Typically, only the currently "active" objectives are + -- displayed to the user in the Goals dialog. An objective + -- is "active" if all of its prerequisites are met. + -- + -- However, some objectives may be "high-level", in that they may + -- explain the broader intention behind potentially multiple + -- prerequisites. + -- + -- Set this option to 'True' to display this goal in the "upcoming" section even + -- if the objective has currently unmet prerequisites. + , logic :: Prerequisite ObjectiveLabel + -- ^ Boolean expression of dependencies upon other objectives. Variables in this expression + -- are the "id"s of other objectives, and become "true" if the corresponding objective is completed. + -- The "condition" of the objective at hand shall not be evaluated until its + -- prerequisite expression evaluates as 'True'. + -- + -- Note that the achievement of these objective dependencies is + -- persistent; once achieved, they still count even if their "condition" + -- might not still hold. The condition is never re-evaluated once true. + } + deriving (Eq, Show, Generic, ToJSON) + +instance FromJSON PrerequisiteConfig where + -- Parsing JSON/YAML 'PrerequisiteConfig' has a shorthand option + -- in which the boolean expression can be written directly, + -- bypassing the "logic" key. + -- Furthermore, an "Id" in a boolean expressions can be written + -- as a bare string without needing the "id" key. + parseJSON val = preLogic val <|> preObject val + where + preObject = withObject "prerequisite" $ \v -> do + previewable <- v .:? "previewable" .!= False + logic <- v .: "logic" + pure PrerequisiteConfig {..} + preLogic = fmap (PrerequisiteConfig False) . parseJSON + +-- | An objective is a condition to be achieved by a player in a +-- scenario. +data Objective = Objective + { _objectiveGoal :: Markdown.Document Syntax + , _objectiveTeaser :: Maybe Text + , _objectiveCondition :: TSyntax + , _objectiveId :: Maybe ObjectiveLabel + , _objectiveOptional :: Bool + , _objectivePrerequisite :: Maybe PrerequisiteConfig + , _objectiveHidden :: Bool + , _objectiveAchievement :: Maybe AD.AchievementInfo + } + deriving (Eq, Show, Generic, ToJSON) + +makeLensesNoSigs ''Objective + +instance ToSample Objective where + toSamples _ = SD.noSamples + +-- | An explanation of the goal of the objective, shown to the player +-- during play. It is represented as a list of paragraphs. +objectiveGoal :: Lens' Objective (Markdown.Document Syntax) + +-- | A very short (3-5 words) description of the goal for +-- displaying on the left side of the Objectives modal. +objectiveTeaser :: Lens' Objective (Maybe Text) + +-- | A winning condition for the objective, expressed as a +-- program of type @cmd bool@. By default, this program will be +-- run to completion every tick (the usual limits on the number +-- of CESK steps per tick do not apply). +objectiveCondition :: Lens' Objective TSyntax + +-- | Optional name by which this objective may be referenced +-- as a prerequisite for other objectives. +objectiveId :: Lens' Objective (Maybe Text) + +-- | Indicates whether the objective is not required in order +-- to "win" the scenario. Useful for (potentially hidden) achievements. +-- If the field is not supplied, it defaults to False (i.e. the +-- objective is mandatory to "win"). +objectiveOptional :: Lens' Objective Bool + +-- | Dependencies upon other objectives +objectivePrerequisite :: Lens' Objective (Maybe PrerequisiteConfig) + +-- | Whether the goal is displayed in the UI before completion. +-- The goal will always be revealed after it is completed. +-- +-- This attribute often goes along with an Achievement. +objectiveHidden :: Lens' Objective Bool + +-- | An optional achievement that is to be registered globally +-- when this objective is completed. +objectiveAchievement :: Lens' Objective (Maybe AD.AchievementInfo) + +instance FromJSON Objective where + parseJSON = withObject "objective" $ \v -> do + _objectiveGoal <- v .:? "goal" .!= mempty + _objectiveTeaser <- v .:? "teaser" + _objectiveCondition <- v .: "condition" + _objectiveId <- v .:? "id" + _objectiveOptional <- v .:? "optional" .!= False + _objectivePrerequisite <- v .:? "prerequisite" + _objectiveHidden <- v .:? "hidden" .!= False + _objectiveAchievement <- v .:? "achievement" + pure Objective {..} + +-- | TODO: #1044 Could also add an "ObjectiveFailed" constructor... +newtype Announcement + = ObjectiveCompleted Objective + deriving (Show, Generic, ToJSON) + +------------------------------------------------------------ +-- Completion tracking +------------------------------------------------------------ + +-- | Gather together lists of objectives that are incomplete, +-- complete, or unwinnable. This type is not exported from this +-- module. +data CompletionBuckets = CompletionBuckets + { _incomplete :: [Objective] + , _completed :: [Objective] + , _unwinnable :: [Objective] + } + deriving (Show, Generic, FromJSON, ToJSON) + +-- Note we derive these lenses for `CompletionBuckets` but we do NOT +-- export them; they are used only internally to this module. In +-- fact, the `CompletionBuckets` type itself is not exported. +makeLensesNoSigs ''CompletionBuckets + +-- | The incomplete objectives in a 'CompletionBuckets' record. +incomplete :: Lens' CompletionBuckets [Objective] + +-- | The completed objectives in a 'CompletionBuckets' record. +completed :: Lens' CompletionBuckets [Objective] + +-- | The unwinnable objectives in a 'CompletionBuckets' record. +unwinnable :: Lens' CompletionBuckets [Objective] + +-- | A record to keep track of the completion status of all a +-- scenario's objectives. We do not export the constructor or +-- record field labels of this type in order to ensure that its +-- internal invariants cannot be violated. +data ObjectiveCompletion = ObjectiveCompletion + { _completionBuckets :: CompletionBuckets + -- ^ This is the authoritative "completion status" + -- for all objectives. + -- Note that there is a separate Set to store the + -- completion status of prerequisite objectives, which + -- must be carefully kept in sync with this. + -- Those prerequisite objectives are required to have + -- labels, but other objectives are not. + -- Therefore only prerequisites exist in the completion + -- map keyed by label. + , _completedIDs :: Set.Set ObjectiveLabel + } + deriving (Show, Generic, FromJSON, ToJSON) + +makeLensesFor [("_completedIDs", "internalCompletedIDs")] ''ObjectiveCompletion +makeLensesExcluding ['_completedIDs] ''ObjectiveCompletion + +-- | Initialize an objective completion tracking record from a list of +-- (initially incomplete) objectives. +initCompletion :: [Objective] -> ObjectiveCompletion +initCompletion objs = ObjectiveCompletion (CompletionBuckets objs [] []) mempty + +-- | A lens onto the 'CompletionBuckets' member of an +-- 'ObjectiveCompletion' record. This lens is not exported. +completionBuckets :: Lens' ObjectiveCompletion CompletionBuckets + +-- | A 'Getter' allowing one to read the set of completed objective +-- IDs for a given scenario. Note that this is a 'Getter', not a +-- 'Lens', to allow for read-only access without the possibility of +-- violating the internal invariants of 'ObjectiveCompletion'. +completedIDs :: Getter ObjectiveCompletion (Set.Set ObjectiveLabel) +completedIDs = to _completedIDs + +-- | A 'Fold' giving read-only access to all the incomplete objectives +-- tracked by an 'ObjectiveCompletion' record. Note that 'Fold' is +-- like a read-only 'Traversal', that is, it has multiple targets +-- but allows only reading them, not updating. In other words +-- 'Fold' is to 'Traversal' as 'Getter' is to 'Lens'. +-- +-- To get an actual list of objectives, use the '(^..)' operator, as +-- in @objCompl ^.. incompleteObjectives@, where @objCompl :: +-- ObjectiveCompletion@. +incompleteObjectives :: Fold ObjectiveCompletion Objective +incompleteObjectives = completionBuckets . folding _incomplete + +-- | A 'Fold' giving read-only access to all the completed objectives +-- tracked by an 'ObjectiveCompletion' record. See the +-- documentation for 'incompleteObjectives' for more about 'Fold'. +completedObjectives :: Fold ObjectiveCompletion Objective +completedObjectives = completionBuckets . folding _completed + +-- | A 'Fold' giving read-only access to all the unwinnable objectives +-- tracked by an 'ObjectiveCompletion' record. See the +-- documentation for 'incompleteObjectives' for more about 'Fold'. +unwinnableObjectives :: Fold ObjectiveCompletion Objective +unwinnableObjectives = completionBuckets . folding _unwinnable + +-- | A 'Fold' over /all/ objectives (whether incomplete, complete, or +-- unwinnable) tracked by an 'ObjectiveCompletion' record. See the +-- documentation for 'incompleteObjectives' for more about 'Fold'. +allObjectives :: Fold ObjectiveCompletion Objective +allObjectives = incompleteObjectives `concatFold` completedObjectives `concatFold` unwinnableObjectives + +-- | Add a completed objective to an 'ObjectiveCompletion' record, +-- being careful to maintain its internal invariants. +addCompleted :: Objective -> ObjectiveCompletion -> ObjectiveCompletion +addCompleted obj = + (completionBuckets . completed %~ (obj :)) + . (internalCompletedIDs %~ maybe id Set.insert (obj ^. objectiveId)) + +-- | Add an unwinnable objective to an 'ObjectiveCompletion' record, +-- being careful to maintain its internal invariants. +addUnwinnable :: Objective -> ObjectiveCompletion -> ObjectiveCompletion +addUnwinnable obj = completionBuckets . unwinnable %~ (obj :) + +-- | Add an incomplete objective to an 'ObjectiveCompletion' record, +-- being careful to maintain its internal invariants. +addIncomplete :: Objective -> ObjectiveCompletion -> ObjectiveCompletion +addIncomplete obj = completionBuckets . incomplete %~ (obj :) + +-- | Returns the 'ObjectiveCompletion' with the incomplete goals +-- extracted to a separate tuple member. This is intended to be +-- used as input to a fold. +extractIncomplete :: ObjectiveCompletion -> (ObjectiveCompletion, [Objective]) +extractIncomplete oc = + (withoutIncomplete, incompleteGoals) + where + incompleteGoals = oc ^. completionBuckets . incomplete + withoutIncomplete = oc & completionBuckets . incomplete .~ [] diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs @@ -0,0 +1,159 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utilities for performing graph analysis on Objective prerequisites +module Swarm.Game.Scenario.Objective.Graph where + +import Control.Arrow ((&&&)) +import Control.Lens (view, (^.), (^..)) +import Data.Aeson +import Data.BoolExpr (Signed (Positive)) +import Data.BoolExpr qualified as BE +import Data.Graph (Graph, SCC (AcyclicSCC), graphFromEdges, stronglyConnComp) +import Data.Map (Map) +import Data.Map.Strict qualified as M +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Tuple (swap) +import GHC.Generics (Generic) +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Logic as L + +-- | This is only needed for constructing a Graph, +-- which requires all nodes to have a key. +data ObjectiveId + = Label (Signed ObjectiveLabel) + | -- | for unlabeled objectives + Ordinal Int + deriving (Eq, Ord, Show, Generic, ToJSON) + +data GraphInfo = GraphInfo + { actualGraph :: Graph + , isAcyclic :: Bool + , sccInfo :: [SCC Objective] + , nodeIDs :: [ObjectiveId] + } + deriving (Show, Generic, ToJSON) + +instance ToJSON (SCC Objective) where + toJSON = String . T.pack . show + +instance ToJSON Graph where + toJSON = String . T.pack . show + +instance ToSample GraphInfo where + toSamples _ = SD.noSamples + +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 + +-- | Collect all of the constants that have a negation. +-- This is necessary for enumerating all of the distinct +-- nodes when constructing a Graph, as we treat a constant +-- and its negation as distinct nodes. +getNegatedIds :: [Objective] -> Map ObjectiveLabel Objective +getNegatedIds objs = + M.fromList $ mapMaybe f allConstants + where + objectivesById = getObjectivesById objs + + allPrereqExpressions = mapMaybe (view objectivePrerequisite) objs + allConstants = + mapMaybe onlyNegative + . Set.toList + . Set.unions + . map (getDistinctConstants . logic) + $ allPrereqExpressions + + f = sequenceA . \x -> (x, M.lookup x objectivesById) + + onlyNegative = \case + BE.Negative x -> Just x + _ -> Nothing + +getObjectivesById :: [Objective] -> Map ObjectiveLabel Objective +getObjectivesById objs = + M.fromList $ + map swap $ + mapMaybe (sequenceA . (id &&& view objectiveId)) objs + +-- | Uses the textual labels for those objectives that +-- have them, and assigns arbitrary integer IDs for +-- the remaining. +-- +-- Only necessary for constructing a "Graph". +assignIds :: [Objective] -> Map ObjectiveId Objective +assignIds objs = + unlabeledObjsMap <> labeledObjsMap + where + objectivesById = getObjectivesById objs + + labeledObjsMap = M.mapKeys (Label . Positive) objectivesById + + unlabeledObjs = filter (null . view objectiveId) objs + unlabeledObjsMap = M.fromList $ zipWith (\x y -> (Ordinal x, y)) [0 ..] unlabeledObjs + +type Edges = [(Objective, ObjectiveId, [ObjectiveId])] + +-- | NOTE: Based strictly on the goal labels, the graph could +-- potentially contain a cycle, if there exist +-- mutually-exclusive goals. That is, if goal A depends on the NOT +-- of "goal B". Goal B could then also depend on "NOT Goal A" (re-enforcing the +-- mutual-exclusivity), or it could mandate a completion order, e.g.: +-- Goal A and Goal B are simultaneously available to pursue. However, if the +-- player completes Goal B first, then it closes off the option to complete +-- Goal A. However, if Goal A is completed first, then the user is also allowed +-- to complete Goal B. +-- +-- To avoid a "cycle" in this circumstance, "A" needs to exist as a distinct node +-- from "NOT A" in the graph. +makeGraph :: Edges -> Graph +makeGraph edges = + myGraph + where + (myGraph, _, _) = graphFromEdges edges + +makeGraphEdges :: [Objective] -> Edges +makeGraphEdges objectives = + rootTuples <> negatedTuples + where + rootTuples = map f $ M.toList $ assignIds objectives + negatedTuples = map gg $ M.toList $ getNegatedIds objectives + gg (k, v) = (v, Label $ BE.Negative k, []) + + 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 = + GraphInfo + (makeGraph edges) + (isAcyclicGraph connectedComponents) + connectedComponents + (M.keys $ assignIds objs) + where + edges = makeGraphEdges objs + connectedComponents = stronglyConnComp edges + objs = oc ^.. allObjectives diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Logic.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Logic.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Logic.hs @@ -0,0 +1,49 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A model for defining boolean expressions for Objective prerequisites. +-- +-- This model is intended to be user-facing in the .yaml files, and is +-- distinct from that in 'Data.BoolExpr'. +module Swarm.Game.Scenario.Objective.Logic where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.BoolExpr +import Data.Char (toLower) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import GHC.Generics (Generic) + +type ObjectiveLabel = Text + +-- | In contrast with the "BoolExpr" type, +-- "And" and "Or" can have /one or more/ children +-- instead of /exactly two/. +data Prerequisite a + = And (NonEmpty (Prerequisite a)) + | Or (NonEmpty (Prerequisite a)) + | Not (Prerequisite a) + | Id a + deriving (Eq, Show, Generic, Functor, Foldable) + +prerequisiteOptions :: Options +prerequisiteOptions = + defaultOptions + { sumEncoding = ObjectWithSingleField + , constructorTagModifier = map toLower + } + +instance ToJSON (Prerequisite ObjectiveLabel) where + toJSON = genericToJSON prerequisiteOptions + +instance FromJSON (Prerequisite ObjectiveLabel) where + parseJSON x = preString x <|> genericParseJSON prerequisiteOptions x + where + preString = withText "prerequisite" $ pure . Id + +toBoolExpr :: Prerequisite a -> BoolExpr a +toBoolExpr (And xs) = foldr1 BAnd (fmap toBoolExpr xs) +toBoolExpr (Or xs) = foldr1 BOr (fmap toBoolExpr xs) +toBoolExpr (Not x) = BNot $ toBoolExpr x +toBoolExpr (Id x) = BConst $ pure x diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Validity checking for 'Objective' prerequisites +module Swarm.Game.Scenario.Objective.Validation where + +import Control.Lens (view, (^.)) +import Control.Monad (unless) +import Data.Foldable (for_, toList) +import Data.Graph (stronglyConnComp) +import Data.Maybe (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) + +-- | Performs monadic validation before returning +-- the "pure" construction of a wrapper record. +-- This validation entails: +-- +-- 1. Ensuring that all goal references utilized in prerequisites +-- actually exist +-- 2. Ensuring that the graph of dependencies is acyclic. +validateObjectives :: + MonadFail m => + [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 () + + unless (isAcyclicGraph connectedComponents) $ + failT ["There are dependency cycles in the prerequisites."] + + return objectives + where + connectedComponents = stronglyConnComp $ makeGraphEdges objectives + allIds = Set.fromList $ mapMaybe (view objectiveId) objectives diff --git a/src/swarm-scenario/Swarm/Game/Scenario/RobotLookup.hs b/src/swarm-scenario/Swarm/Game/Scenario/RobotLookup.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/RobotLookup.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.RobotLookup where + +import Control.Lens hiding (from, (<.>)) +import Data.Aeson (FromJSON) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Swarm.Game.Entity +import Swarm.Game.Robot (TRobot, trobotName) +import Swarm.Util (failT, quote) +import Swarm.Util.Yaml + +------------------------------------------------------------ +-- Robot map +------------------------------------------------------------ + +newtype RobotName = RobotName Text + deriving (Show, Eq, Ord, Generic, FromJSON) + +-- | A robot template paired with its definition's index within +-- the Scenario file +type IndexedTRobot = (Int, TRobot) + +-- | A map from names to robots, used to look up robots in scenario +-- descriptions. +type RobotMap = Map RobotName IndexedTRobot + +-- | Create a 'RobotMap' from a list of robot templates. +buildRobotMap :: [TRobot] -> RobotMap +buildRobotMap rs = M.fromList $ zipWith (\x y -> (RobotName $ view trobotName y, (x, y))) [0 ..] rs + +------------------------------------------------------------ +-- Lookup utilities +------------------------------------------------------------ + +-- | Look up a thing by name, throwing a parse error if it is not +-- found. +getThing :: Show k => Text -> (k -> m -> Maybe a) -> k -> ParserE m a +getThing thing lkup name = do + m <- getE + case lkup name m of + Nothing -> failT ["Unknown", thing, "name:", quote $ T.pack $ show name] + Just a -> return a + +-- | Look up an entity by name in an 'EntityMap', throwing a parse +-- error if it is not found. +getEntity :: Text -> ParserE EntityMap Entity +getEntity = getThing "entity" lookupEntityName + +-- | Look up a robot by name in a 'RobotMap', throwing a parse error +-- if it is not found. +getRobot :: RobotName -> ParserE RobotMap IndexedTRobot +getRobot = getThing "robot" M.lookup diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Style.hs b/src/swarm-scenario/Swarm/Game/Scenario/Style.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Style.hs @@ -0,0 +1,74 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types for styling custom entity attributes +module Swarm.Game.Scenario.Style where + +import Data.Aeson +import Data.Colour.Palette.BrewerSet (Kolor) +import Data.Colour.SRGB (sRGB24read, toSRGB24) +import Data.Set (Set) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Swarm.Game.Entity.Cosmetic + +data StyleFlag + = Standout + | Italic + | Strikethrough + | Underline + | ReverseVideo + | Blink + | Dim + | Bold + deriving (Eq, Ord, Show, Generic) + +styleFlagJsonOptions :: Options +styleFlagJsonOptions = + defaultOptions + { sumEncoding = UntaggedValue + } + +instance FromJSON StyleFlag where + parseJSON = genericParseJSON styleFlagJsonOptions + +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) + +data CustomAttr = CustomAttr + { name :: String + , fg :: Maybe HexColor + , bg :: Maybe HexColor + , style :: Maybe (Set StyleFlag) + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON CustomAttr where + toJSON = + genericToJSON + defaultOptions + { omitNothingFields = True + } + +-- | Must specify either a foreground or background color; +-- just a style is not sufficient. +toHifiPair :: CustomAttr -> Maybe (WorldAttr, PreservableColor) +toHifiPair (CustomAttr n maybeFg maybeBg _) = + sequenceA (WorldAttr n, fmap conv <$> c) + where + c = case (maybeFg, maybeBg) of + (Just f, Just b) -> Just $ FgAndBg f b + (Just f, Nothing) -> Just $ FgOnly f + (Nothing, Just b) -> Just $ BgOnly b + (Nothing, Nothing) -> Nothing + + conv (HexColor x) = Triple $ toSRGB24 kolor + where + kolor :: Kolor + kolor = sRGB24read $ T.unpack x diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Cell ( + PCell (..), + Cell, + AugmentedCell, + CellPaintDisplay, +) where + +import Control.Lens hiding (from, (.=), (<.>)) +import Control.Monad.Extra (mapMaybeM, unless) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as M +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Data.Yaml as Y +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Land +import Swarm.Game.Scenario.RobotLookup +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Scenario.Topography.ProtoCell +import Swarm.Game.Terrain +import Swarm.Util (quote, showT) +import Swarm.Util.Erasable (Erasable (..)) +import Swarm.Util.Yaml + +------------------------------------------------------------ +-- World cells +------------------------------------------------------------ + +-- | A single cell in a world map, which contains a terrain value, +-- and optionally an entity and robot. +-- It is parameterized on the 'Entity' type to facilitate less +-- stateful versions of the 'Entity' type in rendering scenario data. +data PCell e = Cell + { cellTerrain :: TerrainType + , cellEntity :: Erasable e + , cellRobots :: [IndexedTRobot] + } + deriving (Eq, Show) + +-- | A single cell in a world map, which contains a terrain value, +-- and optionally an entity and robot. +type Cell = PCell Entity + +-- | Supplements a cell with waypoint information +type AugmentedCell e = SignpostableCell (PCell e) + +-- | Re-usable serialization for variants of 'PCell' +mkPCellJson :: ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value +mkPCellJson modifier x = + toJSON $ + catMaybes + [ Just . toJSON . getTerrainWord $ cellTerrain x + , fmap toJSON . modifier $ cellEntity x + , listToMaybe [] + ] + +instance ToJSON Cell where + toJSON = mkPCellJson $ \case + EErase -> Just "erase" + ENothing -> Nothing + EJust e -> Just (e ^. entityName) + +-- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'. The +-- entity and robot, if present, are immediately looked up and +-- converted into 'Entity' and 'TRobot' values. If they are not +-- found, a parse error results. +instance FromJSONE (TerrainEntityMaps, RobotMap) Cell where + parseJSONE = withArrayE "tuple" $ \v -> do + let tupRaw = V.toList v + tup <- case NE.nonEmpty tupRaw of + Nothing -> fail "palette entry must have nonzero length (terrain, optional entity and then robots if any)" + Just x -> return x + + (TerrainEntityMaps tm _, _) <- getE + terr <- liftE $ parseJSON (NE.head tup) + unless (M.member terr $ terrainByName tm) + . fail + . T.unpack + $ T.unwords + [ "Unrecognized terrain type" + , quote $ getTerrainWord terr + , "Avaliable:" + , showT $ M.keys $ terrainByName tm + ] + + ent <- case tup ^? ix 1 of + Nothing -> return ENothing + Just e -> do + meName <- liftE $ parseJSON @(Maybe Text) e + case meName of + Nothing -> return ENothing + Just "erase" -> return EErase + Just name -> fmap EJust . localE (view entityMap . fst) $ getEntity name + + let name2rob r = do + mrName <- liftE $ parseJSON @(Maybe RobotName) r + traverse (localE snd . getRobot) mrName + + robs <- mapMaybeM name2rob (drop 2 tupRaw) + + return $ Cell terr ent robs + +------------------------------------------------------------ +-- World editor +------------------------------------------------------------ + +-- | Stateless cells used for the World Editor. +-- These cells contain the bare minimum display information +-- for rendering. +type CellPaintDisplay = PCell EntityFacade + +-- Note: This instance is used only for the purpose of 'WorldPalette' +instance ToJSON CellPaintDisplay where + toJSON = mkPCellJson $ \case + ENothing -> Nothing + EErase -> Just $ EntityFacade "erase" mempty + EJust e -> Just e diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Center.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Center.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Center.hs @@ -0,0 +1,35 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utility for determining the center of +-- the map, outside the context of a +-- running game +module Swarm.Game.Scenario.Topography.Center where + +import Control.Lens (view) +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (fromMaybe, listToMaybe) +import Swarm.Game.Location (Location, origin) +import Swarm.Game.Robot (trobotLocation) +import Swarm.Game.Scenario (ScenarioLandscape) +import Swarm.Game.State.Landscape (SubworldDescription, genRobotTemplates) +import Swarm.Game.Universe (Cosmic (..), SubworldName (DefaultRootSubworld)) + +-- | Determine view center for a static map +-- without reference to a 'GameState' +-- (i.e. outside the context of an active game) +determineStaticViewCenter :: + ScenarioLandscape -> + NonEmpty SubworldDescription -> + Cosmic Location +determineStaticViewCenter sLandscape worldTuples = + fromMaybe defaultVC baseRobotLoc + where + theRobots = genRobotTemplates sLandscape worldTuples + defaultVC = Cosmic DefaultRootSubworld origin + + -- The first robot is guaranteed to be the base. + baseRobotLoc :: Maybe (Cosmic Location) + baseRobotLoc = do + theBaseRobot <- listToMaybe theRobots + view trobotLocation theBaseRobot diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/EntityFacade.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/EntityFacade.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/EntityFacade.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DerivingVia #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Stand-in type for an "Entity" for purposes +-- that do not require carrying around the entire state +-- of an Entity. +-- +-- Useful for simplified serialization, debugging, +-- and equality checking, particularly for the World Editor. +module Swarm.Game.Scenario.Topography.EntityFacade where + +import Control.Lens ((^.)) +import Data.Yaml as Y (ToJSON (toJSON)) +import Swarm.Game.Display (Display) +import Swarm.Game.Entity qualified as E + +-- | This datatype is a lightweight stand-in for the +-- full-fledged "Entity" type without the baggage of all +-- of its other fields. +-- It contains the bare minimum display information +-- for rendering. +data EntityFacade = EntityFacade E.EntityName Display + deriving (Eq) + +-- Note: This instance is used only for the purpose of WorldPalette +instance ToJSON EntityFacade where + toJSON (EntityFacade eName _display) = toJSON eName + +mkFacade :: E.Entity -> EntityFacade +mkFacade e = + EntityFacade + (e ^. E.entityName) + (e ^. E.entityDisplay) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Type definitions and validation logic for portals. +-- +-- Portals can be inter-world or intra-world. +-- It is legal for a portal exit to be on the same cell as its entrance. +-- +-- By default, passage through a portal preserves the orientation +-- of the robot, but an extra portal parameter can specify +-- that the robot should be re-oriented. +module Swarm.Game.Scenario.Topography.Navigation.Portal where + +import Control.Arrow ((&&&)) +import Control.Lens (view) +import Control.Monad (forM, forM_, unless) +import Data.Aeson +import Data.Bifunctor (first) +import Data.BoolExpr (Signed (..)) +import Data.Function (on) +import Data.Functor.Identity +import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Text qualified as T +import Data.Tuple (swap) +import GHC.Generics (Generic) +import Linear (V2, negated) +import Swarm.Game.Location +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) + +type WaypointMap = M.Map WaypointName (NonEmpty Location) + +data AnnotatedDestination a = AnnotatedDestination + { enforceConsistency :: Bool + , reorientation :: Direction + , destination :: Cosmic a + } + deriving (Show, Eq) + +-- | Parameterized on waypoint dimensionality ('additionalDimension') and +-- on the portal location specification method ('portalExitLoc'). +-- +-- == @additionalDimension@ +-- As a member of the 'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription', waypoints are only known within a +-- a single subworld, so 'additionalDimension' is 'Identity' for the map +-- of waypoint names to planar locations. +-- At the Scenario level, in contrast, we have access to all subworlds, so +-- we nest this map to planar locations in additional mapping layer by subworld. +-- +-- == @portalExitLoc@ +-- At the subworld parsing level, we only can obtain the planar location +-- for portal /entrances/, but the /exits/ remain as waypoint names. +-- At the Scenario-parsing level, we finally have +-- access to the waypoints across all subworlds, and can therefore translate +-- the portal exits to concrete planar locations. +data Navigation additionalDimension portalExitLoc = Navigation + { waypoints :: additionalDimension WaypointMap + -- ^ Note that waypoints defined at the "root" level are still relative to + -- the top-left corner of the map rectangle; they are not in absolute world + -- coordinates (as with applying the "ul" offset). + , portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc) + } + +deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b) +deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b) + +data PortalExit = PortalExit + { exit :: WaypointName + , subworldName :: Maybe SubworldName + -- ^ Note: 'Nothing' indicates that references a waypoint within the same subworld. + } + deriving (Show, Eq, Generic, FromJSON) + +data Portal = Portal + { entrance :: WaypointName + , exitInfo :: PortalExit + , consistent :: Bool + , reorient :: PlanarRelativeDir + } + deriving (Show, Eq) + +instance FromJSON Portal where + parseJSON = withObject "Portal" $ \v -> do + entrance <- v .: "entrance" + exitInfo <- v .: "exitInfo" + consistent <- v .:? "consistent" .!= False + reorient <- v .:? "reorient" .!= DForward + pure Portal {..} + +failUponDuplication :: + (MonadFail m, Show a, Show b) => + T.Text -> + M.Map a (NonEmpty b) -> + m () +failUponDuplication message binnedMap = + forM_ (listToMaybe $ M.toList duplicated) $ \(pIn, pOuts) -> + failT + [ "Waypoint" + , showT pIn + , message + , T.intercalate ", " $ map showT $ NE.toList pOuts + ] + where + duplicated = M.filter ((> 1) . NE.length) binnedMap + +failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a +failWaypointLookup (WaypointName rawName) = + maybe (failT ["No waypoint named", quote rawName]) return + +-- | +-- The following constraints must be enforced: +-- +-- * portals based on plural waypoint multiplicity can have multiple entrances but only a single exit +-- * no two portals share the same entrance location +-- * waypoint uniqueness within a subworld when the 'unique' flag is specified +-- +-- == Data flow +-- +-- Waypoints are defined within a subworld and are namespaced by it. +-- Optional intra-subworld uniqueness of Waypoints is enforced at 'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription' +-- parse time. +-- Portals are declared within a subworld. The portal entrance must be a waypoint +-- within this subworld. +-- They can reference waypoints in other subworlds as exits, but these references +-- are not validated until the Scenario parse level. +-- +-- * Since portal /entrances/ are specified at the subworld level, validation that +-- no entrances overlap can also be performed at that level. +-- * However, enforcement of single-multiplicity on portal /exits/ must be performed +-- at scenario-parse level, because for a portal exit that references a waypoint in +-- another subworld, we can't know at the single-'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription' level whether +-- that waypoint has plural multiplicity. +validatePartialNavigation :: + (MonadFail m, Traversable t) => + SubworldName -> + Location -> + [Originated Waypoint] -> + t Portal -> + m (Navigation Identity WaypointName) +validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do + failUponDuplication "is required to be unique, but is duplicated in:" waypointsWithUniqueFlag + + nestedPortalPairs <- forM portalDefs $ \p -> do + let Portal entranceName (PortalExit exitName maybeExitSubworldName) isConsistent reOrient = p + -- Portals can have multiple entrances but only a single exit. + -- That is, the pairings of entries to exits must form a proper mathematical "function". + -- Multiple occurrences of entrance waypoints of a given name will result in + -- multiple portal entrances. + entranceLocs <- getLocs entranceName + + let sw = fromMaybe currentSubworldName maybeExitSubworldName + f = (,AnnotatedDestination isConsistent (DRelative $ DPlanar reOrient) $ Cosmic sw exitName) . extractLoc + return $ map f $ NE.toList entranceLocs + + let reconciledPortalPairs = concat nestedPortalPairs + + -- Aside from the enforcement of single-exit per portal, we apply another layer of + -- enforcement to ensure that no two portals share the same entrance location + failUponDuplication "has overlapping portal entrances exiting to" $ + binTuples reconciledPortalPairs + + return . Navigation (pure bareWaypoints) . M.fromList $ + map (first $ Cosmic currentSubworldName) reconciledPortalPairs + where + getLocs wpWrapper = failWaypointLookup wpWrapper $ M.lookup wpWrapper correctedWaypoints + + extractLoc (Originated _ (Waypoint _ loc)) = loc + correctedWaypoints = + binTuples $ + map + (\x -> (wpName $ wpConfig $ value x, fmap (offsetLoc $ upperLeft .-. origin) x)) + unmergedWaypoints + bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints + waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints + +validatePortals :: + MonadFail m => + Navigation (M.Map SubworldName) WaypointName -> + m (M.Map (Cosmic Location) (AnnotatedDestination Location)) +validatePortals (Navigation wpUniverse partialPortals) = do + portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, AnnotatedDestination isConsistent reOrient portalExit@(Cosmic swName (WaypointName rawExitName))) -> do + firstExitLoc :| otherExits <- getLocs portalExit + unless (null otherExits) $ + failT + [ "Ambiguous exit waypoints named" + , quote rawExitName + , "for portal" + ] + return (portalEntrance, AnnotatedDestination isConsistent reOrient $ Cosmic swName firstExitLoc) + + ensureSpatialConsistency portalPairs + + return $ M.fromList portalPairs + where + getLocs (Cosmic swName wpWrapper@(WaypointName exitName)) = do + subworldWaypoints <- case M.lookup swName wpUniverse of + Just x -> return x + Nothing -> + failT + [ "Could not lookup waypoint" + , quote exitName + , "for portal exit because subworld" + , quote $ renderWorldName swName + , "does not exist" + ] + + failWaypointLookup wpWrapper $ + M.lookup wpWrapper subworldWaypoints + +-- | A portal can be marked as \"consistent\", meaning that it represents +-- a conventional physical passage rather than a \"magical\" teleportation. +-- +-- If there exists more than one \"consistent\" portal between the same +-- two subworlds, then the portal locations must be spatially consistent +-- between the two worlds. I.e. the space comprising the two subworlds +-- forms a "conservative vector field". +-- +-- Verifying this is simple: +-- For all of the portals between Subworlds A and B: +-- +-- * The coordinates of all \"consistent\" portal locations in Subworld A +-- are subtracted from the corresponding coordinates in Subworld B. It +-- does not matter which are exits vs. entrances. +-- * The resulting \"vector\" from every pair must be equal. +ensureSpatialConsistency :: + MonadFail m => + [(Cosmic Location, AnnotatedDestination Location)] -> + m () +ensureSpatialConsistency xs = + unless (null nonUniform) $ + failT + [ "Non-uniform portal distances:" + , showT nonUniform + ] + where + consistentPairs :: [(Cosmic Location, Cosmic Location)] + consistentPairs = map (fmap destination) $ filter (enforceConsistency . snd) xs + + interWorldPairs :: [(Cosmic Location, Cosmic Location)] + interWorldPairs = filter (uncurry ((/=) `on` view subworld)) consistentPairs + + normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)] + normalizedOrdering = map normalizePairOrder interWorldPairs + + normalizePairOrder :: (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a) + normalizePairOrder pair = + if uncurry ((>) `on` view subworld) pair + then Negative $ swap pair + else Positive pair + + tuplify :: (Cosmic a, Cosmic a) -> ((SubworldName, SubworldName), (a, a)) + tuplify = both (view subworld) &&& both (view planar) + + getSigned :: Signed (V2 Int32) -> V2 Int32 + getSigned = \case + Positive x -> x + Negative x -> negated x + + groupedBySubworldPair :: + Map (SubworldName, SubworldName) (NonEmpty (Signed (Location, Location))) + groupedBySubworldPair = binTuples $ map (sequenceSigned . fmap tuplify) normalizedOrdering + + vectorized :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32)) + vectorized = M.map (NE.map (getSigned . fmap (uncurry (.-.)))) groupedBySubworldPair + + nonUniform :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32)) + nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized + +-- | +-- An implementation of 'sequenceA' for 'Signed' that does not +-- require an 'Applicative' instance for the inner 'Functor'. +-- +-- == Discussion +-- Compare to the 'Traversable' instance of 'Signed': +-- +-- @ +-- instance Traversable Signed where +-- traverse f (Positive x) = Positive <$> f x +-- traverse f (Negative x) = Negative <$> f x +-- @ +-- +-- if we were to substitute 'id' for f: +-- +-- @ +-- traverse id (Positive x) = Positive <$> id x +-- traverse id (Negative x) = Negative <$> id x +-- @ +-- our implementation essentially becomes @traverse id@. +-- +-- However, we cannot simply write our implementation as @traverse id@, because +-- the 'traverse' function has an 'Applicative' constraint, which is superfluous +-- for our purpose. +-- +-- Perhaps there is an opportunity to invent a typeclass for datatypes which +-- consist exclusively of unary (or more ambitiously, non-nullary?) data constructors, +-- for which a less-constrained 'sequence' function could be automatically derived. +-- Compare to the 'Comonad' class and its 'extract' function. +sequenceSigned :: + Functor f => + Signed (f a) -> + f (Signed a) +sequenceSigned = \case + Positive x -> Positive <$> x + Negative x -> Negative <$> x 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 new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs @@ -0,0 +1,115 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.WorldDescription where + +import Control.Carrier.Reader (runReader) +import Control.Carrier.Throw.Either +import Control.Monad (forM) +import Data.Coerce +import Data.Functor.Identity +import Data.Text qualified as T +import Data.Yaml as Y +import Swarm.Game.Entity +import Swarm.Game.Land +import Swarm.Game.Location +import Swarm.Game.Scenario.RobotLookup +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.Navigation.Portal +import Swarm.Game.Scenario.Topography.Navigation.Waypoint ( + Parentage (Root), + WaypointName, + ) +import Swarm.Game.Scenario.Topography.ProtoCell +import Swarm.Game.Scenario.Topography.Structure ( + LocatedStructure, + MergedStructure (MergedStructure), + NamedStructure, + PStructure (Structure), + paintMap, + ) +import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly +import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.WorldPalette +import Swarm.Game.Universe +import Swarm.Game.World.Parse () +import Swarm.Game.World.Syntax +import Swarm.Game.World.Typecheck +import Swarm.Language.Pretty (prettyString) +import Swarm.Util.Yaml + +------------------------------------------------------------ +-- World description +------------------------------------------------------------ + +-- | A description of a world parsed from a YAML file. +-- This type is parameterized to accommodate Cells that +-- utilize a less stateful Entity type. +data PWorldDescription e = WorldDescription + { offsetOrigin :: Bool + , scrollable :: Bool + , palette :: WorldPalette e + , ul :: Location + , area :: PositionedGrid (Maybe (PCell e)) + , navigation :: Navigation Identity WaypointName + , placedStructures :: [LocatedStructure] + , worldName :: SubworldName + , worldProg :: Maybe (TTerm '[] (World CellVal)) + } + deriving (Show) + +type WorldDescription = PWorldDescription Entity + +type InheritedStructureDefs = [NamedStructure (Maybe Cell)] + +data WorldParseDependencies + = WorldParseDependencies + WorldMap + InheritedStructureDefs + RobotMap + -- | 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 + + let withDeps = localE (const (tem, rm)) + palette <- + withDeps $ + v ..:? "palette" ..!= StructurePalette mempty + subworldLocalStructureDefs <- + withDeps $ + v ..:? "structures" ..!= [] + + let structureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs + MergedStructure area staticStructurePlacements unmergedWaypoints <- + liftE $ integrateArea palette structureDefs v + + worldName <- liftE $ v .:? "name" .!= DefaultRootSubworld + ul <- liftE $ v .:? "upperleft" .!= origin + portalDefs <- liftE $ v .:? "portals" .!= [] + navigation <- + validatePartialNavigation + worldName + ul + unmergedWaypoints + portalDefs + + 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 + + offsetOrigin <- liftE $ v .:? "offset" .!= False + scrollable <- liftE $ v .:? "scrollable" .!= True + let placedStructures = + map (offsetLoc $ coerce ul) staticStructurePlacements + return $ WorldDescription {..} + +------------------------------------------------------------ +-- World editor +------------------------------------------------------------ + +-- | A pared-down (stateless) version of "WorldDescription" just for +-- the purpose of rendering a Scenario file +type WorldDescriptionPaint = PWorldDescription EntityFacade + +instance ToJSON WorldDescriptionPaint where + toJSON w = + object + [ "offset" .= offsetOrigin w + , "palette" .= Y.toJSON paletteKeymap + , "upperleft" .= ul w + , "map" .= Y.toJSON mapText + ] + where + cellGrid = gridContent $ area w + suggestedPalette = PaletteAndMaskChar (palette w) Nothing + (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs @@ -0,0 +1,138 @@ +{-# 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 +import Data.Maybe (catMaybes) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Tuple (swap) +import Swarm.Game.Entity +import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.ProtoCell +import Swarm.Game.Terrain (TerrainType) +import Swarm.Util.Erasable + +-- | A world palette maps characters to 'Cell' values. +type WorldPalette e = StructurePalette (PCell e) + +type TerrainWith a = (TerrainType, Erasable a) + +cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade +cellToTerrainPair (Cell terrain erasableEntity _) = (terrain, erasableEntity) + +toCellPaintDisplay :: Cell -> CellPaintDisplay +toCellPaintDisplay (Cell terrain maybeEntity r) = + Cell terrain (mkFacade <$> maybeEntity) r + +toKey :: TerrainWith EntityFacade -> TerrainWith EntityName +toKey = fmap $ fmap (\(EntityFacade eName _display) -> eName) + +-- | We want to identify all of the unique (terrain, entity facade) pairs. +-- However, "EntityFacade" includes a "Display" record, which contains more +-- fields than desirable for use as a unique key. +-- Therefore, we extract just the entity name for use in a +-- (terrain, entity name) key, and couple it with the original +-- (terrain, entity facade) pair in a Map. +getUniqueTerrainFacadePairs :: + [CellPaintDisplay] -> + M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) +getUniqueTerrainFacadePairs cellGrid = + M.fromList $ map genTuple cellGrid + where + genTuple c = + (toKey terrainEfd, terrainEfd) + where + terrainEfd = cellToTerrainPair c + +constructPalette :: + [(Char, TerrainWith EntityFacade)] -> + KM.KeyMap CellPaintDisplay +constructPalette mappedPairs = + KM.fromMapText terrainEntityPalette + where + g (terrain, maybeEfd) = Cell terrain maybeEfd [] + terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs + +constructWorldMap :: + [(Char, TerrainWith EntityFacade)] -> + -- | Mask char + Char -> + Grid (Maybe CellPaintDisplay) -> + String +constructWorldMap mappedPairs maskChar = + unlines . getRows . fmap renderMapCell + where + invertedMappedPairs = map (swap . fmap toKey) mappedPairs + + renderMapCell maybeC = case maybeC of + Nothing -> maskChar + Just c -> + -- NOTE: This lookup should never fail + M.findWithDefault (error "Palette lookup failed!") k $ + M.fromList invertedMappedPairs + where + k = toKey $ cellToTerrainPair c + +-- | All alphanumeric characters. These are used as supplemental +-- map placeholders in case a pre-existing display character is +-- not available to re-use. +genericCharacterPool :: Set.Set Char +genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9'] + +data PaletteAndMaskChar = PaletteAndMaskChar + { paletteEntries :: WorldPalette EntityFacade + , reservedMaskChar :: Maybe Char + -- ^ represents a transparent cell + } + +-- | Note that display characters are not unique +-- across different entities! However, the palette KeyMap +-- as a conveyance serves to dedupe them. +prepForJson :: + PaletteAndMaskChar -> + Grid (Maybe CellPaintDisplay) -> + (String, KM.KeyMap CellPaintDisplay) +prepForJson (PaletteAndMaskChar (StructurePalette suggestedPalette) maybeMaskChar) cellGrid = + (constructWorldMap mappedPairs maskCharacter cellGrid, constructPalette mappedPairs) + where + preassignments :: [(Char, TerrainWith EntityFacade)] + preassignments = + map (first T.head . fmap (cellToTerrainPair . standardCell)) $ + M.toList $ + KM.toMapText suggestedPalette + + entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) + entityCells = getUniqueTerrainFacadePairs $ catMaybes $ allMembers cellGrid + + unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) + unassignedCells = + M.withoutKeys entityCells $ + Set.fromList $ + map (toKey . snd) preassignments + + (maskCharacter, availableCharacterPool) = case maybeMaskChar of + Just c -> (c, genericCharacterPool) + Nothing -> Set.deleteFindMin genericCharacterPool + + unassignedCharacters :: Set.Set Char + unassignedCharacters = + -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char") + -- to generate this pool? + Set.difference availableCharacterPool usedCharacters + where + usedCharacters = + Set.fromList $ + map fst preassignments + + newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)] + newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells + + mappedPairs = preassignments <> newlyAssignedPairs diff --git a/src/swarm-scenario/Swarm/Game/State/Config.hs b/src/swarm-scenario/Swarm/Game/State/Config.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/State/Config.hs @@ -0,0 +1,20 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Config data required by initializers of the +-- 'Swarm.Game.State.GameState' record and its subrecords. +module Swarm.Game.State.Config where + +import Data.Map (Map) +import Data.Text (Text) +import Swarm.Game.ResourceLoading (NameGenerator) +import Swarm.Game.Scenario (GameStateInputs) + +-- | Record to pass information needed to create an initial +-- 'GameState' record when starting a scenario. +data GameStateConfig = GameStateConfig + { initAppDataMap :: Map Text Text + , nameParts :: NameGenerator + -- ^ Lists of words/adjectives for use in building random robot names. + , initState :: GameStateInputs + } diff --git a/src/swarm-scenario/Swarm/Game/State/Landscape.hs b/src/swarm-scenario/Swarm/Game/State/Landscape.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/State/Landscape.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.State.Landscape ( + Landscape, + SubworldDescription, + + -- ** Lenses + worldNavigation, + multiWorld, + worldScrollable, + terrainAndEntities, + + -- ** Utilities + initLandscape, + mkLandscape, + buildWorldTuples, + genMultiWorld, + buildWorld, + genRobotTemplates, +) where + +import Control.Arrow (Arrow ((&&&))) +import Control.Lens hiding (Const, both, use, uses, (%=), (+=), (.=), (<+=), (<<.=)) +import Data.Array (Array, listArray) +import Data.Bifunctor (first) +import Data.Int (Int32) +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (isJust) +import Data.Tuple.Extra (both, swap) +import Swarm.Game.Entity +import Swarm.Game.Land +import Swarm.Game.Location +import Swarm.Game.Robot (TRobot, trobotLocation) +import Swarm.Game.Scenario +import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) +import Swarm.Game.Scenario.Topography.Structure.Overlay +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.Util.Erasable +import Swarm.Util.Lens (makeLensesNoSigs) + +type SubworldDescription = (SubworldName, ([IndexedTRobot], Seed -> WorldFun Int Entity)) + +data Landscape = Landscape + { _worldNavigation :: Navigation (M.Map SubworldName) Location + , _multiWorld :: MultiWorld Int Entity + , _terrainAndEntities :: TerrainEntityMaps + , _worldScrollable :: Bool + } + +makeLensesNoSigs ''Landscape + +-- | Includes a 'Map' of named locations and an +-- "edge list" (graph) that maps portal entrances to exits +worldNavigation :: Lens' Landscape (Navigation (M.Map SubworldName) Location) + +-- | The current state of the world (terrain and entities only; robots +-- are stored in the 'robotMap'). 'Int' is used instead of +-- 'TerrainType' because we need to be able to store terrain values in +-- unboxed tile arrays. +multiWorld :: Lens' Landscape (MultiWorld Int Entity) + +-- | The catalogs of all terrain and entities that the game knows about. +terrainAndEntities :: Lens' Landscape TerrainEntityMaps + +-- | Whether the world map is supposed to be scrollable or not. +worldScrollable :: Lens' Landscape Bool + +-- | Create an record that is empty except for +-- system-provided entities. +initLandscape :: GameStateConfig -> Landscape +initLandscape gsc = + Landscape + { _worldNavigation = Navigation mempty mempty + , _multiWorld = mempty + , _terrainAndEntities = initEntityTerrain $ gsiScenarioInputs $ initState gsc + , _worldScrollable = True + } + +mkLandscape :: ScenarioLandscape -> NonEmpty SubworldDescription -> Seed -> Landscape +mkLandscape sLandscape worldTuples theSeed = + Landscape + { _worldNavigation = sLandscape ^. scenarioNavigation + , _multiWorld = genMultiWorld worldTuples theSeed + , _terrainAndEntities = sLandscape ^. scenarioTerrainAndEntities + , -- 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. + _worldScrollable = NE.head (sLandscape ^. scenarioWorlds) ^. to scrollable + } + +buildWorldTuples :: ScenarioLandscape -> NonEmpty SubworldDescription +buildWorldTuples sLandscape = + NE.map (worldName &&& buildWorld (sLandscape ^. scenarioTerrainAndEntities)) $ + sLandscape ^. scenarioWorlds + +genMultiWorld :: NonEmpty SubworldDescription -> Seed -> MultiWorld Int Entity +genMultiWorld worldTuples s = + M.map genWorld + . M.fromList + . NE.toList + $ worldTuples + where + genWorld x = newWorld $ snd x s + +-- | Take a world description, parsed from a scenario file, and turn +-- it into a list of located robots and a world function. +buildWorld :: + TerrainEntityMaps -> + WorldDescription -> + ([IndexedTRobot], Seed -> WorldFun Int Entity) +buildWorld tem WorldDescription {..} = + (robots worldName, first getTerrainIndex . wf) + where + getTerrainIndex t = + M.findWithDefault 0 t $ + terrainIndexByName $ + tem ^. terrainMap + + g = gridContent area + + ulOffset = origin .-. gridPosition area + ulModified = ul .+^ ulOffset + + worldGrid :: Grid (TerrainType, Erasable Entity) + worldGrid = maybe (BlankT, ENothing) (cellTerrain &&& cellEntity) <$> g + + offsetCoordsByArea :: Coords -> AreaDimensions -> Coords + offsetCoordsByArea x a = + x `addTuple` swap (asTuple a) + + coords = locToCoords ulModified + + arrayMaxBound = + both (subtract 1) + . unCoords + . offsetCoordsByArea coords + $ getGridDimensions g + + arrayBoundsTuple = (unCoords coords, arrayMaxBound) + + worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity) + worldArray = listArray arrayBoundsTuple $ allMembers worldGrid + + dslWF, arrayWF :: Seed -> WorldFun TerrainType Entity + dslWF = maybe mempty ((applyWhen offsetOrigin findGoodOrigin .) . runWorld) worldProg + arrayWF = const $ worldFunFromArray worldArray + + wf = dslWF <> arrayWF + + -- Get all the robots described in cells and set their locations appropriately + robots :: SubworldName -> [IndexedTRobot] + robots swName = + concat $ mapIndexedMembers extractRobots g + where + extractRobots (Coords coordsTuple) maybeCell = + let robotWithLoc = trobotLocation ?~ Cosmic swName (coordsToLoc (coords `addTuple` coordsTuple)) + in map (fmap robotWithLoc) (maybe [] cellRobots maybeCell) + +-- | +-- Returns a list of robots, ordered by decreasing preference +-- to serve as the "base". +-- +-- = Rules for selecting the "base" robot: +-- +-- What follows is a thorough description of how the base +-- choice is made as of the most recent study of the code. +-- This level of detail is not meant to be public-facing. +-- +-- For an abbreviated explanation, see the "Base robot" section of the +-- . +-- +-- == Precedence rules +-- +-- 1. Prefer those robots defined with a @loc@ ('robotLocation') in the scenario file +-- +-- 1. If multiple robots define a @loc@, use the robot that is defined +-- first within the scenario file. +-- 2. Note that if a robot is both given a @loc@ AND is specified in the +-- world map, then two instances of the robot shall be created. The +-- instance with the @loc@ shall be preferred as the base. +-- +-- 2. Fall back to robots generated from templates via the map and palette. +-- +-- 1. If multiple robots are specified in the map, prefer the one that +-- is defined first within the scenario file. +-- 2. If multiple robots are instantiated from the same template, then +-- prefer the one with a lower-indexed subworld. Note that the root +-- subworld is always first. +-- 3. If multiple robots instantiated from the same template are in the +-- same subworld, then +-- prefer the one closest to the upper-left of the screen, with higher +-- rows given precedence over columns (i.e. first in row-major order). +genRobotTemplates :: ScenarioLandscape -> NonEmpty (a, ([(Int, TRobot)], b)) -> [TRobot] +genRobotTemplates sLandscape worldTuples = + locatedRobots ++ map snd (sortOn fst genRobots) + where + -- Keep only robots from the robot list with a concrete location; + -- the others existed only to serve as a template for robots drawn + -- in the world map + locatedRobots = filter (isJust . view trobotLocation) $ sLandscape ^. scenarioRobots + + -- Subworld order as encountered in the scenario YAML file is preserved for + -- the purpose of numbering robots, other than the "root" subworld + -- guaranteed to be first. + genRobots :: [(Int, TRobot)] + genRobots = concat $ NE.toList $ NE.map (fst . snd) worldTuples diff --git a/src/swarm-scenario/Swarm/Game/Terrain.hs b/src/swarm-scenario/Swarm/Game/Terrain.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Terrain.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Terrain types and properties. +module Swarm.Game.Terrain ( + TerrainType (..), + TerrainObj (..), + TerrainMap (..), + blankTerrainIndex, + getTerrainDefaultPaletteChar, + getTerrainWord, + terrainFromText, + loadTerrain, + mkTerrainMap, + validateTerrainAttrRefs, +) where + +import Control.Algebra (Has) +import Control.Arrow (first, (&&&)) +import Control.Effect.Lift (Lift, sendIO) +import Control.Effect.Throw (Throw, liftEither, throwError) +import Control.Monad (forM, unless, (<=<)) +import Data.Char (toUpper) +import Data.Hashable (Hashable) +import Data.IntMap (IntMap) +import Data.IntMap qualified as IM +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Tuple (swap) +import Data.Yaml +import GHC.Generics (Generic) +import Swarm.Game.Display +import Swarm.Game.Entity.Cosmetic (WorldAttr (..)) +import Swarm.Game.Failure +import Swarm.Game.ResourceLoading (getDataFileNameSafe) +import Swarm.Util (enumeratedMap, quote) +import Swarm.Util.Effect (withThrow) + +data TerrainType = BlankT | TerrainType Text + deriving (Eq, Ord, Show, Generic, ToJSON, Hashable) + +blankTerrainIndex :: Int +blankTerrainIndex = 0 + +terrainFromText :: Text -> TerrainType +terrainFromText "blank" = BlankT +terrainFromText x = TerrainType x + +getTerrainWord :: TerrainType -> Text +getTerrainWord BlankT = "blank" +getTerrainWord (TerrainType x) = x + +instance FromJSON TerrainType where + parseJSON = + withText "TerrainType" $ + return . terrainFromText + +instance Semigroup TerrainType where + t <> BlankT = t + _ <> t = t + +instance Monoid TerrainType where + mempty = BlankT + +getTerrainDefaultPaletteChar :: TerrainType -> Char +getTerrainDefaultPaletteChar = toUpper . T.head . getTerrainWord + +-- | Representation for parsing only. Not exported. +data TerrainItem = TerrainItem + { name :: TerrainType + , attr :: Text + , description :: Text + } + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + +data TerrainObj = TerrainObj + { terrainName :: TerrainType + , terrainDesc :: Text + , terrainDisplay :: Display + } + deriving (Show) + +promoteTerrainObjects :: [TerrainItem] -> [TerrainObj] +promoteTerrainObjects = + map (\(TerrainItem n a d) -> TerrainObj n d $ defaultTerrainDisplay (AWorld a)) + +invertedIndexMap :: IntMap TerrainObj -> Map TerrainType Int +invertedIndexMap = M.fromList . map (first terrainName . swap) . IM.toList + +-- | Each terrain type shall have a unique +-- integral index. The indices should +-- be consecutive by parse order. +data TerrainMap = TerrainMap + { terrainByName :: Map TerrainType TerrainObj + , terrainByIndex :: IntMap TerrainObj + , terrainIndexByName :: Map TerrainType Int + -- ^ basically the inverse of 'terrainByIndex'. + -- This needs to be (is) recomputed upon every update to + -- the other fields in 'TerrainMap'. + } + deriving (Show) + +instance Semigroup TerrainMap where + TerrainMap oldByName oldByIndex _ <> TerrainMap newByName newByIndex _ = + TerrainMap + (oldByName <> newByName) + combinedTerrainByIndex + (invertedIndexMap combinedTerrainByIndex) + where + combinedTerrainByIndex = oldByIndex <> enumeratedMap (IM.size oldByIndex) (IM.elems newByIndex) + +instance Monoid TerrainMap where + mempty = TerrainMap mempty mempty mempty + +mkTerrainMap :: [TerrainObj] -> TerrainMap +mkTerrainMap items = + TerrainMap + { terrainByName = M.fromList $ map (terrainName &&& id) items + , terrainByIndex = byIndex + , terrainIndexByName = invertedIndexMap byIndex + } + where + byIndex = enumeratedMap blankTerrainIndex items + +-- | Validates references to 'Display' attributes +validateTerrainAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [TerrainItem] -> m [TerrainObj] +validateTerrainAttrRefs validAttrs rawTerrains = + forM rawTerrains $ \(TerrainItem n a d) -> do + unless (Set.member (WorldAttr $ T.unpack a) validAttrs) + . throwError + . CustomMessage + $ T.unwords + [ "Nonexistent attribute" + , quote a + , "referenced by terrain" + , quote $ getTerrainWord n + ] + + return $ TerrainObj n d $ defaultTerrainDisplay (AWorld a) + +-- | Load terrain from a data file called @terrains.yaml@, producing +-- either an 'TerrainMap' or a parse error. +loadTerrain :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m TerrainMap +loadTerrain = do + fileName <- getDataFileNameSafe Terrain terrainFile + decoded <- + withThrow (terrainFailure . CanNotParseYaml) . (liftEither <=< sendIO) $ + decodeFileEither fileName + + let terrainObjs = promoteTerrainObjects decoded + -- Ensures that the blank terrain gets index 0 + return $ mkTerrainMap $ blankTerrainObj : terrainObjs + where + terrainFile = "terrains.yaml" + terrainFailure = AssetNotLoaded (Data Terrain) terrainFile + + blankTerrainObj = TerrainObj BlankT "Blank terrain" $ defaultTerrainDisplay ADefault diff --git a/src/swarm-scenario/Swarm/Game/World.hs b/src/swarm-scenario/Swarm/Game/World.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Grid on which the game takes place +-- +-- A /world/ refers to the grid on which the game takes place, and the +-- things in it (besides robots). A world has a base, immutable +-- /terrain/ layer, where each cell contains a terrain type, and a +-- mutable /entity/ layer, with at most one entity per cell. +-- +-- A world is technically finite but practically infinite (worlds are +-- indexed by 32-bit signed integers, so they correspond to a +-- \( 2^{32} \times 2^{32} \) torus). +module Swarm.Game.World ( + -- * Worlds + WorldFun (..), + runWF, + worldFunFromArray, + World, + MultiWorld, + + -- ** Tile management + loadCell, + loadRegion, + + -- ** World functions + newWorld, + lookupCosmicTerrain, + lookupTerrain, + lookupCosmicEntity, + lookupEntity, + update, + + -- ** Monadic variants + lookupTerrainM, + lookupEntityM, + lookupContentM, + updateM, + + -- ** Runtime updates + WorldUpdate (..), +) where + +import Control.Algebra (Has) +import Control.Arrow ((&&&)) +import Control.Effect.State (State, get, modify, state) +import Control.Lens +import Data.Array qualified as A +import Data.Array.IArray +import Data.Array.Unboxed qualified as U +import Data.Bifunctor (second) +import Data.Bits +import Data.Foldable (foldl') +import Data.Int (Int32) +import Data.IntMap qualified as IM +import Data.Map (Map) +import Data.Map.Strict qualified as M +import Data.Maybe (fromMaybe) +import Data.Semigroup (Last (..)) +import Data.Yaml (FromJSON, ToJSON) +import GHC.Generics (Generic) +import Swarm.Game.Entity (Entity) +import Swarm.Game.Location +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) + +------------------------------------------------------------ +-- World function +------------------------------------------------------------ + +-- | A @WorldFun t e@ represents a 2D world with terrain of type @t@ +-- (exactly one per cell) and entities of type @e@ (at most one per +-- cell). +newtype WorldFun t e = WF {getWF :: Coords -> (t, Erasable (Last e))} + deriving stock (Functor) + deriving newtype (Semigroup, Monoid) + +runWF :: WorldFun t e -> Coords -> (t, Maybe e) +runWF wf = second (erasableToMaybe . fmap getLast) . getWF wf + +instance Bifunctor WorldFun where + bimap g h (WF z) = WF (bimap g (fmap (fmap h)) . z) + +-- | Create a world function from a finite array of specified cells. +worldFunFromArray :: Monoid t => Array (Int32, Int32) (t, Erasable e) -> WorldFun t e +worldFunFromArray arr = WF $ \(Coords (r, c)) -> + if inRange bnds (r, c) + then second (fmap Last) (arr ! (r, c)) + else mempty + where + bnds = bounds arr + +------------------------------------------------------------ +-- Tiles and coordinates +------------------------------------------------------------ + +-- | The number of bits we need in each coordinate to represent all +-- the locations in a tile. In other words, each tile has a size of +-- @2^tileBits x 2^tileBits@. +-- +-- Currently, 'tileBits' is set to 6, giving us 64x64 tiles, with +-- 4096 cells in each tile. That seems intuitively like a good size, +-- but I don't have a good sense for the tradeoffs here, and I don't +-- know how much the choice of tile size matters. +tileBits :: Int +tileBits = 6 + +-- | The number consisting of 'tileBits' many 1 bits. We can use this +-- to mask out the tile offset of a coordinate. +tileMask :: Int32 +tileMask = (1 `shiftL` tileBits) - 1 + +-- | If we think of the world as a grid of /tiles/, we can assign each +-- tile some coordinates in the same way we would if each tile was a +-- single cell. These are the tile coordinates. +newtype TileCoords = TileCoords {unTileCoords :: Coords} + deriving (Eq, Ord, Show, Ix, Generic) + +instance Rewrapped TileCoords t +instance Wrapped TileCoords + +-- | Convert from a cell's coordinates to the coordinates of its tile, +-- simply by shifting out 'tileBits' many bits. +tileCoords :: Coords -> TileCoords +tileCoords = TileCoords . over (_Wrapped . both) (`shiftR` tileBits) + +-- | Find the coordinates of the upper-left corner of a tile. +tileOrigin :: TileCoords -> Coords +tileOrigin = over (_Wrapped . both) (`shiftL` tileBits) . unTileCoords + +-- | A 'TileOffset' represents an offset from the upper-left corner of +-- some tile to a cell in its interior. +newtype TileOffset = TileOffset Coords + deriving (Eq, Ord, Show, Ix, Generic) + +-- | The offsets of the upper-left and lower-right corners of a tile: +-- (0,0) to ('tileMask', 'tileMask'). +tileBounds :: (TileOffset, TileOffset) +tileBounds = (TileOffset (Coords (0, 0)), TileOffset (Coords (tileMask, tileMask))) + +-- | Compute the offset of a given coordinate within its tile. +tileOffset :: Coords -> TileOffset +tileOffset = TileOffset . over (_Wrapped . both) (.&. tileMask) + +-- | Add a tile offset to the coordinates of the tile's upper left +-- corner. NOTE that for efficiency, this function only works when +-- the first argument is in fact the coordinates of a tile's +-- upper-left corner (/i.e./ it is an output of 'tileOrigin'). In +-- that case the coordinates will end with all 0 bits, and we can +-- add the tile offset just by doing a coordinatewise 'xor'. +plusOffset :: Coords -> TileOffset -> Coords +plusOffset (Coords (x1, y1)) (TileOffset (Coords (x2, y2))) = Coords (x1 `xor` x2, y1 `xor` y2) + +instance Rewrapped TileOffset t +instance Wrapped TileOffset + +-- | A terrain tile is an unboxed array of terrain values. +type TerrainTile t = U.UArray TileOffset t + +-- | An entity tile is an array of possible entity values. Note it +-- cannot be an unboxed array since entities are complex records +-- which have to be boxed. +type EntityTile e = A.Array TileOffset (Maybe e) + +type MultiWorld t e = Map SubworldName (World t e) + +-- | A 'World' consists of a 'WorldFun' that specifies the initial +-- world, a cache of loaded square tiles to make lookups faster, and +-- a map storing locations whose entities have changed from their +-- initial values. +-- +-- Right now the 'World' simply holds on to all the tiles it has +-- ever loaded. Ideally it would use some kind of LRU caching +-- scheme to keep memory usage bounded, but it would be a bit +-- tricky, and in any case it's probably not going to matter much +-- for a while. Once tile loads can trigger robots to spawn, it +-- would also make for some difficult decisions in terms of how to +-- handle respawning. +data World t e = World + { _worldFun :: WorldFun t e + , _tileCache :: M.Map TileCoords (TerrainTile t, EntityTile e) + , _changed :: M.Map Coords (Maybe e) + } + +-- | Create a new 'World' from a 'WorldFun'. +newWorld :: WorldFun t e -> World t e +newWorld f = World f M.empty M.empty + +lookupCosmicTerrain :: + TerrainMap -> + Cosmic Coords -> + MultiWorld Int e -> + TerrainType +lookupCosmicTerrain tm (Cosmic subworldName i) multiWorld = + fromMaybe BlankT $ do + x <- M.lookup subworldName multiWorld + y <- (`IM.lookup` terrainByIndex tm) . lookupTerrain i $ x + return $ terrainName y + +-- | Look up the terrain value at certain coordinates: try looking it +-- up in the tile cache first, and fall back to running the 'WorldFun' +-- otherwise. +-- +-- This function does /not/ ensure that the tile containing the +-- given coordinates is loaded. For that, see 'lookupTerrainM'. +lookupTerrain :: (IArray U.UArray t) => Coords -> World t e -> t +lookupTerrain i (World f t _) = + ((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t) + ? fst (runWF f i) + +-- | A stateful variant of 'lookupTerrain', which first loads the tile +-- containing the given coordinates if it is not already loaded, +-- then looks up the terrain value. +lookupTerrainM :: + forall t e sig m. + (Has (State (World t e)) sig m, IArray U.UArray t) => + Coords -> + m t +lookupTerrainM c = do + modify @(World t e) $ loadCell c + lookupTerrain c <$> get @(World t e) + +lookupContentM :: + forall t e sig m. + (Has (State (World t e)) sig m, IArray U.UArray t) => + Coords -> + m (t, Maybe e) +lookupContentM c = do + modify @(World t e) $ loadCell c + w <- get @(World t e) + return (lookupTerrain c w, lookupEntity c w) + +lookupCosmicEntity :: Cosmic Coords -> MultiWorld t e -> Maybe e +lookupCosmicEntity (Cosmic subworldName i) multiWorld = + lookupEntity i =<< M.lookup subworldName multiWorld + +-- | Look up the entity at certain coordinates: first, see if it is in +-- the map of locations with changed entities; then try looking it +-- up in the tile cache first; and finally fall back to running the +-- 'WorldFun'. +-- +-- This function does /not/ ensure that the tile containing the +-- given coordinates is loaded. For that, see 'lookupEntityM'. +lookupEntity :: Coords -> World t e -> Maybe e +lookupEntity i (World f t m) = + M.lookup i m + ? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t) + ? snd (runWF f i) + +-- | A stateful variant of 'lookupEntity', which first loads the tile +-- containing the given coordinates if it is not already loaded, +-- then looks up the terrain value. +lookupEntityM :: + forall t e sig m. + (Has (State (World t e)) sig m, IArray U.UArray t) => + Coords -> + m (Maybe e) +lookupEntityM c = do + modify @(World t e) $ loadCell c + lookupEntity c <$> get @(World t e) + +-- | Update the entity (or absence thereof) at a certain location, +-- returning an updated 'World' and a Boolean indicating whether +-- the update changed the entity here. +-- See also 'updateM'. +update :: + Coords -> + (Maybe Entity -> Maybe Entity) -> + World t Entity -> + (World t Entity, CellUpdate Entity) +update i g w@(World f t m) = + (wNew, classifyModification entityBefore entityAfter) + where + wNew = World f t $ M.insert i entityAfter m + entityBefore = lookupEntity i w + entityAfter = g entityBefore + +-- | A stateful variant of 'update', which also ensures the tile +-- containing the given coordinates is loaded. +updateM :: + forall t sig m. + (Has (State (World t Entity)) sig m, IArray U.UArray t) => + Coords -> + (Maybe Entity -> Maybe Entity) -> + m (CellUpdate Entity) +updateM c g = do + state @(World t Entity) $ update c g . loadCell c + +-- | Load the tile containing a specific cell. +loadCell :: (IArray U.UArray t) => Coords -> World t e -> World t e +loadCell c = loadRegion (c, c) + +-- | Load all the tiles which overlap the given rectangular region +-- (specified as an upper-left and lower-right corner, inclusive). +loadRegion :: + forall t e. + (IArray U.UArray t) => + (Coords, Coords) -> + World t e -> + World t e +loadRegion reg (World f t m) = World f t' m + where + tiles = range (over both tileCoords reg) + t' = foldl' (\hm (i, tile) -> maybeInsert i tile hm) t (map (id &&& loadTile) tiles) + + maybeInsert k v tm + | k `M.member` tm = tm + | otherwise = M.insert k v tm + + loadTile :: TileCoords -> (TerrainTile t, EntityTile e) + loadTile tc = (listArray tileBounds terrain, listArray tileBounds entities) + where + tileCorner = tileOrigin tc + (terrain, entities) = unzip $ map (runWF f . plusOffset tileCorner) (range tileBounds) + +--------------------------------------------------------------------- +-- Runtime world update +--------------------------------------------------------------------- + +-- | Enumeration of world updates. This type is used for changes by +-- /e.g./ the @drill@ command which must be carried out at a later +-- tick. Using a first-order representation (as opposed to /e.g./ +-- just a @World -> World@ function) allows us to serialize and +-- inspect the updates. +data WorldUpdate e = ReplaceEntity + { updatedLoc :: Cosmic Location + , originalEntity :: e + , newEntity :: Maybe e + } + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) diff --git a/src/swarm-scenario/Swarm/Game/World/Abstract.hs b/src/swarm-scenario/Swarm/Game/World/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Abstract.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Explicitly type-preserving bracket abstraction, a la Oleg Kiselyov. +-- Turn elaborated, type-indexed terms into variableless, type-indexed +-- terms with only constants and application. +-- +-- For more information, see: +-- +-- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ +module Swarm.Game.World.Abstract where + +import Data.Kind (Type) +import Swarm.Game.World.Typecheck (Applicable (..), Const (..), HasConst (..), Idx (..), TTerm (..), ($$.), (.$$), (.$$.)) + +------------------------------------------------------------ +-- Bracket abstraction +------------------------------------------------------------ + +-------------------------------------------------- +-- Closed terms + +-- | Closed, fully abstracted terms. All computation is represented +-- by combinators. This is the ultimate target for the bracket +-- abstraction operation. +data BTerm :: Type -> Type where + BApp :: BTerm (a -> b) -> BTerm a -> BTerm b + BConst :: Const a -> BTerm a + +deriving instance Show (BTerm t) + +instance Applicable BTerm where + ($$) = BApp + +instance HasConst BTerm where + embed = BConst + +-------------------------------------------------- +-- Open terms + +-- | These explicitly open terms are an intermediate stage in the +-- bracket abstraction algorithm, /i.e./ they represent terms which have +-- been only partially abstracted. +data OTerm :: [Type] -> Type -> Type where + -- Embedded closed term. + E :: BTerm a -> OTerm g a + -- Reference to the innermost/top environment variable, i.e. Z + V :: OTerm (a ': g) a + -- Internalize the topmost env variable as a function argument + N :: OTerm g (a -> b) -> OTerm (a ': g) b + -- Ignore the topmost env variable + W :: OTerm g b -> OTerm (a ': g) b + +instance HasConst (OTerm g) where + embed = E . embed + +-- | Bracket abstraction: convert the 'TTerm' to an 'OTerm', then +-- project out the embedded 'BTerm'. GHC can see this is total +-- since 'E' is the only constructor that can produce an 'OTerm' +-- with an empty environment. +bracket :: TTerm '[] a -> BTerm a +bracket t = case conv t of + E t' -> t' + +-- | Type-preserving conversion from 'TTerm' to 'OTerm' ('conv' + the +-- 'Applicable' instance). Taken directly from Kiselyov. +conv :: TTerm g a -> OTerm g a +conv (TVar VZ) = V +conv (TVar (VS x)) = W (conv (TVar x)) +conv (TLam t) = case conv t of + V -> E (BConst I) + E d -> E (K .$$ d) + N e -> e + W e -> K .$$ e +conv (TApp t1 t2) = conv t1 $$ conv t2 +conv (TConst c) = embed c + +instance Applicable (OTerm g) where + ($$) :: OTerm g (a -> b) -> OTerm g a -> OTerm g b + W e1 $$ W e2 = W (e1 $$ e2) + W e $$ E d = W (e $$ E d) + E d $$ W e = W (E d $$ e) + W e $$ V = N e + V $$ W e = N (E (C .$$. I) $$ e) + W e1 $$ N e2 = N (B .$$ e1 $$ e2) + N e1 $$ W e2 = N (C .$$ e1 $$ e2) + N e1 $$ N e2 = N (S .$$ e1 $$ e2) + N e $$ V = N (S .$$ e $$. I) + V $$ N e = N (E (S .$$. I) $$ e) + E d $$ N e = N (E (B .$$ d) $$ e) + E d $$ V = N (E d) + V $$ E d = N (E (C .$$. I $$ d)) + N e $$ E d = N (E (C .$$. C $$ d) $$ e) + E d1 $$ E d2 = E (d1 $$ d2) + +-- There are only 15 cases above: GHC can tell that V $$ V is +-- impossible (it would be ill-typed)! diff --git a/src/swarm-scenario/Swarm/Game/World/Compile.hs b/src/swarm-scenario/Swarm/Game/World/Compile.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Compile.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Compiling abstracted combinator expressions ('BTerm') to native +-- Haskell terms. This can supposedly be more efficient than directly +-- interpreting 'BTerm's, but some benchmarking is probably needed to +-- decide whether we want this or not. +-- +-- For more info, see: +-- +-- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ +module Swarm.Game.World.Compile where + +import Data.ByteString (ByteString) +import Data.Hash.Murmur (murmur3) +import Data.Kind (Constraint) +import Data.Tagged (Tagged (unTagged)) +import Numeric.Noise.Perlin (noiseValue, perlin) +import Swarm.Game.Location (pattern Location) +import Swarm.Game.World.Abstract (BTerm (..)) +import Swarm.Game.World.Coords (Coords (..), coordsToLoc, locToCoords) +import Swarm.Game.World.Gen (Seed) +import Swarm.Game.World.Syntax (Axis (..), World) +import Swarm.Game.World.Typecheck (Applicable (..), Const (..), Empty (..), NotFun, Over (..)) +import Witch (from) +import Witch.Encoding qualified as Encoding + +data CTerm a where + CFun :: (CTerm a -> CTerm b) -> CTerm (a -> b) + CConst :: (NotFun a) => a -> CTerm a + +instance Applicable CTerm where + CFun f $$ x = f x + +compile :: Seed -> BTerm a -> CTerm a +compile seed (BApp b1 b2) = compile seed b1 $$ compile seed b2 +compile seed (BConst c) = compileConst seed c + +compileConst :: Seed -> Const a -> CTerm a +compileConst seed = \case + CLit i -> CConst i + CCell c -> CConst c + CFI -> unary fromIntegral + CIf -> CFun $ \(CConst b) -> CFun $ \t -> CFun $ \e -> if b then t else e + CNot -> unary not + CNeg -> unary negate + CAbs -> unary abs + CAnd -> binary (&&) + COr -> binary (||) + CAdd -> binary (+) + CSub -> binary (-) + CMul -> binary (*) + CDiv -> binary (/) + CIDiv -> binary div + CMod -> binary mod + CEq -> binary (==) + CNeq -> binary (/=) + CLt -> binary (<) + CLeq -> binary (<=) + CGt -> binary (>) + CGeq -> binary (>=) + CMask -> compileMask + CSeed -> CConst (fromIntegral seed) + CCoord ax -> CFun $ \(CConst (coordsToLoc -> Location x y)) -> CConst (fromIntegral (case ax of X -> x; Y -> y)) + CHash -> compileHash seed + CPerlin -> compilePerlin + COver -> binary () + CIMap -> compileIMap + K -> CFun $ \x -> CFun $ const x + S -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ x $$ (g $$ x) + I -> CFun id + B -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ (g $$ x) + C -> CFun $ \f -> CFun $ \x -> CFun $ \y -> f $$ y $$ x + Φ -> CFun $ \c -> CFun $ \f -> CFun $ \g -> CFun $ \x -> c $$ (f $$ x) $$ (g $$ x) + +unary :: (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b) +unary op = CFun $ \(CConst x) -> CConst (op x) + +binary :: (NotFun a, NotFun b, NotFun c) => (a -> b -> c) -> CTerm (a -> b -> c) +binary op = CFun $ \(CConst x) -> CFun $ \(CConst y) -> CConst (op x y) + +-- Note we could desugar 'mask p a -> if p a empty' but that would +-- require an explicit 'empty' node, whose type can't be inferred. +compileMask :: (NotFun a, Empty a) => CTerm (World Bool -> World a -> World a) +compileMask = CFun $ \p -> CFun $ \a -> CFun $ \ix -> + case p $$ ix of + CConst b -> if b then a $$ ix else CConst empty + +compileHash :: Seed -> CTerm (Coords -> Integer) +compileHash seed = CFun $ \(CConst (Coords ix)) -> CConst (fromIntegral (h ix)) + where + h = murmur3 (fromIntegral seed) . unTagged . from @String @(Encoding.UTF_8 ByteString) . show + +compilePerlin :: CTerm (Integer -> Integer -> Double -> Double -> World Double) +compilePerlin = + CFun $ \(CConst s) -> + CFun $ \(CConst o) -> + CFun $ \(CConst k) -> + CFun $ \(CConst p) -> + let noise = perlin (fromIntegral s) (fromIntegral o) k p + in CFun $ \(CConst (Coords ix)) -> CConst (sample ix noise) + where + sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0) + +compileIMap :: NotFun a => CTerm (World Integer -> World Integer -> World a -> World a) +compileIMap = + CFun $ \wx -> + CFun $ \wy -> + CFun $ \wa -> + CFun $ \c -> + let mkCoords :: CTerm Integer -> CTerm Integer -> CTerm Coords + mkCoords (CConst x) (CConst y) = CConst (locToCoords (Location (fromIntegral x) (fromIntegral y))) + in wa $$ mkCoords (wx $$ c) (wy $$ c) + +type family NoFunParams a :: Constraint where + NoFunParams (a -> b) = (NotFun a, NoFunParams b) + NoFunParams _ = () + +-- | Interpret a compiled term into the host language. +runCTerm :: (NoFunParams a) => CTerm a -> a +runCTerm (CConst a) = a +runCTerm (CFun f) = runCTerm . f . CConst diff --git a/src/swarm-scenario/Swarm/Game/World/Eval.hs b/src/swarm-scenario/Swarm/Game/World/Eval.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Eval.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Evaluation for the Swarm world description DSL. +module Swarm.Game.World.Eval ( + runWorld, +) where + +import Swarm.Game.Entity (Entity) +import Swarm.Game.Terrain (TerrainType (..)) +import Swarm.Game.World (WorldFun (..)) +import Swarm.Game.World.Abstract (bracket) +import Swarm.Game.World.Coords (Coords) +import Swarm.Game.World.Gen (Seed) +import Swarm.Game.World.Interpret (interpBTerm) +import Swarm.Game.World.Syntax +import Swarm.Game.World.Typecheck + +-- | Run a typechecked world description DSL term to produce a +-- 'WorldFun'. +runWorld :: TTerm '[] (World CellVal) -> Seed -> WorldFun TerrainType Entity +runWorld t seed = convertWF . interpBTerm seed . bracket $ t + +-- Currently we run a DSL term by performing bracket abstraction, +-- producing a 'BTerm', then directly interpreting the 'BTerm' with +-- 'interpBTerm'. We could also compile the 'BTerm' to a 'CTerm' and +-- run it, i.e. +-- +-- convertWF . runCTerm . compile seed . bracket $ t +-- +-- which can supposedly give a performance boost, but it is unclear +-- whether this actually makes a difference in our case. + +-- | Simple adapter function to convert a plain @Coords -> CellVal@ +-- function into a 'WorldFun' value. +convertWF :: (Coords -> CellVal) -> WorldFun TerrainType Entity +convertWF f = WF ((\(CellVal t e _) -> (t, e)) . f) diff --git a/src/swarm-scenario/Swarm/Game/World/Gen.hs b/src/swarm-scenario/Swarm/Game/World/Gen.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Gen.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- 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.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 + +type Seed = Int + +-- | Extract a list of all entities mentioned in a given world DSL term. +extractEntities :: TTerm g a -> S.Set Entity +extractEntities (TLam t) = extractEntities t +extractEntities (TApp t1 t2) = extractEntities t1 <> extractEntities t2 +extractEntities (TConst (CCell (CellVal _ ee _))) = getEntity ee + where + 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 new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Interpret.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Interpreter for the Swarm world description DSL. +module Swarm.Game.World.Interpret ( + interpBTerm, + interpConst, +) where + +import Control.Applicative (Applicative (..)) +import Data.ByteString (ByteString) +import Data.Hash.Murmur (murmur3) +import Data.Tagged (unTagged) +import Numeric.Noise.Perlin (noiseValue, perlin) +import Swarm.Game.Location (pattern Location) +import Swarm.Game.World.Abstract (BTerm (..)) +import Swarm.Game.World.Coords (Coords (..), coordsToLoc, locToCoords) +import Swarm.Game.World.Gen (Seed) +import Swarm.Game.World.Syntax (Axis (..)) +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 +interpBTerm seed (BApp f x) = interpBTerm seed f (interpBTerm seed x) +interpBTerm seed (BConst c) = interpConst seed c + +-- | Interpret a constant into the host language. +interpConst :: Seed -> Const a -> a +interpConst seed = \case + CLit a -> a + CCell c -> c + CIf -> \b t e -> if b then t else e + CNot -> not + CNeg -> negate + CAbs -> abs + CAnd -> (&&) + COr -> (||) + CAdd -> (+) + CSub -> (-) + CMul -> (*) + CDiv -> (/) + CIDiv -> div + CMod -> mod + CEq -> (==) + CNeq -> (/=) + CLt -> (<) + CLeq -> (<=) + CGt -> (>) + CGeq -> (>=) + CMask -> \b x c -> if b c then x c else empty + CSeed -> fromIntegral seed + CCoord ax -> \(coordsToLoc -> Location x y) -> fromIntegral (case ax of X -> x; Y -> y) + CHash -> \(Coords ix) -> fromIntegral . murmur3 (fromIntegral seed) . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ ix + CPerlin -> \s o k p -> + let noise = perlin (fromIntegral s) (fromIntegral o) k p + sample (i, j) = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0) + in \(Coords ix) -> sample ix + CFI -> fromInteger + COver -> () + CIMap -> \wx wy a c -> a (locToCoords (Location (fromIntegral (wx c)) (fromIntegral (wy c)))) + K -> const + S -> (<*>) + I -> id + B -> (.) + C -> flip + Φ -> liftA2 diff --git a/src/swarm-scenario/Swarm/Game/World/Load.hs b/src/swarm-scenario/Swarm/Game/World/Load.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Load.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Loading world descriptions from `worlds/*.world`. +module Swarm.Game.World.Load where + +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.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.Util (acquireAllWithExt) +import Swarm.Util.Effect (throwToWarning, 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. +loadWorlds :: + (Has (Accum (Seq 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 + +-- | Load a file containing a world DSL term, throwing an exception if +-- it fails to parse or typecheck. +loadWorld :: + (Has (Throw SystemFailure) sig m) => + FilePath -> + TerrainEntityMaps -> + (FilePath, String) -> + m (Text, Some (TTerm '[])) +loadWorld dir tem (fp, src) = do + wexp <- + liftEither . left (AssetNotLoaded (Data Worlds) fp . CanNotParseMegaparsec) $ + runParser parseWExp (into @Text src) + t <- + withThrow (AssetNotLoaded (Data Worlds) fp . DoesNotTypecheck . prettyText @CheckErr) $ + runReader tem . runReader @WorldMap M.empty $ + infer CNil wexp + return (into @Text (dropExtension (stripDir dir fp)), t) + +-- | Strip a leading directory from a 'FilePath'. +stripDir :: FilePath -> FilePath -> FilePath +stripDir dir fp = joinPath (drop (length (splitPath dir)) (splitPath fp)) diff --git a/src/swarm-scenario/Swarm/Game/World/Modify.hs b/src/swarm-scenario/Swarm/Game/World/Modify.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Modify.hs @@ -0,0 +1,41 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Parse.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +-- FromJSON WExp +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parser for the Swarm world description DSL. +module Swarm.Game.World.Parse where + +import Control.Monad (void) +import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) +import Control.Monad.Combinators.NonEmpty qualified as CNE (sepBy1) +import Data.List.Extra (enumerate) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import Data.Yaml (FromJSON (parseJSON), withText) +import Swarm.Game.World.Syntax +import Swarm.Language.Parser.Util (fully) +import Swarm.Util (failT, showT, squote) +import Text.Megaparsec hiding (runParser) +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L +import Witch (into) + +type Parser = Parsec Void Text +type ParserError = ParseErrorBundle Text Void + +------------------------------------------------------------ +-- Lexing + +reservedWords :: [Text] +reservedWords = + [ "not" + , "true" + , "false" + , "seed" + , "x" + , "y" + , "hash" + , "let" + , "in" + , "overlay" + , "hcat" + , "vcat" + , "if" + , "then" + , "else" + , "perlin" + , "mask" + , "empty" + , "abs" + , "imap" + ] + +-- | Skip spaces and comments. +sc :: Parser () +sc = + L.space + space1 + (L.skipLineComment "//") + (L.skipBlockComment "/*" "*/") + +-- | In general, we follow the convention that every token parser +-- assumes no leading whitespace and consumes all trailing +-- whitespace. Concretely, we achieve this by wrapping every token +-- parser using 'lexeme'. +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +-- | A lexeme consisting of a literal string. +symbol :: Text -> Parser Text +symbol = L.symbol sc + +operatorChar :: Parser Char +operatorChar = oneOf ("!@#$%^&*=+-/<>" :: String) + +operator :: Text -> Parser Text +operator op = (lexeme . try) $ string op <* notFollowedBy operatorChar + +-- | A positive integer literal token. +integerOrFloat :: Parser (Either Integer Double) +integerOrFloat = + label "numeric literal" $ + lexeme (Right <$> try L.float <|> Left <$> L.decimal) + +-- | Parse a case-insensitive reserved word, making sure it is not a +-- prefix of a longer variable name, and allowing the parser to +-- backtrack if it fails. +reserved :: Text -> Parser () +reserved w = (lexeme . try) $ string' w *> notFollowedBy (alphaNumChar <|> char '_') + +-- | Parse an identifier, i.e. any non-reserved string containing +-- alphanumeric characters and underscores and not starting with a +-- number. +identifier :: Parser Var +identifier = (lexeme . try) (p >>= check) "variable name" + where + p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'') + check (into @Text -> t) + | T.toLower t `elem` reservedWords = + failT ["reserved word", squote t, "cannot be used as variable name"] + | otherwise = return t + +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +braces :: Parser a -> Parser a +braces = between (symbol "{") (symbol "}") + +comma :: Parser () +comma = void $ symbol "," + +------------------------------------------------------------ +-- Parser + +---------------------------------------------------------------------- +-- NOTE: when updating the parser, be sure to update the BNF in +-- data/worlds/README.md to match! +---------------------------------------------------------------------- + +parseWExpAtom :: Parser WExp +parseWExpAtom = + either WInt WFloat <$> integerOrFloat + <|> WBool <$> (True <$ reserved "true" <|> False <$ reserved "false") + <|> parseCell + <|> WVar <$> identifier + <|> WSeed <$ reserved "seed" + <|> WCoord <$> (X <$ reserved "x" <|> Y <$ reserved "y") + <|> WHash <$ reserved "hash" + <|> parseIf + <|> parsePerlin + <|> parseAbs + <|> parseLet + <|> parseOverlay + <|> parseMask + <|> parseImport + <|> parseIMap + -- <|> parseCat + -- <|> parseStruct + <|> parens parseWExp + +parseWExp :: Parser WExp +parseWExp = + makeExprParser + parseWExpAtom + [ + [ Prefix (unary Not <$ reserved "not") + , Prefix (unary Neg <$ operator "-") + ] + , + [ InfixL (binary Mul <$ operator "*") + , InfixL (binary Div <$ operator "/") + , InfixL (binary Mod <$ operator "%") + ] + , + [ InfixL (binary Add <$ operator "+") + , InfixL (binary Sub <$ operator "-") + , InfixR (binary Overlay <$ operator "<>") + ] + , + [ InfixN (binary Eq <$ operator "==") + , InfixN (binary Neq <$ operator "/=") + , InfixN (binary Lt <$ operator "<") + , InfixN (binary Leq <$ operator "<=") + , InfixN (binary Gt <$ operator ">") + , InfixN (binary Geq <$ operator ">=") + ] + , [InfixR (binary And <$ operator "&&")] + , [InfixR (binary Or <$ operator "||")] + ] + where + unary op x = WOp op [x] + binary op x1 x2 = WOp op [x1, x2] + +parseCell :: Parser WExp +parseCell = + braces $ WCell <$> parseCellItem `sepBy1` comma + +parseCellItem :: Parser (Maybe CellTag, Text) +parseCellItem = + (,) + <$> optional (try (parseCellTag <* symbol ":")) + <*> parseName + +parseCellTag :: Parser CellTag +parseCellTag = choice (map mkCellTagParser (enumerate @CellTag)) + where + mkCellTagParser ct = ct <$ string' (T.drop 4 $ showT ct) + +parseName :: Parser Text +parseName = + into @Text + <$> manyTill anySingle (lookAhead (satisfy (\c -> c == ',' || c == '}' || c == ']'))) + +parseIf :: Parser WExp +parseIf = + (\i t e -> WOp If [i, t, e]) + <$> (reserved "if" *> parseWExp) + <*> (reserved "then" *> parseWExp) + <*> (reserved "else" *> parseWExp) + +parsePerlin :: Parser WExp +parsePerlin = + (\s o k p -> WOp Perlin [s, o, k, p]) + <$> (reserved "perlin" *> parseWExpAtom) + <*> parseWExpAtom + <*> parseWExpAtom + <*> parseWExpAtom + +parseAbs :: Parser WExp +parseAbs = + WOp Abs . (: []) <$> (reserved "abs" *> parseWExpAtom) + +parseLet :: Parser WExp +parseLet = + WLet + <$> ( reserved "let" + *> (((,) <$> identifier <*> (symbol "=" *> parseWExp)) `sepBy` comma) + ) + <*> (reserved "in" *> parseWExp) + +parseOverlay :: Parser WExp +parseOverlay = do + reserved "overlay" + brackets $ WOverlay <$> parseWExp `CNE.sepBy1` comma + +parseMask :: Parser WExp +parseMask = do + reserved "mask" + w1 <- parseWExpAtom + w2 <- parseWExpAtom + return $ WOp Mask [w1, w2] + +parseImport :: Parser WExp +parseImport = WImport . into @Text <$> between (symbol "\"") (symbol "\"") (some (satisfy (/= '"'))) + +parseIMap :: Parser WExp +parseIMap = do + reserved "imap" + wx <- parseWExpAtom + wy <- parseWExpAtom + wa <- parseWExpAtom + return $ WOp IMap [wx, wy, wa] + +-- parseCat :: Parser WExp +-- parseCat = +-- WCat +-- <$> (X <$ reserved "hcat" <|> Y <$ reserved "vcat") +-- <*> brackets (parseWExp `sepBy` comma) + +-- parseStruct :: Parser WExp +-- parseStruct = reserved "struct" *> fail "struct not implemented" + +------------------------------------------------------------ +-- Utility + +runParser :: Parser a -> Text -> Either ParserError a +runParser p = parse (fully sc p) "" + +------------------------------------------------------------ +-- JSON instance + +instance FromJSON WExp where + parseJSON = withText "World DSL program" $ \t -> + case runParser parseWExp t of + Left err -> error (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 new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Render.hs @@ -0,0 +1,189 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- GameState- and TUI-independent world rendering. +module Swarm.Game.World.Render where + +import Codec.Picture +import Control.Applicative ((<|>)) +import Control.Carrier.Throw.Either (runThrow) +import Control.Effect.Lift (Lift, sendIO) +import Control.Effect.Throw +import Control.Lens (view, (^.)) +import Data.Colour.SRGB (RGB (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Tuple.Extra (both) +import Linear (V2 (..)) +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.Topography.Area +import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.Center +import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade) +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Rasterize +import Swarm.Game.Scenario.Topography.Structure.Overlay +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.Util.Content +import Swarm.Util.Erasable (erasableToMaybe) +import System.IO (hPutStrLn, stderr) + +data OuputFormat + = ConsoleText + | PngImage + +data FailureMode + = Terminate + | RenderBlankImage + +-- | Command-line options for configuring the app. +data RenderOpts = RenderOpts + { renderSeed :: Maybe Seed + -- ^ Explicit seed chosen by the user. + , outputFormat :: OuputFormat + , outputFilepath :: FilePath + , gridSize :: Maybe AreaDimensions + , failureMode :: FailureMode + } + +getDisplayChar :: PCell EntityFacade -> Char +getDisplayChar = maybe ' ' facadeChar . erasableToMaybe . cellEntity + 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 :: + Location -> + PWorldDescription e -> + Maybe AreaDimensions -> + BoundsRectangle +getBoundingBox vc scenarioWorld maybeSize = + mkBoundingBox areaDims upperLeftLocation + where + upperLeftLocation = + if null maybeSize && not (isEmpty mapAreaDims) + then ul scenarioWorld + else vc .+^ ((`div` 2) <$> V2 (negate w) h) + + mkBoundingBox areaDimens upperLeftLoc = + both locToCoords locationBounds + where + lowerRightLocation = computeBottomRightFromUpperLeft areaDimens upperLeftLoc + locationBounds = (upperLeftLoc, lowerRightLocation) + + worldArea = gridContent $ area scenarioWorld + mapAreaDims = getGridDimensions worldArea + areaDims@(AreaDimensions w h) = + fromMaybe (AreaDimensions 20 10) $ + maybeSize <|> surfaceEmpty isEmpty mapAreaDims + +getDisplayGrid :: + Location -> + ScenarioLandscape -> + Landscape -> + Maybe AreaDimensions -> + Grid CellPaintDisplay +getDisplayGrid vc sLandscape ls maybeSize = + getMapRectangle + mkFacade + (getContentAt (sLandscape ^. scenarioTerrainAndEntities . terrainMap) worlds . mkCosmic) + (getBoundingBox vc firstScenarioWorld maybeSize) + where + mkCosmic = Cosmic $ worldName firstScenarioWorld + worlds = view multiWorld ls + + firstScenarioWorld = NE.head $ view scenarioWorlds sLandscape + +getRenderableGrid :: + (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 + (myScenario, _gsi) <- loadStandaloneScenario fp + let sLandscape = myScenario ^. scenarioLandscape + theSeed <- sendIO $ arbitrateSeed maybeSeed sLandscape + + let worldTuples = buildWorldTuples sLandscape + myLandscape = mkLandscape sLandscape worldTuples theSeed + + vc = + view planar $ + determineStaticViewCenter sLandscape worldTuples + + return (getDisplayGrid vc sLandscape myLandscape maybeSize, sLandscape ^. scenarioCosmetics) + +doRenderCmd :: RenderOpts -> FilePath -> IO () +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 + return $ getRows $ getDisplayChar <$> grid + +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 + writePng (outputFilepath opts) img + +printScenarioMap :: [String] -> IO () +printScenarioMap = + sendIO . mapM_ putStrLn diff --git a/src/swarm-scenario/Swarm/Game/World/Syntax.hs b/src/swarm-scenario/Swarm/Game/World/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Syntax.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Abstract syntax for the Swarm world description DSL. +module Swarm.Game.World.Syntax ( + -- | Various component types + World, + RawCellVal, + CellTag (..), + CellVal (..), + Var, + Axis (..), + Op (..), + -- | The main AST type + WExp (..), +) +where + +import Control.Lens (view, (^.)) +import Data.List.NonEmpty qualified as NE +import Data.Semigroup (Last (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Prettyprinter +import Swarm.Game.Entity (Entity, entityName) +import Swarm.Game.Robot (TRobot, trobotName) +import Swarm.Game.Terrain +import Swarm.Game.World.Coords +import Swarm.Language.Pretty +import Swarm.Util (showT) +import Swarm.Util.Erasable + +------------------------------------------------------------ +-- Bits and bobs + +type World b = Coords -> b + +data CellTag = CellTerrain | CellEntity | CellRobot + deriving (Eq, Ord, Show, Enum, Bounded) + +instance PrettyPrec CellTag where + prettyPrec _ = \case + CellTerrain -> "terrain" + CellEntity -> "an entity" + CellRobot -> "a robot" + +type RawCellVal = [(Maybe CellTag, Text)] + +prettyRawCellItem :: (Maybe CellTag, Text) -> Doc ann +prettyRawCellItem (Nothing, t) = pretty t +prettyRawCellItem (Just tag, t) = pretty (T.toLower . T.drop 4 . showT $ tag) <> ":" <> pretty t + +data CellVal = CellVal TerrainType (Erasable (Last Entity)) [TRobot] + deriving (Eq, Show) + +instance PrettyPrec CellVal where + prettyPrec _ (CellVal terr ent rs) = + "{" <> hsep (punctuate "," (map prettyRawCellItem items)) <> "}" + where + items = + [(Just CellTerrain, getTerrainWord terr) | terr /= BlankT] + ++ [(Just CellEntity, e ^. entityName) | EJust (Last e) <- [ent]] + ++ map ((Just CellRobot,) . view trobotName) rs + +type Var = Text + +data Axis = X | Y + deriving (Eq, Ord, Show, Bounded, Enum) + +instance PrettyPrec Axis where + prettyPrec _ = \case X -> "x"; Y -> "y" + +data Op = Not | Neg | And | Or | Add | Sub | Mul | Div | Mod | Eq | Neq | Lt | Leq | Gt | Geq | If | Perlin | Mask | Overlay | Abs | IMap + deriving (Eq, Ord, Show) + +------------------------------------------------------------ +-- Main AST + +data WExp where + WInt :: Integer -> WExp + WFloat :: Double -> WExp + WBool :: Bool -> WExp + WCell :: RawCellVal -> WExp + WVar :: Text -> WExp + -- Require all operators to be fully saturated. Just embedding + -- operators as constants and including function application would + -- be a more elegant encoding, but it requires being more clever + -- with type inference. + WOp :: Op -> [WExp] -> WExp + WSeed :: WExp + WCoord :: Axis -> WExp + WHash :: WExp + WLet :: [(Var, WExp)] -> WExp -> WExp + WOverlay :: NE.NonEmpty WExp -> WExp + WImport :: Text -> WExp + deriving (Eq, Show) + +-- We don't have an explicit Empty case because we can't infer its +-- type. It could be done but it would require a lot more care with +-- inference vs checking mode. + +-- TODO (#1394): Add hcat and vcat operations +-- WCat :: Axis -> [WExp] -> WExp + +-- TODO (#1394): Add support for structures +-- WStruct :: WorldPalette Text -> [Text] -> WExp diff --git a/src/swarm-scenario/Swarm/Game/World/Typecheck.hs b/src/swarm-scenario/Swarm/Game/World/Typecheck.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/World/Typecheck.hs @@ -0,0 +1,699 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Typechecking and elaboration for the Swarm world DSL. For more +-- information, see: +-- +-- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ +module Swarm.Game.World.Typecheck where + +import Control.Algebra (Has) +import Control.Effect.Reader (Reader, ask) +import Control.Effect.Throw (Throw, throwError) +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) +import Data.Map qualified as M +import Data.Semigroup (Last (..)) +import Data.Text (Text) +import Data.Type.Equality (TestEquality (..), type (:~:) (Refl)) +import Prettyprinter +import Swarm.Game.Entity (lookupEntityName) +import Swarm.Game.Land +import Swarm.Game.Terrain +import Swarm.Game.World.Syntax +import Swarm.Language.Pretty +import Swarm.Util (showT) +import Swarm.Util.Erasable +import Prelude hiding (lookup) + +------------------------------------------------------------ +-- Type classes for monoidal world values + +-- We could use Semigroup and Monoid, but we want to use the two +-- classes separately and make instances for base types, so it's +-- cleaner to just make our own classes (the instances would be +-- orphans if we used Semigroup and Monoid). + +class Empty e where + empty :: e + +instance Empty CellVal where + empty = CellVal mempty mempty mempty + +class Over m where + () :: m -> m -> m + +instance Over Bool where + _ x = x + +instance Over Integer where + _ x = x + +instance Over Double where + _ x = x + +instance Over CellVal where + CellVal t1 e1 r1 CellVal t2 e2 r2 = CellVal (t1 <> t2) (e1 <> e2) (r1 <> r2) + +------------------------------------------------------------ +-- Type class for type-indexed application + +infixl 1 $$ +class Applicable t where + ($$) :: t (a -> b) -> t a -> t b + +------------------------------------------------------------ +-- Distinguishing functions and non-functions at the type level + +-- In several places, for efficiency we will require something to be +-- not a function, which we can enforce using the 'NotFun' constraint. + +type family IsFun a where + IsFun (_ -> _) = 'True + IsFun _ = 'False + +type NotFun a = IsFun a ~ 'False + +------------------------------------------------------------ +-- Type-indexed constants + +-- | Type-indexed constants. These include both language built-ins +-- (@if@, arithmetic, comparison, @<>@, etc.) as well as combinators +-- (@S@, @I@, @C@, @K@, @B@, @Φ@) we will use both for elaboration +-- and later as a compilation target. +data Const :: Type -> Type where + CLit :: (Show a, NotFun a) => a -> Const a + CCell :: CellVal -> Const CellVal + -- We have a separate CCell instead of using CLit for cells so that we can + -- later extract all the entities from a world expression. + CFI :: Const (Integer -> Double) + CIf :: Const (Bool -> a -> a -> a) + CNot :: Const (Bool -> Bool) + CNeg :: (Num a, NotFun a) => Const (a -> a) + CAbs :: (Num a, NotFun a) => Const (a -> a) + CAnd :: Const (Bool -> Bool -> Bool) + COr :: Const (Bool -> Bool -> Bool) + CAdd :: (Num a, NotFun a) => Const (a -> a -> a) + CSub :: (Num a, NotFun a) => Const (a -> a -> a) + CMul :: (Num a, NotFun a) => Const (a -> a -> a) + CDiv :: (Fractional a, NotFun a) => Const (a -> a -> a) + CIDiv :: (Integral a, NotFun a) => Const (a -> a -> a) + CMod :: (Integral a, NotFun a) => Const (a -> a -> a) + CEq :: (Eq a, NotFun a) => Const (a -> a -> Bool) + CNeq :: (Eq a, NotFun a) => Const (a -> a -> Bool) + CLt :: (Ord a, NotFun a) => Const (a -> a -> Bool) + CLeq :: (Ord a, NotFun a) => Const (a -> a -> Bool) + CGt :: (Ord a, NotFun a) => Const (a -> a -> Bool) + CGeq :: (Ord a, NotFun a) => Const (a -> a -> Bool) + CMask :: (Empty a, NotFun a) => Const (World Bool -> World a -> World a) + CSeed :: Const Integer + CCoord :: Axis -> Const (World Integer) + CHash :: Const (World Integer) + CPerlin :: Const (Integer -> Integer -> Double -> Double -> World Double) + COver :: (Over a, NotFun a) => Const (a -> a -> a) + CIMap :: NotFun a => Const (World Integer -> World Integer -> World a -> World a) + -- Combinators generated during elaboration + variable abstraction + K :: Const (a -> b -> a) + S :: Const ((a -> b -> c) -> (a -> b) -> a -> c) + I :: Const (a -> a) + B :: Const ((b -> c) -> (a -> b) -> a -> c) + C :: Const ((a -> b -> c) -> b -> a -> c) + -- Phoenix combinator, aka liftA2. Including this combinator in the + -- target set is not typical, but it turns out to be very helpful in + -- elaborating the "over" operation. + Φ :: Const ((a -> b -> c) -> (d -> a) -> (d -> b) -> (d -> c)) + +deriving instance Show (Const ty) + +class HasConst t where + embed :: Const a -> t a + +infixl 1 .$$ +(.$$) :: (HasConst t, Applicable t) => Const (a -> b) -> t a -> t b +c .$$ t = embed c $$ t + +infixl 1 $$. +($$.) :: (HasConst t, Applicable t) => t (a -> b) -> Const a -> t b +t $$. c = t $$ embed c + +infixl 1 .$$. +(.$$.) :: (HasConst t, Applicable t) => Const (a -> b) -> Const a -> t b +c1 .$$. c2 = embed c1 $$ embed c2 + +instance PrettyPrec (Const α) where + prettyPrec _ = \case + CLit a -> pretty (showT a) + CCell c -> ppr c + CFI -> "fromIntegral" + CIf -> "if" + CNot -> "not" + CNeg -> "negate" + CAbs -> "abs" + CAnd -> "and" + COr -> "or" + CAdd -> "add" + CSub -> "sub" + CMul -> "mul" + CDiv -> "div" + CIDiv -> "idiv" + CMod -> "mod" + CEq -> "eq" + CNeq -> "neq" + CLt -> "lt" + CLeq -> "leq" + CGt -> "gt" + CGeq -> "geq" + CMask -> "mask" + CSeed -> "seed" + CCoord ax -> ppr ax + CHash -> "hash" + CPerlin -> "perlin" + COver -> "over" + CIMap -> "imap" + K -> "K" + S -> "S" + I -> "I" + B -> "B" + C -> "C" + Φ -> "Φ" + +------------------------------------------------------------ +-- Intrinsically typed core language + +-- | Type-level list append. +type family Append (xs :: [k]) (ys :: [k]) :: [k] where + Append '[] ys = ys + Append (x ': xs) ys = x ': Append xs ys + +-- | Type- and context-indexed de Bruijn indices. (v :: Idx g a) means +-- v represents a variable with type a in a type context g. +data Idx :: [Type] -> Type -> Type where + VZ :: Idx (ty ': g) ty + VS :: Idx g ty -> Idx (x ': g) ty + +deriving instance Show (Idx g ty) + +idxToNat :: Idx g a -> Int +idxToNat VZ = 0 +idxToNat (VS x) = 1 + idxToNat x + +-- | A variable valid in one context is also valid in another extended +-- context with additional variables. +weakenVar :: forall h g a. Idx g a -> Idx (Append g h) a +weakenVar VZ = VZ +weakenVar (VS x) = VS (weakenVar @h x) + +-- | Type-indexed terms. Note this is a stripped-down core language, +-- with only variables, lambdas, application, and constants. +data TTerm :: [Type] -> Type -> Type where + TVar :: Idx g a -> TTerm g a + TLam :: TTerm (ty1 ': g) ty2 -> TTerm g (ty1 -> ty2) + TApp :: TTerm g (a -> b) -> TTerm g a -> TTerm g b + TConst :: Const a -> TTerm g a + +deriving instance Show (TTerm g ty) + +instance Applicable (TTerm g) where + TConst I $$ x = x + f $$ x = TApp f x + +instance HasConst (TTerm g) where + embed = TConst + +instance PrettyPrec (TTerm g α) where + prettyPrec :: Int -> TTerm g α -> Doc ann + prettyPrec p = \case + TVar ix -> pretty (idxToNat ix) + TLam t -> + pparens (p > 0) $ + "λ." <+> ppr t + TApp t1 t2 -> + pparens (p > 1) $ + prettyPrec 1 t1 <+> prettyPrec 2 t2 + TConst c -> ppr c + +-- | A term valid in one context is also valid in another extended +-- context with additional variables (which the term does not use). +weaken :: forall h g a. TTerm g a -> TTerm (Append g h) a +weaken (TVar x) = TVar (weakenVar @h x) +weaken (TLam t) = TLam (weaken @h t) +weaken (TApp t1 t2) = TApp (weaken @h t1) (weaken @h t2) +weaken (TConst c) = TConst c + +------------------------------------------------------------ +-- Errors + +-- | Errors that can occur during typechecking/elaboration. +data CheckErr where + ApplyErr :: Some (TTerm g) -> Some (TTerm g) -> CheckErr + NoInstance :: Text -> TTy a -> CheckErr + Unbound :: Text -> CheckErr + BadType :: Some (TTerm g) -> TTy b -> CheckErr + BadDivType :: TTy a -> CheckErr + UnknownImport :: Text -> CheckErr + NotAThing :: Text -> CellTag -> CheckErr + NotAnything :: Text -> CheckErr + +deriving instance Show CheckErr + +instance PrettyPrec CheckErr where + prettyPrec _ = \case + ApplyErr (Some ty1 t1) (Some ty2 t2) -> + nest 2 . vsep $ + [ "Error in application:" + , squotes (ppr t1) <> " has type " <> squotes (ppr ty1) + , "and cannot be applied to" + , squotes (ppr t2) <> " which has type " <> squotes (ppr ty2) + ] + NoInstance cls ty -> squotes (ppr ty) <+> "is not an instance of" <+> pretty cls + Unbound x -> "Undefined variable" <+> pretty x + BadType (Some tty t) ty -> + 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) + 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) + +------------------------------------------------------------ +-- Type representations + +-- | Base types. +data Base :: Type -> Type where + BInt :: Base Integer + BFloat :: Base Double + BBool :: Base Bool + BCell :: Base CellVal + +deriving instance Show (Base ty) + +-- | Testing base type representations for equality to yield reflected +-- type-level equalities. +instance TestEquality Base where + testEquality BInt BInt = Just Refl + testEquality BFloat BFloat = Just Refl + testEquality BBool BBool = Just Refl + testEquality BCell BCell = Just Refl + testEquality _ _ = Nothing + +instance PrettyPrec (Base α) where + prettyPrec _ = \case + BInt -> "int" + BFloat -> "float" + BBool -> "bool" + BCell -> "cell" + +-- | Type representations indexed by the corresponding host language +-- type. +data TTy :: Type -> Type where + TTyBase :: Base t -> TTy t + (:->:) :: TTy a -> TTy b -> TTy (a -> b) + TTyWorld :: TTy t -> TTy (World t) + +infixr 0 :->: + +pattern TTyBool :: TTy Bool +pattern TTyBool = TTyBase BBool + +pattern TTyInt :: TTy Integer +pattern TTyInt = TTyBase BInt + +pattern TTyFloat :: TTy Double +pattern TTyFloat = TTyBase BFloat + +pattern TTyCell :: TTy CellVal +pattern TTyCell = TTyBase BCell + +deriving instance Show (TTy ty) + +-- | Testing type representations for equality to yield reflected +-- type-level equalities. +instance TestEquality TTy where + testEquality (TTyBase b1) (TTyBase b2) = testEquality b1 b2 + testEquality (TTyWorld b1) (TTyWorld b2) = + case testEquality b1 b2 of + Just Refl -> Just Refl + Nothing -> Nothing + testEquality _ _ = Nothing + +instance PrettyPrec (TTy ty) where + prettyPrec :: Int -> TTy ty -> Doc ann + prettyPrec _ (TTyBase b) = ppr b + prettyPrec p (α :->: β) = + pparens (p > 0) $ + prettyPrec 1 α <+> "->" <+> prettyPrec 0 β + prettyPrec p (TTyWorld t) = + pparens (p > 1) $ + "World" <+> prettyPrec 2 t + +------------------------------------------------------------ +-- Instance checking + +-- | Check that a particular type has an 'GHC.Classes.Eq' instance, and run a +-- computation in a context provided with an 'GHC.Classes.Eq' constraint. The +-- other @checkX@ functions are similar. +checkEq :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Eq ty, NotFun ty) => m a) -> m a +checkEq (TTyBase BBool) a = a +checkEq (TTyBase BInt) a = a +checkEq (TTyBase BFloat) a = a +checkEq ty _ = throwError $ NoInstance "Eq" ty + +checkOrd :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Ord ty, NotFun ty) => m a) -> m a +checkOrd (TTyBase BBool) a = a +checkOrd (TTyBase BInt) a = a +checkOrd (TTyBase BFloat) a = a +checkOrd ty _ = throwError $ NoInstance "Ord" ty + +checkNum :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Num ty, NotFun ty) => m a) -> m a +checkNum (TTyBase BInt) a = a +checkNum (TTyBase BFloat) a = a +checkNum ty _ = throwError $ NoInstance "Num" ty + +checkIntegral :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Integral ty, NotFun ty) => m a) -> m a +checkIntegral (TTyBase BInt) a = a +checkIntegral ty _ = throwError $ NoInstance "Integral" ty + +checkEmpty :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Empty ty, NotFun ty) => m a) -> m a +checkEmpty (TTyBase BCell) a = a +checkEmpty ty _ = throwError $ NoInstance "Empty" ty + +checkOver :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Over ty, NotFun ty) => m a) -> m a +checkOver (TTyBase BBool) a = a +checkOver (TTyBase BInt) a = a +checkOver (TTyBase BFloat) a = a +checkOver (TTyBase BCell) a = a +checkOver ty _ = throwError $ NoInstance "Over" ty + +checkNotFun :: (Has (Throw CheckErr) sig m) => TTy ty -> (NotFun ty => m a) -> m a +checkNotFun (TTyBase BBool) a = a +checkNotFun (TTyBase BInt) a = a +checkNotFun (TTyBase BFloat) a = a +checkNotFun (TTyBase BCell) a = a +checkNotFun ty _ = throwError $ NoInstance "NotFun" ty + +------------------------------------------------------------ +-- Existential wrappers + +-- | Wrap up a type-indexed thing to hide the type index, but package +-- it with a 'TTy' which we can pattern-match on to recover the type +-- later. +data Some :: (Type -> Type) -> Type where + Some :: TTy α -> t α -> Some t + +deriving instance (forall α. Show (t α)) => Show (Some t) + +mapSome :: (forall α. s α -> t α) -> Some s -> Some t +mapSome f (Some ty t) = Some ty (f t) + +type SomeTy = Some (F.Const ()) + +pattern SomeTy :: TTy α -> SomeTy +pattern SomeTy α = Some α (F.Const ()) +{-# COMPLETE SomeTy #-} + +------------------------------------------------------------ +-- Type inference/checking + elaboration + +type WorldMap = Map Text (Some (TTerm '[])) + +-- | Type contexts, indexed by a type-level list of types of all the +-- variables in the context. +data Ctx :: [Type] -> Type where + CNil :: Ctx '[] + CCons :: Text -> TTy ty -> Ctx g -> Ctx (ty ': g) + +-- | Look up a variable name in the context, returning a type-indexed +-- de Bruijn index. +lookup :: (Has (Throw CheckErr) sig m) => Text -> Ctx g -> m (Some (Idx g)) +lookup x CNil = throwError $ Unbound x +lookup x (CCons y ty ctx) + | x == y = return $ Some ty VZ + | otherwise = mapSome VS <$> lookup x ctx + +-- | Check that a term has a given type, and if so, return a +-- corresponding elaborated and type-indexed term. Note that this +-- also deals with subtyping: for example, if we check that the term +-- @3@ has type @World Int@, we will get back a suitably lifted +-- value (/i.e./ @const 3@). +check :: + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + TTy t -> + WExp -> + m (TTerm g t) +check e ty t = do + t1 <- infer e t + Some ty' t' <- apply (Some (ty :->: ty) (embed I)) t1 + case testEquality ty ty' of + Nothing -> throwError $ BadType t1 ty + Just Refl -> return t' + +-- | Get the underlying base type of a term which either has a base +-- type or a World type. +getBaseType :: Some (TTerm g) -> SomeTy +getBaseType (Some (TTyWorld ty) _) = SomeTy ty +getBaseType (Some ty _) = SomeTy ty + +-- | Apply one term to another term, automatically handling promotion +-- and lifting, via the fact that World is Applicative. That is, +-- (1) if a term of type T is used where a term of type World T is +-- expected, it will automatically be promoted (by an application of +-- const); (2) if a function of type (T1 -> T2 -> ... -> Tn) is +-- applied to any arguments of type (World Ti), the function will be +-- lifted to (World T1 -> World T2 -> ... -> World Tn). +apply :: (Has (Throw CheckErr) sig m) => Some (TTerm g) -> Some (TTerm g) -> m (Some (TTerm g)) +-- Normal function application +apply (Some (ty11 :->: ty12) t1) (Some ty2 t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some ty12 (t1 $$ t2) +-- (World T -> ...) applied to T: promote the argument to (World T) with const +apply (Some (TTyWorld ty11 :->: ty12) t1) (Some ty2 t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some ty12 (t1 $$ (K .$$ t2)) +-- (S -> T) applied to (World S): lift the function to (World S -> World T). +apply (Some (ty11 :->: ty12) t1) (Some (TTyWorld ty2) t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (B .$$ t1 $$ t2) +-- World (S -> T) applied to S. Note this case and the next are +-- needed because in the previous case, when (S -> T) is lifted to +-- (World S -> World T), T may itself be a function type. +apply (Some (TTyWorld (ty11 :->: ty12)) t1) (Some ty2 t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (S .$$ t1 $$ (K .$$ t2)) +-- World (S -> T) applied to (World S) +apply (Some (TTyWorld (ty11 :->: ty12)) t1) (Some (TTyWorld ty2) t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (S .$$ t1 $$ t2) +apply t1 t2 = throwError $ ApplyErr t1 t2 + +applyTo :: (Has (Throw CheckErr) sig m) => Some (TTerm g) -> Some (TTerm g) -> m (Some (TTerm g)) +applyTo = flip apply + +-- | Infer the type of an operator: turn a raw operator into a +-- type-indexed constant. However, some operators are polymorphic, +-- so we also provide a list of type arguments. For example, the +-- type of the negation operator can be either (Int -> Int) or +-- (Float -> Float) so we provide it as an argument. +-- +-- Currently, all operators take at most one type argument, so +-- (Maybe SomeTy) might seem more appropriate than [SomeTy], but +-- that is just a coincidence; in general one can easily imagine +-- operators that are polymorphic in more than one type variable, +-- and we may wish to add such in the future. +inferOp :: (Has (Throw CheckErr) sig m) => [SomeTy] -> Op -> m (Some (TTerm g)) +inferOp _ Not = return $ Some (TTyBool :->: TTyBool) (embed CNot) +inferOp [SomeTy tyA] Neg = Some (tyA :->: tyA) <$> checkNum tyA (return $ embed CNeg) +inferOp _ And = return $ Some (TTyBool :->: TTyBool :->: TTyBool) (embed CAnd) +inferOp _ Or = return $ Some (TTyBool :->: TTyBool :->: TTyBool) (embed COr) +inferOp [SomeTy tyA] Abs = Some (tyA :->: tyA) <$> checkNum tyA (return $ embed CAbs) +inferOp [SomeTy tyA] Add = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CAdd) +inferOp [SomeTy tyA] Sub = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CSub) +inferOp [SomeTy tyA] Mul = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CMul) +inferOp [SomeTy tyA] Div = case tyA of + TTyBase BInt -> return $ Some (tyA :->: tyA :->: tyA) (embed CIDiv) + TTyBase BFloat -> return $ Some (tyA :->: tyA :->: tyA) (embed CDiv) + _ -> throwError $ BadDivType tyA +inferOp [SomeTy tyA] Mod = Some (tyA :->: tyA :->: tyA) <$> checkIntegral tyA (return $ embed CMod) +inferOp [SomeTy tyA] Eq = Some (tyA :->: tyA :->: TTyBool) <$> checkEq tyA (return $ embed CEq) +inferOp [SomeTy tyA] Neq = Some (tyA :->: tyA :->: TTyBool) <$> checkEq tyA (return $ embed CNeq) +inferOp [SomeTy tyA] Lt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CLt) +inferOp [SomeTy tyA] Leq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CLeq) +inferOp [SomeTy tyA] Gt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGt) +inferOp [SomeTy tyA] Geq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGeq) +inferOp [SomeTy tyA] If = return $ Some (TTyBool :->: tyA :->: tyA :->: tyA) (embed CIf) +inferOp _ Perlin = return $ Some (TTyInt :->: TTyInt :->: TTyFloat :->: TTyFloat :->: TTyWorld TTyFloat) (embed CPerlin) +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 + +-- | Given a raw operator and the terms the operator is applied to, +-- select which types should be supplied as the type arguments to +-- the operator. For example, for an operator like @+@ we can just +-- select the type of its first argument; for an operator like @if@, +-- we must select the type of its second argument, since @if : Bool +-- -> a -> a -> a@. In all cases we must also select the underlying +-- base type in case the argument has a @World@ type. For example +-- if @+@ is applied to an argument of type @World Int@ we still +-- want to give @+@ the type @Int -> Int -> Int@. It can be lifted +-- to have type @World Int -> World Int -> World Int@ but that will +-- be taken care of by application, which will insert the right +-- combinators to do the lifting. +typeArgsFor :: Op -> [Some (TTerm g)] -> [SomeTy] +typeArgsFor op (t : _) + | op `elem` [Neg, Abs, Add, Sub, Mul, Div, Mod, Eq, Neq, Lt, Leq, Gt, Geq] = [getBaseType t] +typeArgsFor op (_ : t : _) + | op `elem` [If, Mask, Overlay] = [getBaseType t] +typeArgsFor IMap (_ : _ : t : _) = [getBaseType t] +typeArgsFor _ _ = [] + +-- | Typecheck the application of an operator to some terms, returning +-- a typed, elaborated version of the application. +applyOp :: + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + Op -> + [WExp] -> + m (Some (TTerm g)) +applyOp ctx op ts = do + tts <- mapM (infer ctx) ts + foldl (\r -> (r >>=) . applyTo) (inferOp (typeArgsFor op tts) op) tts + +-- | Infer the type of a term, and elaborate along the way. +infer :: + forall sig m g. + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + WExp -> + m (Some (TTerm g)) +infer _ (WInt i) = return $ Some (TTyBase BInt) (embed (CLit i)) +infer _ (WFloat f) = return $ Some (TTyBase BFloat) (embed (CLit f)) +infer _ (WBool b) = return $ Some (TTyBase BBool) (embed (CLit b)) +infer _ (WCell c) = do + c' <- resolveCell c + return $ Some TTyCell (embed (CCell c')) +infer ctx (WVar x) = mapSome TVar <$> lookup x ctx +infer ctx (WOp op ts) = applyOp ctx op ts +infer _ WSeed = return $ Some TTyInt (embed CSeed) +infer _ (WCoord ax) = return $ Some (TTyWorld TTyInt) (embed (CCoord ax)) +infer _ WHash = return $ Some (TTyWorld TTyInt) (embed CHash) +infer ctx (WLet defs body) = inferLet ctx defs body +infer ctx (WOverlay ts) = inferOverlay ctx ts +infer _ctx (WImport key) = do + worldMap <- ask @WorldMap + case M.lookup key worldMap of + Just (Some ty t) -> return (Some ty (weaken @g t)) + Nothing -> throwError $ UnknownImport key + +-- | Try to resolve a 'RawCellVal'---containing only 'Text' names for +-- terrain, entities, and robots---into a real 'CellVal' with +-- references to actual terrain, entities, and robots. +resolveCell :: + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + ) => + RawCellVal -> + m CellVal +resolveCell items = do + cellVals <- mapM resolveCellItem items + return $ foldl' () empty cellVals + +-- | Try to resolve one cell item name into an actual item (terrain, +-- entity, robot, etc.). +resolveCellItem :: + forall sig m. + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + ) => + (Maybe CellTag, Text) -> + m CellVal +resolveCellItem (mCellTag, item) = case mCellTag of + Just cellTag -> do + -- The item was tagged specifically, like {terrain: dirt} or {entity: water} + mCell <- resolverByTag cellTag item + maybe (throwError $ NotAThing item cellTag) return mCell + Nothing -> do + -- The item was not tagged; try resolving in all possible ways and choose + -- the first that works + maybeCells <- mapM (`resolverByTag` item) (enumerate @CellTag) + case F.asum maybeCells of + Nothing -> throwError $ NotAnything item + Just cell -> return cell + where + mkTerrain t = CellVal t mempty mempty + mkEntity e = CellVal mempty (EJust (Last e)) mempty + + resolverByTag :: CellTag -> Text -> m (Maybe CellVal) + resolverByTag = \case + CellTerrain -> \tName -> do + TerrainEntityMaps tm _em <- ask @TerrainEntityMaps + return . fmap (mkTerrain . terrainName) . (`M.lookup` terrainByName tm) $ terrainFromText tName + CellEntity -> \eName -> + case eName of + "erase" -> return $ Just (CellVal mempty EErase mempty) + _ -> do + TerrainEntityMaps _tm em <- ask @TerrainEntityMaps + return . fmap mkEntity $ lookupEntityName eName em + CellRobot -> \_ -> return Nothing -- TODO (#1396): support robots + +-- | Infer the type of a let expression, and elaborate into a series +-- of lambda applications. +inferLet :: + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + [(Var, WExp)] -> + WExp -> + m (Some (TTerm g)) +inferLet ctx [] body = infer ctx body +inferLet ctx ((x, e) : xs) body = do + e'@(Some ty1 _) <- infer ctx e + Some ty2 let' <- inferLet (CCons x ty1 ctx) xs body + apply (Some (ty1 :->: ty2) (TLam let')) e' + +-- | Infer the type of an @overlay@ expression, and elaborate into a +-- chain of @<>@ (over) operations. +inferOverlay :: + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + NE.NonEmpty WExp -> + m (Some (TTerm g)) +inferOverlay ctx es = case NE.uncons es of + -- @overlay [e] = e@ + (e, Nothing) -> infer ctx e + -- @overlay (e : es') = e <> overlay es'@ + (e, Just es') -> do + e' <- infer ctx e + o' <- inferOverlay ctx es' + case getBaseType e' of + SomeTy ty -> do + let wty = TTyWorld ty + c <- checkOver ty (return $ embed COver) + apply (Some (wty :->: wty :->: wty) (Φ .$$ c)) e' >>= applyTo o' diff --git a/src/swarm-scenario/Swarm/Util/Content.hs b/src/swarm-scenario/Swarm/Util/Content.hs new file mode 100644 --- /dev/null +++ b/src/swarm-scenario/Swarm/Util/Content.hs @@ -0,0 +1,66 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utilities for accessing content of the world, +-- by single cells or in bulk for rendering. +module Swarm.Util.Content where + +import Control.Applicative ((<|>)) +import Control.Lens ((^.)) +import Data.Map qualified as M +import Data.Text qualified as T +import Swarm.Game.Display +import Swarm.Game.Entity.Cosmetic +import Swarm.Game.Scenario.Topography.Cell (PCell (..)) +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainWord) +import Swarm.Game.Universe +import Swarm.Game.World +import Swarm.Game.World.Coords +import Swarm.Util.Erasable (erasableToMaybe, maybeToErasable) + +-- | Get the terrain and entity at a single cell +getContentAt :: TerrainMap -> MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e) +getContentAt tm w coords = (underlyingCellTerrain, underlyingCellEntity) + where + underlyingCellEntity = lookupCosmicEntity coords w + underlyingCellTerrain = lookupCosmicTerrain tm coords w + +-- * Rendering + +-- | Get a rectangle of cells for rendering. +-- +-- Compare to: 'Swarm.TUI.View.worldWidget' +getMapRectangle :: + (d -> e) -> + (Coords -> (TerrainType, Maybe d)) -> + BoundsRectangle -> + Grid (PCell e) +getMapRectangle paintTransform contentFunc coords = + mkGrid $ map renderRow [yTop .. yBottom] + where + (Coords (yTop, xLeft), Coords (yBottom, xRight)) = coords + + drawCell f rowIndex colIndex = + Cell + terrain + (f <$> maybeToErasable erasableEntity) + [] + where + (terrain, erasableEntity) = contentFunc $ Coords (rowIndex, colIndex) + + renderRow rowIndex = map (drawCell paintTransform rowIndex) [xLeft .. xRight] + +-- | Get the color used to render a single cell +getTerrainEntityColor :: + M.Map WorldAttr PreservableColor -> + PCell EntityFacade -> + Maybe PreservableColor +getTerrainEntityColor aMap (Cell terr cellEnt _) = + (entityColor =<< erasableToMaybe cellEnt) <|> terrainFallback + where + terrainFallback = M.lookup (WorldAttr $ T.unpack $ getTerrainWord terr) aMap + entityColor (EntityFacade _ d) = case d ^. displayAttr of + AWorld n -> M.lookup (WorldAttr $ T.unpack n) aMap + _ -> Nothing diff --git a/src/swarm-topography/Swarm/Game/Location.hs b/src/swarm-topography/Swarm/Game/Location.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Location.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- Orphan JSON instances for Location and Heading + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Locations and headings +-- +-- Locations and headings. +module Swarm.Game.Location ( + Location, + pattern Location, + HasLocation (..), + + -- ** Heading and Direction functions + Heading, + applyTurn, + relativeTo, + toDirection, + toAbsDirection, + nearestDirection, + fromDirection, + isCardinal, + north, + south, + east, + west, + + -- ** Utility functions + manhattan, + euclidean, + getLocsInArea, + getElemsInArea, + + -- ** Re-exports for convenience + Affine (..), + Point (..), + origin, + toHeading, +) where + +import Control.Arrow ((&&&)) +import Data.Aeson (FromJSONKey, ToJSONKey) +import Data.Function (on, (&)) +import Data.Int (Int32) +import Data.List (nub) +import Data.List.Extra (enumerate) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Yaml (FromJSON (parseJSON), ToJSON (toJSON)) +import Linear (Additive (..), V2 (..), negated, norm, perp, unangle) +import Linear.Affine (Affine (..), Point (..), origin) +import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..), PlanarRelativeDir (..), RelativeDir (..), isCardinal) +import Swarm.Util qualified as Util + +-- $setup +-- >>> import qualified Data.Map as Map +-- >>> import Linear +-- >>> import Swarm.Language.Syntax.Direction + +-- | A t'Location' is a pair of @(x,y)@ coordinates, both up to 32 bits. +-- The positive x-axis points east and the positive y-axis points +-- north. These are the coordinates that are shown to players. +-- +-- See also the 'Swarm.Game.World.Coords' type defined in "Swarm.Game.World", which +-- use a (row, column) format instead, which is more convenient for +-- internal use. The "Swarm.Game.World" module also defines +-- conversions between 'Location' and 'Swarm.Game.World.Coords'. +type Location = Point V2 Int32 + +-- | A convenient way to pattern-match on t'Location' values. +pattern Location :: Int32 -> Int32 -> Location +pattern Location x y = P (V2 x y) + +{-# COMPLETE Location #-} + +instance FromJSON Location where + parseJSON = fmap P . parseJSON + +instance ToJSON Location where + toJSON (P v) = toJSON v + +-- | A @Heading@ is a 2D vector, with 32-bit coordinates. +-- +-- t'Location' and 'Heading' are both represented using types from +-- the @linear@ package, so they can be manipulated using a large +-- number of operators from that package. For example: +-- +-- * Two headings can be added with '^+^'. +-- * The difference between two t'Location's is a 'Heading' (via '.-.'). +-- * A t'Location' plus a 'Heading' is another t'Location' (via 'Linear.Affine..^+'). +type Heading = V2 Int32 + +deriving instance ToJSON (V2 Int32) +deriving instance FromJSON (V2 Int32) + +deriving instance FromJSONKey (V2 Int32) +deriving instance ToJSONKey (V2 Int32) + +toHeading :: AbsoluteDir -> Heading +toHeading = \case + DNorth -> north + DSouth -> south + DEast -> east + DWest -> west + +-- | The cardinal direction north = @V2 0 1@. +north :: Heading +north = V2 0 1 + +-- | The cardinal direction south = @V2 0 (-1)@. +south :: Heading +south = V2 0 (-1) + +-- | The cardinal direction east = @V2 1 0@. +east :: Heading +east = V2 1 0 + +-- | The cardinal direction west = @V2 (-1) 0@. +west :: Heading +west = V2 (-1) 0 + +-- | The direction for viewing the current cell = @V2 0 0@. +down :: Heading +down = zero + +-- | The 'applyTurn' function gives the meaning of each 'Direction' by +-- turning relative to the given heading or by turning to an absolute +-- heading. +-- +-- >>> applyTurn (DRelative (DPlanar DLeft)) (V2 5 3) +-- V2 (-3) 5 +-- >>> applyTurn (DAbsolute DWest) (V2 5 3) +-- V2 (-1) 0 +applyTurn :: Direction -> Heading -> Heading +applyTurn d = case d of + DRelative e -> case e of + DPlanar DLeft -> perp + DPlanar DRight -> negated . perp + DPlanar DBack -> negated + DPlanar DForward -> id + DDown -> const down + DAbsolute e -> const $ toHeading e + +-- | Mapping from heading to their corresponding cardinal directions. +-- Only absolute directions are mapped. +cardinalDirs :: M.Map Heading AbsoluteDir +cardinalDirs = + M.fromList $ map (toHeading &&& id) enumerate + +-- | Possibly convert a heading into a 'Direction'---that is, if the +-- vector happens to be a unit vector in one of the cardinal +-- directions. +-- +-- >>> toDirection (V2 0 (-1)) +-- Just (DAbsolute DSouth) +-- >>> toDirection (V2 3 7) +-- Nothing +toDirection :: Heading -> Maybe Direction +toDirection = fmap DAbsolute . toAbsDirection + +-- | Like 'toDirection', but preserve the type guarantee of an absolute direction +toAbsDirection :: Heading -> Maybe AbsoluteDir +toAbsDirection v = M.lookup v cardinalDirs + +-- | Return the 'PlanarRelativeDir' which would result in turning to +-- the first (target) direction from the second (reference) direction. +-- +-- >>> DWest `relativeTo` DSouth +-- DRight +-- >>> DWest `relativeTo` DWest +-- DForward +relativeTo :: AbsoluteDir -> AbsoluteDir -> PlanarRelativeDir +relativeTo targetDir referenceDir = + toEnum indexDiff + where + enumCount = length (enumerate :: [AbsoluteDir]) + indexDiff = ((-) `on` fromEnum) targetDir referenceDir `mod` enumCount + +-- | Compute the absolute direction nearest to a given 'Heading'. +-- +-- Logic adapted from . +nearestDirection :: Heading -> AbsoluteDir +nearestDirection coord = + Util.indexWrapNonEmpty orderedDirs index + where + angle :: Double + angle = unangle (fmap fromIntegral coord) / (2 * pi) + + index :: Int + 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) + +-- | Euclidean distance between world locations. +euclidean :: Location -> Location -> Double +euclidean p1 p2 = norm (fromIntegral <$> (p2 .-. p1)) + +-- | Get all the locations that are within a certain manhattan +-- distance from a given location. +-- +-- >>> getLocsInArea (P (V2 0 0)) 1 +-- [P (V2 0 0),P (V2 0 1),P (V2 0 (-1)),P (V2 1 0),P (V2 (-1) 0)] +-- >>> map (\i -> length (getLocsInArea origin i)) [0..8] +-- [1,5,13,25,41,61,85,113,145] +-- +-- See also @Swarm.Game.Step.Const.genDiamondSides@. +getLocsInArea :: Location -> Int32 -> [Location] +getLocsInArea loc r = + [loc .+^ V2 dx dy | x <- [0 .. r], y <- [0 .. r - x], dx <- nub [x, -x], dy <- nub [y, -y]] + +-- | Get elements that are within a certain manhattan distance from location. +-- +-- >>> v2s i = [(p, manhattan origin p) | x <- [-i..i], y <- [-i..i], let p = Location x y] +-- >>> v2s 0 +-- [(P (V2 0 0),0)] +-- >>> map (\i -> length (getElemsInArea origin i (Map.fromList $ v2s i))) [0..8] +-- [1,5,13,25,41,61,85,113,145] +-- +-- The last test is the sequence "Centered square numbers": +-- https://oeis.org/A001844 +getElemsInArea :: Location -> Int32 -> Map Location e -> [e] +getElemsInArea o@(Location x y) d m = M.elems sm' + where + -- to be more efficient we basically split on first coordinate + -- (which is logarithmic) and then we have to linearly filter + -- the second coordinate to get a square - this is how it looks: + -- ▲▲▲▲ + -- ││││ the arrows mark points that are greater then A + -- ││s│ and lesser then B + -- │sssB (2,1) + -- ssoss <-- o=(x=0,y=0) with d=2 + -- (-2,-1) Asss│ + -- │s││ the point o and all s are in manhattan + -- ││││ distance 2 from point o + -- ▼▼▼▼ + sm = + m + & M.split (Location (x - d) (y - 1)) -- A + & snd -- A< + & M.split (Location (x + d) (y + 1)) -- B + & fst -- B> + sm' = M.filterWithKey (const . (<= d) . manhattan o) sm + +-- * Locatable things + +class HasLocation a where + -- | Basically 'fmap' for the 'Location' field of a record + modifyLoc :: (Location -> Location) -> a -> a + + -- | Translation by a vector + offsetLoc :: V2 Int32 -> a -> a + offsetLoc locOffset = modifyLoc (.+^ locOffset) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Area where + +import Data.Int (Int32) +import Data.List qualified as L +import Data.Maybe (listToMaybe) +import Data.Semigroup +import Linear (V2 (..)) +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Grid +import Prelude hiding (zipWith) + +-- | Height and width of a 2D map region +data AreaDimensions = AreaDimensions + { rectWidth :: Int32 + , rectHeight :: Int32 + } + +getGridDimensions :: Grid a -> AreaDimensions +getGridDimensions g = getAreaDimensions $ getRows g + +asTuple :: AreaDimensions -> (Int32, Int32) +asTuple (AreaDimensions x y) = (x, y) + +renderRectDimensions :: AreaDimensions -> String +renderRectDimensions (AreaDimensions w h) = + L.intercalate "x" $ map show [w, h] + +invertY :: V2 Int32 -> V2 Int32 +invertY (V2 x y) = V2 x (-y) + +-- | Incorporates an offset by @-1@, since the area is +-- "inclusive" of the lower-right coordinate. +-- Inverse of 'cornersToArea'. +computeBottomRightFromUpperLeft :: AreaDimensions -> Location -> Location +computeBottomRightFromUpperLeft a upperLeft = + upperLeft .+^ displacement + where + displacement = invertY $ computeAbsoluteCornerDisplacement a + +computeAbsoluteCornerDisplacement :: AreaDimensions -> V2 Int32 +computeAbsoluteCornerDisplacement (AreaDimensions w h) = + subtract 1 <$> V2 w h + +-- | Converts the displacement vector between the two +-- diagonal corners of the rectangle into an 'AreaDimensions' record. +-- Adds one to both dimensions since the corner coordinates are "inclusive". +-- Inverse of 'computeBottomRightFromUpperLeft'. +cornersToArea :: Location -> Location -> AreaDimensions +cornersToArea upperLeft bottomRight = + AreaDimensions x y + where + V2 x y = (+ 1) <$> invertY (bottomRight .-. upperLeft) + +-- | Has zero width or height. +isEmpty :: AreaDimensions -> Bool +isEmpty (AreaDimensions w h) = w == 0 || h == 0 + +-- | Extracts the dimensions of a map grid. +getAreaDimensions :: [[a]] -> AreaDimensions +getAreaDimensions cellGrid = + AreaDimensions w h + where + w = fromIntegral $ maybe 0 length $ listToMaybe cellGrid -- column count + h = fromIntegral $ length cellGrid -- row count + +computeArea :: AreaDimensions -> Int32 +computeArea (AreaDimensions w h) = w * h + +fillGrid :: AreaDimensions -> a -> Grid a +fillGrid (AreaDimensions 0 _) _ = EmptyGrid +fillGrid (AreaDimensions _ 0) _ = EmptyGrid +fillGrid (AreaDimensions w h) x = + Grid + . stimes h + . pure + . stimes w + . pure + $ x diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs @@ -0,0 +1,65 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Grid ( + Grid (..), + gridToVec, + mapIndexedMembers, + allMembers, + mapRows, + getRows, + mkGrid, +) +where + +import Data.Aeson (ToJSON (..)) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (fromMaybe) +import Data.Semigroup +import Data.Vector qualified as V +import Swarm.Game.World.Coords +import Prelude hiding (zipWith) + +data Grid c + = EmptyGrid + | Grid (NonEmpty (NonEmpty 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 + +getRows :: Grid a -> [[a]] +getRows EmptyGrid = [] +getRows (Grid 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 + +allMembers :: Grid a -> [a] +allMembers EmptyGrid = [] +allMembers g = concat . getRows $ 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 + +-- | 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 + +instance (ToJSON a) => ToJSON (Grid a) where + toJSON EmptyGrid = toJSON ([] :: [a]) + toJSON (Grid g) = toJSON g diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Landmarks that are used to specify portal locations +-- and can serve as navigation aids via the `waypoint` command. +-- +-- = Waypoint ordering +-- +-- The sequence of waypoints of a given name is dictated by criteria in the following order: +-- +-- 1. Ordering of structure placements +-- (see implementation of 'Swarm.Game.Scenario.Topography.Structure.mergeStructures'); +-- later placements are ordered first. +-- 2. Placement of cells within a map. Map locations go by row-major order +-- (compare to docs for 'Swarm.Game.State.genRobotTemplates'). +-- +-- TODO (#1366): May be useful to have a mechanism for more +-- precise control of ordering. +module Swarm.Game.Scenario.Topography.Navigation.Waypoint where + +import Data.Text qualified as T +import Data.Yaml as Y +import GHC.Generics (Generic) +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Placement + +-- | This type is isomorphic to 'Maybe'. +data Parentage a + = WithParent a + | Root + deriving (Show, Eq) + +-- | Indicates which structure something came from +-- for debugging purposes. +data Originated a = Originated + { parent :: Parentage Placement + , value :: a + } + deriving (Show, Eq, Functor) + +newtype WaypointName = WaypointName T.Text + deriving (Show, Eq, Ord, Generic, FromJSON) + +-- | Metadata about a waypoint +data WaypointConfig = WaypointConfig + { wpName :: WaypointName + , wpUnique :: Bool + -- ^ Enforce global uniqueness of this waypoint + } + deriving (Show, Eq) + +parseWaypointConfig :: Object -> Parser WaypointConfig +parseWaypointConfig v = do + wpName <- v .: "name" + wpUnique <- v .:? "unique" .!= False + pure WaypointConfig {..} + +instance FromJSON WaypointConfig where + parseJSON = withObject "Waypoint Config" parseWaypointConfig + +-- | +-- A parent world shouldn't have to know the exact layout of a subworld +-- to specify where exactly a portal will deliver a robot to within the subworld. +-- Therefore, we define named waypoints in the subworld and the parent world +-- must reference them by name, rather than by coordinate. +data Waypoint = Waypoint + { wpConfig :: WaypointConfig + , wpLoc :: Location + } + deriving (Show, Eq) + +-- | JSON representation is flattened; all keys are at the same level, +-- in contrast with the underlying record. +instance FromJSON Waypoint where + parseJSON = withObject "Waypoint" $ \v -> do + wpConfig <- parseWaypointConfig v + wpLoc <- v .: "loc" + pure Waypoint {..} + +instance HasLocation Waypoint where + modifyLoc f (Waypoint cfg originalLoc) = Waypoint cfg $ f originalLoc diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Descriptions of the orientation and offset by +-- which a structure should be placed. +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.Grid +import Swarm.Language.Syntax.Direction (AbsoluteDir (..)) + +newtype StructureName = StructureName Text + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + +getStructureName :: StructureName -> Text +getStructureName (StructureName sn) = sn + +-- | Orientation transformations are applied before translation. +data Orientation = Orientation + { up :: AbsoluteDir + -- ^ e.g. For "East", rotates 270 degrees. + , flipped :: Bool + -- ^ vertical flip, applied before rotation + } + deriving (Eq, Show) + +instance FromJSON Orientation where + parseJSON = withObject "structure orientation" $ \v -> do + up <- v .:? "up" .!= DNorth + flipped <- v .:? "flip" .!= False + pure Orientation {..} + +defaultOrientation :: Orientation +defaultOrientation = Orientation DNorth False + +-- | This is the point-wise equivalent of "applyOrientationTransform" +reorientLandmark :: Orientation -> AreaDimensions -> Location -> Location +reorientLandmark (Orientation upDir shouldFlip) (AreaDimensions width height) = + rotational . flipping + where + 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 + rotational = case upDir of + DNorth -> id + DSouth -> flipH . flipV + DEast -> transposeLoc . flipV + DWest -> transposeLoc . flipH + +-- | affine transformation +applyOrientationTransform :: Orientation -> Grid a -> Grid a +applyOrientationTransform (Orientation upDir shouldFlip) = + mapRows f + where + f = rotational . flipping + flipV = NE.reverse + flipping = if shouldFlip then flipV else id + rotational = case upDir of + DNorth -> id + DSouth -> NE.transpose . flipV . NE.transpose . flipV + DEast -> NE.transpose . flipV + DWest -> flipV . NE.transpose + +data Pose = Pose + { offset :: Location + , orient :: Orientation + } + deriving (Eq, Show) + +data Placement = Placement + { src :: StructureName + , structurePose :: Pose + } + deriving (Eq, Show) + +instance FromJSON Placement where + parseJSON = withObject "structure placement" $ \v -> do + src <- v .: "src" + offset <- v .:? "offset" .!= origin + orient <- v .:? "orient" .!= defaultOrientation + let structurePose = Pose offset orient + pure Placement {..} diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.ProtoCell ( + SignpostableCell (..), + StructurePalette (..), +) where + +import Control.Applicative ((<|>)) +import Data.Aeson.KeyMap (KeyMap) +import Data.Yaml as Y +import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig) +import Swarm.Util.Yaml + +newtype StructurePalette e = StructurePalette + {unPalette :: KeyMap (SignpostableCell e)} + deriving (Eq, Show) + +instance (FromJSONE e a) => FromJSONE e (StructurePalette a) where + parseJSONE = + withObjectE "palette" $ + fmap StructurePalette . mapM parseJSONE + +-- | Supplements a cell with waypoint information +data SignpostableCell c = SignpostableCell + { waypointCfg :: Maybe WaypointConfig + , standardCell :: c + } + deriving (Eq, Show) + +instance (FromJSONE e a) => FromJSONE e (SignpostableCell a) where + parseJSONE x = + withObjectE "SignpostableCell" objParse x + <|> (SignpostableCell Nothing <$> parseJSONE x) + where + objParse v = do + waypointCfg <- liftE $ v .:? "waypoint" + 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 new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs @@ -0,0 +1,18 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Convenience functions for rendering topographical structures +module Swarm.Game.Scenario.Topography.Rasterize where + +import Codec.Picture +import Data.Vector qualified as V +import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Grid + +makeImage :: Pixel px => (a -> px) -> Grid a -> Image px +makeImage computeColor 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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Definitions of "structures" for use within a map +-- 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 Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (catMaybes) +import Data.Set (Set) +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 +import Swarm.Game.Scenario.Topography.Grid +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.Overlay +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 + { area :: PositionedGrid c + , structures :: [NamedStructure c] + -- ^ structure definitions from parents shall be accessible by children + , placements :: [Placement] + -- ^ earlier placements will be overlaid on top of later placements in the YAML file + , waypoints :: [Waypoint] + } + deriving (Eq, Show) + +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 + parseJSONE = withObjectE "named structure" $ \v -> do + structure <- v ..: "structure" + liftE $ do + name <- v .: "name" + recognize <- v .:? "recognize" .!= mempty + description <- v .:? "description" + return $ NamedArea {..} + +instance FromJSON (Grid Char) where + parseJSON = withText "area" $ \t -> do + let textLines = map T.unpack $ T.lines t + g = mkGrid textLines + case NE.nonEmpty textLines of + Nothing -> return EmptyGrid + Just nonemptyRows -> do + let firstRowLength = length $ NE.head nonemptyRows + unless (all ((== firstRowLength) . length) $ NE.tail nonemptyRows) $ + fail "Grid is not rectangular!" + return g + +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 {..} + +-- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw +-- string into a nested list of 'PCell' values by looking up each +-- character in the palette, failing if any character in the raw map +-- is not contained in the palette. +paintMap :: + MonadFail m => + Maybe Char -> + StructurePalette c -> + Grid Char -> + m (Grid (Maybe c), [Waypoint]) +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 + + unless (null unusedChars) $ + fail $ + unwords + [ "Unused characters in palette:" + , T.unpack $ T.intercalate ", " unusedChars + ] + + let cells = fmap standardCell <$> nestedLists + getWp coords maybeAugmentedCell = do + wpCfg <- waypointCfg =<< maybeAugmentedCell + return . Waypoint wpCfg . coordsToLoc $ coords + wps = catMaybes $ mapIndexedMembers getWp nestedLists + + return (cells, wps) + where + toCell c = + if Just c == maskChar + then return Nothing + else case KeyMap.lookup (Key.fromString [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 new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Definitions of "structures" for use within a map +-- as well as logic for combining them. +module Swarm.Game.Scenario.Topography.Structure.Assembly ( + mergeStructures, +) +where + +import Control.Arrow (left, (&&&)) +import Control.Monad (when) +import Data.Coerce +import Data.Either.Extra (maybeToEither) +import Data.Foldable (foldlM) +import Data.Map qualified as M +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +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.Overlay +import Swarm.Language.Syntax.Direction (directionJsonModifier) +import Swarm.Util (commaList, quote, showT) + +-- | Destructively overlays one direct child structure +-- upon the input structure. +-- However, the child structure is assembled recursively. +overlaySingleStructure :: + M.Map StructureName (NamedStructure (Maybe a)) -> + Placed (Maybe a) -> + MergedStructure (Maybe a) -> + Either Text (MergedStructure (Maybe a)) +overlaySingleStructure + inheritedStrucDefs + (Placed p@(Placement _ 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 + + return $ MergedStructure mergedArea mergedPlacements mergedWaypoints + where + placeOnArea (PositionedGrid _ overArea) = + offsetLoc (coerce loc) + . modifyLoc (reorientLandmark orientation $ getGridDimensions overArea) + +-- | 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 :: + M.Map StructureName (NamedStructure (Maybe a)) -> + Parentage Placement -> + PStructure (Maybe a) -> + Either Text (MergedStructure (Maybe a)) +mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = do + 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 + + wrappedOverlays = + map wrapPlacement $ + filter (\(Placed _ ns) -> isRecognizable ns) overlays + + foldlM + (flip $ overlaySingleStructure structureMap) + (MergedStructure origArea wrappedOverlays originatedWaypoints) + overlays + where + originatedWaypoints = map (Originated parentPlacement) subWaypoints + + -- deeper definitions override the outer (toplevel) ones + structureMap = + M.union + (M.fromList $ map (name &&& id) subStructures) + inheritedStrucDefs + +-- * Grid manipulation + +overlayGridExpanded :: + Grid (Maybe a) -> + Pose -> + PositionedGrid (Maybe a) -> + PositionedGrid (Maybe a) +overlayGridExpanded + inputGrid + (Pose loc orientation) + (PositionedGrid _ overlayArea) = + PositionedGrid origin inputGrid <> positionedOverlay + where + reorientedOverlayCells = applyOrientationTransform orientation overlayArea + positionedOverlay = PositionedGrid loc reorientedOverlayCells + +-- * Validation + +elaboratePlacement :: Parentage Placement -> Text +elaboratePlacement p = + T.unwords + [ "Within" + , pTxt <> ":" + , "" + ] + where + pTxt = case p of + Root -> "root placement" + WithParent (Placement (StructureName sn) (Pose loc _)) -> + T.unwords + [ "placement of" + , quote sn + , "at" + , showT loc + ] + +validatePlacement :: + M.Map StructureName (NamedStructure (Maybe a)) -> + Placement -> + Either Text (Placed (Maybe a)) +validatePlacement + structureMap + placement@(Placement sName@(StructureName n) (Pose _ orientation)) = do + t@(_, ns) <- + maybeToEither + (T.unwords ["Could not look up structure", quote n]) + $ sequenceA (placement, M.lookup sName structureMap) + + let placementDirection = up orientation + recognizedOrientations = recognize ns + + when (isRecognizable ns) $ do + when (flipped orientation) $ + Left $ + T.unwords + [ "Placing recognizable structure" + , quote n + , "with flipped orientation is not supported." + ] + + -- Redundant orientations by rotational symmetry are accounted + -- for at scenario parse time + when (Set.notMember placementDirection recognizedOrientations) $ + Left $ + T.unwords + [ "Placing recognizable structure" + , quote n + , "with" + , renderDir placementDirection + , "orientation is not supported." + , "Try" + , commaList $ map renderDir $ Set.toList recognizedOrientations + , "instead." + ] + return $ uncurry Placed t + where + renderDir = quote . T.pack . directionJsonModifier . show diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Generic overlay operations on grids +module Swarm.Game.Scenario.Topography.Structure.Overlay ( + PositionedGrid (..), +) where + +import Control.Applicative +import Data.Function (on) +import Data.Int (Int32) +import Data.Tuple (swap) +import Linear +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Util (applyWhen) + +data PositionedGrid a = PositionedGrid + { gridPosition :: Location + , gridContent :: Grid a + } + deriving (Eq) + +instance Show (PositionedGrid a) where + show (PositionedGrid p g) = + unwords + [ "Grid with dimension" + , renderRectDimensions $ getGridDimensions g + , "located at" + , show p + ] + +data OverlayPair a = OverlayPair + { _base :: a + , _overlay :: a + } + +-- | Has a 'Semigroup' instance to determine the smallest +-- bounds that enclose two rectangles +data SubsumingRect = SubsumingRect + { _northwestCorner :: Location + , _southeastCorner :: Location + } + +-- | @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 + +getSubsumingRect :: PositionedGrid a -> SubsumingRect +getSubsumingRect (PositionedGrid loc g) = + SubsumingRect loc $ computeBottomRightFromUpperLeft (getGridDimensions g) loc + +computeMergedArea :: OverlayPair (PositionedGrid a) -> AreaDimensions +computeMergedArea (OverlayPair pg1 pg2) = + cornersToArea ul br + where + SubsumingRect ul br = ((<>) `on` getSubsumingRect) pg1 pg2 + +zipGridRows :: + Alternative f => + AreaDimensions -> + OverlayPair [[f a]] -> + Grid (f a) +zipGridRows dims (OverlayPair paddedBaseRows paddedOverlayRows) = + mkGrid $ (pad2D paddedBaseRows . pad2D paddedOverlayRows) blankGrid + where + -- Right-bias; that is, take the last non-empty value + pad2D = zipPadded $ zipPadded $ flip (<|>) + blankGrid = getRows $ fillGrid dims empty + +-- | +-- First arg: base layer +-- Second arg: overlay layer +-- +-- The upper-left corner of the base layer is the original "origin". +-- +-- If the overlay is to the west or north of the base layer, +-- then we must pad the base layer on the left or top. +-- And since the area expands relative to the "origin" of the +-- base layer, we must shift the combined grid's "origin" location +-- to the new position of the base layer's upper-left corner. +-- +-- If the overlay is to the east/south, we do not have to +-- modify the origin, since no padding is added to the left/top +-- of the base layer. +instance (Alternative f) => Semigroup (PositionedGrid (f a)) where + a1@(PositionedGrid baseLoc baseGrid) <> a2@(PositionedGrid overlayLoc overlayGrid) = + PositionedGrid newOrigin 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: + -- \* 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 + + paddedOverlayPair = + padSouthwest originDelta $ + OverlayPair baseGrid overlayGrid + +-- | 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 :: + Alternative f => + V2 Int32 -> + OverlayPair (Grid (f a)) -> + OverlayPair [[f a]] +padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) = + OverlayPair paddedBaseGrid paddedOverlayGrid + where + prefixPadDimension delta f = f (padding <>) + where + padding = replicate (abs $ fromIntegral delta) empty + + prefixPadRows = prefixPadDimension deltaY id + prefixPadColumns = prefixPadDimension deltaX map + + -- Assume only the *overlay* requires vertical (top-)padding. + -- However, if the conditional is true, then + -- the *base* needs vertical padding instead. + (baseVerticalPadFunc, overlayVerticalPadFunc) = + applyWhen (deltaY > 0) swap (id, prefixPadRows) + + -- Assume only the *overlay* requires horizontal (left-)padding. + -- However, if the conditional is true, then + -- the *base* needs horizontal padding instead. + (baseHorizontalPadFunc, overlayHorizontalPadFunc) = + applyWhen (deltaX < 0) swap (id, prefixPadColumns) + + paddedBaseGrid = baseVerticalPadFunc $ baseHorizontalPadFunc $ getRows baseGrid + paddedOverlayGrid = overlayVerticalPadFunc $ overlayHorizontalPadFunc $ getRows overlayGrid + +-- * Utils + +-- | Apply a function to combine elements from two lists +-- of potentially different lengths. +-- Produces a result with length equal to the longer list. +-- Elements from the longer list are placed directly in the +-- resulting list when the shorter list runs out of elements. +zipPadded :: (a -> a -> a) -> [a] -> [a] -> [a] +zipPadded _ [] ys = ys +zipPadded _ xs [] = xs +zipPadded f (x : xs) (y : ys) = f x y : zipPadded f xs ys diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Public interface for structure recognizer. +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 + -- ^ Records the top-left corner of the found structure + , _recognitionLog :: [SearchLog a] + } + deriving (Generic) + +makeLenses ''StructureRecognizer 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 new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs @@ -0,0 +1,78 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types strictly for debugging structure recognition via the web interface +module Swarm.Game.Scenario.Topography.Structure.Recognition.Log where + +import Data.Aeson +import Data.Int (Int32) +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.Recognition.Type +import Swarm.Game.Universe (Cosmic) + +type StructureRowContent e = [Maybe e] +type WorldRowContent e = [Maybe e] + +data MatchingRowFrom = MatchingRowFrom + { rowIdx :: Int32 + , structure :: OriginalName + } + deriving (Generic, ToJSON) + +newtype HaystackPosition = HaystackPosition Int + deriving (Generic, ToJSON) + +data HaystackContext e = HaystackContext + { worldRow :: WorldRowContent e + , haystackPosition :: HaystackPosition + } + deriving (Functor, Generic, ToJSON) + +data FoundRowCandidate e = FoundRowCandidate + { haystackContext :: HaystackContext e + , structureContent :: StructureRowContent e + , rowCandidates :: [MatchingRowFrom] + } + deriving (Functor, Generic, ToJSON) + +data ParticipatingEntity e = ParticipatingEntity + { entity :: e + , searchOffsets :: InspectionOffsets + } + deriving (Functor, Generic, ToJSON) + +data IntactPlacementLog = IntactPlacementLog + { isIntact :: Bool + , sName :: OriginalName + , locUpperLeft :: Cosmic Location + } + deriving (Generic, ToJSON) + +data SearchLog e + = FoundParticipatingEntity (ParticipatingEntity e) + | StructureRemoved OriginalName + | FoundRowCandidates [FoundRowCandidate e] + | FoundCompleteStructureCandidates [OriginalName] + | IntactStaticPlacement [IntactPlacementLog] + deriving (Functor, Generic) + +instance (ToJSON e) => ToJSON (SearchLog e) where + toJSON = genericToJSON searchLogOptions + +searchLogOptions :: Options +searchLogOptions = + defaultOptions + { sumEncoding = ObjectWithSingleField + } + +instance ToSample (SearchLog e) where + toSamples _ = SD.noSamples + +data StructureLocation = StructureLocation OriginalName (Cosmic Location) + deriving (Generic, ToJSON) + +instance ToSample StructureLocation where + toSamples _ = SD.noSamples 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 new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs @@ -0,0 +1,129 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Structure.Recognition.Prep (mkEntityLookup) where + +import Control.Arrow ((&&&)) +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 qualified as NE +import Data.Maybe (catMaybes) +import Data.Semigroup (sconcat) +import Data.Tuple (swap) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Text.AhoCorasick + +allStructureRows :: [StructureWithGrid b a] -> [StructureRow b a] +allStructureRows = + concatMap 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 + +-- | 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 + 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 + +-- | Make the first-phase lookup map, keyed by 'Entity', +-- along with automatons whose key symbols are "Maybe Entity". +-- +-- 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). +mkEntityLookup :: + (Hashable a, Eq a) => + [StructureWithGrid b a] -> + HM.HashMap a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a)) +mkEntityLookup grids = + HM.map mkValues 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 + where + structureRowsNE = NE.map myRow singleRows + sm2D = mkRowLookup structureRowsNE + + mkValues neList = AutomatonInfo participatingEnts bounds sm + where + participatingEnts = + HS.fromList + (concatMap (catMaybes . fst) tuples) + + tuples = HM.toList $ HM.mapWithKey mkSmValue groupedByUniqueRow + + groupedByUniqueRow = binTuplesHM $ NE.toList $ NE.map (rowContent . myRow &&& id) neList + bounds = sconcat $ NE.map expandedOffsets neList + sm = makeStateMachine tuples + + -- The values of this map are guaranteed to contain only one + -- entry per row of a given structure. + rowsByEntityParticipation = + binTuplesHM $ + map (myEntity &&& id) $ + concatMap explodeRowEntities rowsAcrossAllStructures + + deriveEntityOffsets :: PositionWithinRow b a -> InspectionOffsets + deriveEntityOffsets (PositionWithinRow pos r) = + mkOffsets pos $ rowContent r + + -- 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 + +-- * Util + +-- | Place the second element of the tuples into bins by +-- the value of the first element. +binTuplesHM :: + (Foldable t, Hashable a, Eq a) => + t (a, b) -> + HM.HashMap a (NE.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 new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs @@ -0,0 +1,98 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Registry of found structures. +-- This datatype contains two maps that must be kept in sync. +-- Uses smart constructors to maintain this invariant. +module Swarm.Game.Scenario.Topography.Structure.Recognition.Registry ( + FoundRegistry, + + -- * Instantiation + emptyFoundStructures, + populateStaticFoundStructures, + + -- * Read-only accessors + foundByName, + foundByLocation, + + -- * Mutation + addFound, + removeStructure, +) +where + +import Control.Arrow ((&&&)) +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 Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Universe (Cosmic) +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. +data FoundRegistry b a = FoundRegistry + { _foundByName :: Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a)) + , _foundByLocation :: Map (Cosmic Location) (FoundStructure b a) + } + +emptyFoundStructures :: FoundRegistry b a +emptyFoundStructures = FoundRegistry mempty mempty + +-- | 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 = _foundByName + +-- | This is a worldwide "mask" that prevents members of placed +-- structures from participating in new structures and facilitates +-- deletion of structures when their elements are removed from the world. +-- +-- Each recognized structure instance will have @MxN@ entries in this map. +foundByLocation :: FoundRegistry b a -> Map (Cosmic Location) (FoundStructure b a) +foundByLocation = _foundByLocation + +removeStructure :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a +removeStructure fs (FoundRegistry byName byLoc) = + FoundRegistry + (M.update tidyDelete structureName byName) + (deleteKeys allOccupiedCoords byLoc) + where + allOccupiedCoords = genOccupiedCoords fs + structureName = getName $ originalDefinition $ structureWithGrid fs + upperLeft = upperLeftCorner fs + + -- NOTE: Observe similarities to + -- Swarm.Game.State.removeRobotFromLocationMap + tidyDelete = NEM.nonEmptyMap . NEM.delete upperLeft + +addFound :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a +addFound fs@(FoundStructure swg loc) (FoundRegistry byName byLoc) = + FoundRegistry + (M.insertWith (<>) k (NEM.singleton loc swg) byName) + (M.union occupationMap byLoc) + where + k = getName $ originalDefinition swg + occupationMap = M.fromList $ map (,fs) $ genOccupiedCoords fs + +-- | Bulk insertion of found structures. +-- +-- Each of these shall have been re-checked in case +-- a subsequent placement occludes them. +populateStaticFoundStructures :: [FoundStructure b a] -> FoundRegistry b a +populateStaticFoundStructures allFound = + FoundRegistry byName byLocation + where + mkOccupationMap fs = M.fromList $ map (,fs) $ genOccupiedCoords fs + byLocation = M.unions $ map mkOccupationMap allFound + + byName = + M.map (NEM.fromList . NE.map (upperLeftCorner &&& structureWithGrid)) $ + binTuples $ + map (getName . originalDefinition . structureWithGrid &&& id) allFound 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 new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Symmetry analysis for structure recognizer. +module Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry where + +import Control.Monad (unless, when) +import Data.Map qualified as M +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) + +-- | Warns if any recognition orientations are redundant +-- by rotational symmetry. +-- We can accomplish this by testing only two rotations: +-- +-- 1. Rotate 90 degrees. If identical to the original +-- orientation, then has 4-fold symmetry and we don't +-- need to check any other orientations. +-- Warn if more than one recognition orientation was supplied. +-- 2. Rotate 180 degrees. At best, we may now have +-- 2-fold symmetry. +-- Warn if two opposite orientations were supplied. +checkSymmetry :: + (MonadFail m, Eq a) => NamedGrid a -> m (SymmetryAnnotatedGrid (NamedGrid a)) +checkSymmetry ng = do + case symmetryType of + FourFold -> + when (Set.size suppliedOrientations > 1) + . failT + . pure + $ T.unwords ["Redundant orientations supplied; with four-fold symmetry, just supply 'north'."] + TwoFold -> + unless (null redundantOrientations) + . failT + . pure + $ T.unwords + [ "Redundant" + , commaList $ map showT redundantOrientations + , "orientations supplied with two-fold symmetry." + ] + where + redundantOrientations = + map fst + . filter ((> 1) . snd) + . M.toList + . histogram + . map getCoordinateOrientation + $ Set.toList suppliedOrientations + _ -> return () + + return $ SymmetryAnnotatedGrid ng symmetryType + where + symmetryType + | quarterTurnRows == originalRows = FourFold + | halfTurnRows == originalRows = TwoFold + | otherwise = NoSymmetry + + quarterTurnRows = applyOrientationTransform (Orientation DWest False) originalRows + halfTurnRows = applyOrientationTransform (Orientation DSouth False) originalRows + + suppliedOrientations = Structure.recognize ng + originalRows = Structure.structure ng 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 new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Structure recognizer types. +-- +-- See overview of the structure recognizer feature in +-- "Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute". +-- +-- The following structure template shall be used to illustrate +-- roles of the types in this module: +-- +-- @ +-- cdc +-- aab +-- cdc +-- @ +module Swarm.Game.Scenario.Topography.Structure.Recognition.Type where + +import Control.Arrow ((&&&)) +import Control.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.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.Scenario.Topography.Area +import Swarm.Game.Universe (Cosmic, offsetBy) +import Swarm.Language.Syntax.Direction (AbsoluteDir) +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. +-- +-- === Example +-- A single entity @a@ in the row: +-- +-- @ +-- aab +-- @ +type AtomicKeySymbol a = Maybe a + +-- | A "needle" consisting row of cells within the haystack +-- (a sequence of rows) to be searched. +-- +-- === Example +-- The complete row: +-- +-- @ +-- aab +-- @ +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. +-- +-- === Example +-- For entity @b@ within the row: +-- +-- @ +-- aab +-- @ +-- +-- Its '_position' is @2@. +data PositionWithinRow b a = PositionWithinRow + { _position :: Int32 + -- ^ horizontal index of the entity within the row + , structureRow :: StructureRow b a + } + +-- Represents all of the locations that particular entity +-- occurs within a specific row of a particular structure. +-- +-- === Example +-- For entity @a@ within the row: +-- +-- @ +-- aab +-- @ +-- +-- this record will contain two entries in its 'entityOccurrences' field. +data SingleRowEntityOccurrences b a = SingleRowEntityOccurrences + { myRow :: StructureRow b a + , myEntity :: a + , entityOccurrences :: NE.NonEmpty (PositionWithinRow b a) + , expandedOffsets :: InspectionOffsets + } + +-- | A a specific row within a particular structure. +-- +-- === Example +-- For the second occurrence of @cdc@ within the structure: +-- +-- @ +-- cdc +-- aab +-- cdc +-- @ +-- +-- it's 'rowIndex' is @2@. +-- +-- The two type parameters, `b` and `a`, correspond +-- to 'StructureCells' 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 + } + +-- | 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 + } + 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. +data StructureWithGrid b a = StructureWithGrid + { originalDefinition :: NamedOriginal b + , rotatedTo :: AbsoluteDir + , entityGrid :: [SymbolSequence 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] + , entityCounts :: Map a Int + } + +-- | For all of the rows that contain a given entity +-- (and are recognized by a single automaton), +-- compute the left-most and right-most position +-- within the row that the given entity may occur. +-- +-- This determines how far to the left and to the right +-- our search of the world cells needs to begin and +-- end, respectively. +-- +-- The 'Semigroup' instance always grows in extent, taking the minimum +-- of the leftward offsets and the maximum of the rightward offsets. +data InspectionOffsets = InspectionOffsets + { startOffset :: Min Int32 + -- ^ Always non-positive (i.e. either zero or negative). + -- For the first-level search, this extends to the left. + -- For the second-level search, this extends upward. + , endOffset :: Max Int32 + -- ^ Always non-negative. + -- For the first-level search, this extends to the right. + -- For the second-level search, this extends downward. + } + deriving (Show, Generic, ToJSON) + +instance Semigroup InspectionOffsets where + 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 + } + deriving (Generic) + +makeLenses ''AutomatonInfo + +-- | 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) + -- ^ 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)) + } + deriving (Generic) + +makeLenses ''RecognizerAutomatons + +-- | Final output of the search process. +-- 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 + } + deriving (Eq) + +-- | Ordering is by increasing preference between simultaneously +-- completed structures. +-- The preference heuristic is for: +-- +-- 1. Primarily, larger area. +-- 2. Secondarily, lower X-Y coords (X is compared first) +-- +-- Since the natural order of coordinates increases as described, +-- we need to invert it with 'Down' so that this ordering is by +-- increasing preference. +instance (Eq b, Eq a) => Ord (FoundStructure b a) where + compare = compare `on` (f1 &&& f2) + where + f1 = computeArea . getAreaDimensions . 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 + where + mkCol y x ent = loc `offsetBy` V2 x (negate y) <$ ent + mkRow rowIdx = zipWith (mkCol rowIdx) [0 ..] diff --git a/src/swarm-topography/Swarm/Game/Universe.hs b/src/swarm-topography/Swarm/Game/Universe.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Universe.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types and utilities for working with "universal locations"; +-- locations that encompass different 2-D subworlds. +module Swarm.Game.Universe where + +import Control.Lens (makeLenses, view) +import Data.Function (on) +import Data.Int (Int32) +import Data.Text (Text) +import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, withText, (.:)) +import GHC.Generics (Generic) +import Linear (V2 (..)) +import Swarm.Game.Location +import Swarm.Util (quote) + +-- * Referring to subworlds + +data SubworldName = DefaultRootSubworld | SubworldName Text + deriving (Show, Eq, Ord, Generic, ToJSON) + +instance FromJSON SubworldName where + parseJSON = withText "subworld name" $ return . SubworldName + +renderWorldName :: SubworldName -> Text +renderWorldName = \case + SubworldName s -> s + DefaultRootSubworld -> "" + +renderQuotedWorldName :: SubworldName -> Text +renderQuotedWorldName = \case + SubworldName s -> quote s + DefaultRootSubworld -> "" + +-- * Universal location + +-- | The swarm universe consists of locations +-- indexed by subworld. +-- Not only is this parameterized datatype useful for planar (2D) +-- coordinates, but is also used for named waypoints. +data Cosmic a = Cosmic + { _subworld :: SubworldName + , _planar :: a + } + deriving (Show, Eq, Ord, Functor, Generic, ToJSON) + +makeLenses ''Cosmic + +instance (FromJSON a) => FromJSON (Cosmic a) where + parseJSON x = case x of + Object v -> do + _subworld <- v .: "subworld" + _planar <- v .: "loc" + pure Cosmic {..} + _ -> Cosmic DefaultRootSubworld <$> parseJSON x + +-- * Measurement + +data DistanceMeasure b = Measurable b | InfinitelyFar + deriving (Eq, Ord) + +getFiniteDistance :: DistanceMeasure b -> Maybe b +getFiniteDistance = \case + Measurable x -> Just x + InfinitelyFar -> Nothing + +-- | Returns 'InfinitelyFar' if not within the same subworld. +cosmoMeasure :: (a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b +cosmoMeasure f a b + | ((/=) `on` view subworld) a b = InfinitelyFar + | otherwise = Measurable $ (f `on` view planar) a b + +-- * Utilities + +defaultCosmicLocation :: Cosmic Location +defaultCosmicLocation = Cosmic DefaultRootSubworld origin + +offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location +offsetBy loc v = fmap (.+^ v) loc diff --git a/src/swarm-topography/Swarm/Game/World/Coords.hs b/src/swarm-topography/Swarm/Game/World/Coords.hs new file mode 100644 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/World/Coords.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- World coordinates. +module Swarm.Game.World.Coords ( + Coords (..), + locToCoords, + coordsToLoc, + addTuple, + BoundsRectangle, +) +where + +import Control.Lens (Rewrapped, Wrapped) +import Data.Array.IArray (Ix) +import Data.Int (Int32) +import GHC.Generics (Generic) +import Swarm.Game.Location (Location, pattern Location) + +------------------------------------------------------------ +-- World coordinates +------------------------------------------------------------ + +-- | World coordinates use @(row,column)@ format, with the row +-- increasing as we move down the screen. We use this format for +-- indexing worlds internally, since it plays nicely with things +-- like drawing the screen, and reading maps from configuration +-- files. The 'locToCoords' and 'coordsToLoc' functions convert back +-- and forth between this type and t'Location', which is used when +-- presenting coordinates externally to the player. +newtype Coords = Coords {unCoords :: (Int32, Int32)} + deriving (Eq, Ord, Show, Ix, Generic) + +instance Rewrapped Coords t +instance Wrapped Coords + +-- | Convert an external @(x,y)@ location to an internal 'Coords' value. +locToCoords :: Location -> Coords +locToCoords (Location x y) = Coords (-y, x) + +-- | Convert an internal 'Coords' value to an external @(x,y)@ location. +coordsToLoc :: Coords -> Location +coordsToLoc (Coords (r, c)) = Location c (-r) + +addTuple :: Coords -> (Int32, Int32) -> Coords +addTuple (Coords (r, c)) (addR, addC) = Coords (r + addR, c + addC) + +-- | Represents the top-left and bottom-right coordinates +-- of a bounding rectangle of cells in the world map +type BoundsRectangle = (Coords, Coords) diff --git a/src/swarm-tournament/Swarm/Web/Auth.hs b/src/swarm-tournament/Swarm/Web/Auth.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tournament/Swarm/Web/Auth.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Authentication logic for Swarm tournament server. +module Swarm.Web.Auth where + +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.UTF8 as BSU +import Data.Map qualified as M +import Data.Text qualified as T +import Data.Text.Encoding qualified as DTE +import Data.Text.Lazy qualified as TL +import Database.SQLite.Simple.ToField +import GHC.Generics (Generic) +import Network.HTTP.Client qualified as HC +import Network.HTTP.Types (hAccept, hUserAgent, parseSimpleQuery, renderSimpleQuery) +import Servant +import Text.Read (readMaybe) + +data GitHubCredentials = GitHubCredentials + { clientId :: BS.ByteString + , clientSecret :: BS.ByteString + } + +instance FromJSON GitHubCredentials where + parseJSON = withObject "GitHubCredentials" $ \v -> do + clientId <- BSU.fromString <$> v .: "CLIENT_ID" + clientSecret <- BSU.fromString <$> v .: "CLIENT_SECRET" + pure GitHubCredentials {..} + +newtype TokenExchangeCode = TokenExchangeCode BS.ByteString + +instance FromHttpApiData TokenExchangeCode where + parseUrlPiece = return . TokenExchangeCode . DTE.encodeUtf8 + +newtype AccessToken = AccessToken BS.ByteString + +instance ToField AccessToken where + toField (AccessToken x) = toField x + +newtype RefreshToken = RefreshToken BS.ByteString + +instance ToField RefreshToken where + toField (RefreshToken x) = toField x + +data UserApiResponse = UserApiResponse + { login :: TL.Text + , id :: Int + , name :: TL.Text + } + deriving (Generic, FromJSON) + +data Expirable a = Expirable + { token :: a + , expirationSeconds :: Int + } + +fetchAuthenticatedUser :: + (MonadIO m, MonadThrow m, MonadFail m) => + HC.Manager -> + AccessToken -> + m UserApiResponse +fetchAuthenticatedUser manager (AccessToken tok) = do + req <- HC.parseUrlThrow "https://api.github.com/user" + resp <- + liftIO + . flip HC.httpLbs manager + . HC.applyBearerAuth tok + $ req + { HC.requestHeaders = + [ (hAccept, "application/vnd.github+json") + , (hUserAgent, "Swarm Gaming Hub") + , ("X-GitHub-Api-Version", "2022-11-28") + ] + } + either fail return $ eitherDecode $ HC.responseBody resp + +data ReceivedTokens = ReceivedTokens + { accessToken :: Expirable AccessToken + , refreshToken :: Expirable RefreshToken + } + +packExchangeResponse :: + M.Map ByteString ByteString -> + Maybe ReceivedTokens +packExchangeResponse valMap = + ReceivedTokens + <$> (Expirable <$> atVal <*> toInt "expires_in") + <*> (Expirable <$> rtVal <*> toInt "refresh_token_expires_in") + where + toInt k = readMaybe . BSU.toString =<< M.lookup k valMap + + atVal = AccessToken <$> M.lookup "access_token" valMap + rtVal = RefreshToken <$> M.lookup "refresh_token" valMap + +exchangeCode :: + (MonadIO m, MonadThrow m, MonadFail m) => + HC.Manager -> + GitHubCredentials -> + TokenExchangeCode -> + m ReceivedTokens +exchangeCode manager creds (TokenExchangeCode code) = do + let qParms = + T.unpack . DTE.decodeUtf8 $ + renderSimpleQuery + True + [ ("client_id", clientId creds) + , ("client_secret", clientSecret creds) + , ("code", code) + ] + req <- HC.parseUrlThrow $ "https://github.com/login/oauth/access_token" <> qParms + resp <- liftIO $ flip HC.httpLbs manager $ req {HC.method = "POST"} + + let parms = parseSimpleQuery $ LBS.toStrict $ HC.responseBody resp + valMap = M.fromList parms + + maybe + (fail "Response did not include access token") + return + $ packExchangeResponse valMap diff --git a/src/swarm-tournament/Swarm/Web/Tournament.hs b/src/swarm-tournament/Swarm/Web/Tournament.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tournament/Swarm/Web/Tournament.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A web service for serving Swarm tournaments. +module Swarm.Web.Tournament ( + defaultPort, + AppData (..), + GitHubCredentials (..), + DeploymentEnvironment (..), + + -- ** Development + webMain, + app, +) where + +import Commonmark qualified as Mark (commonmark, renderHtml) +import Control.Lens hiding (Context) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader (runReaderT) +import Data.Aeson +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Either.Extra (maybeToEither) +import Data.Int (Int64) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding (decodeUtf8, decodeUtf8', encodeUtf8) +import Data.Yaml (decodeEither', defaultEncodeOptions, encodeWith) +import Database.SQLite.Simple (withConnection) +import GHC.Generics (Generic) +import Network.HTTP.Client qualified as HC +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types (hCookie, ok200, renderSimpleQuery) +import Network.Wai (Request, requestHeaders, responseLBS) +import Network.Wai.Application.Static (defaultFileServerSettings) +import Network.Wai.Handler.Warp qualified as Warp +import Network.Wai.Parse ( + defaultParseRequestBodyOptions, + setMaxRequestFileSize, + setMaxRequestKeyLength, + setMaxRequestNumFiles, + ) +import Servant +import Servant.Multipart +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) +import Swarm.Game.Scenario (ScenarioMetadata, scenarioMetadata) +import Swarm.Game.State (Sha1 (..)) +import Swarm.Web.Auth +import Swarm.Web.Tournament.Database.Query +import Swarm.Web.Tournament.Type +import Swarm.Web.Tournament.Validate +import Swarm.Web.Tournament.Validate.FailureMode +import Swarm.Web.Tournament.Validate.Upload +import Web.Cookie + +defaultPort :: Warp.Port +defaultPort = 5500 + +-- | NOTE: The default Servant server timeout is 30 sec; +-- see https://hackage.haskell.org/package/http-client-0.7.17/docs/Network-HTTP-Client-Internal.html#t:ResponseTimeout +defaultSolutionTimeout :: SolutionTimeout +defaultSolutionTimeout = SolutionTimeout 20 + +data DeploymentEnvironment + = LocalDevelopment UserAlias + | ProdDeployment + +data AppData = AppData + { swarmGameGitVersion :: Sha1 + , gitHubCredentials :: GitHubCredentials + , persistence :: PersistenceLayer IO + , developmentMode :: DeploymentEnvironment + } + +type LoginType = Headers '[Header "Location" TL.Text, Header "Set-Cookie" SetCookie] NoContent +type LoginHandler = Handler LoginType + +type TournamentAPI = + "api" :> "private" :> "upload" :> "scenario" :> Header "Referer" TL.Text :> AuthProtect "cookie-auth" :> MultipartForm Mem (MultipartData Mem) :> Verb 'POST 303 '[JSON] (Headers '[Header "Location" TL.Text] ScenarioCharacterization) + :<|> "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 + :<|> "solution" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text + :<|> "list" :> "games" :> Get '[JSON] [TournamentGame] + :<|> "list" :> "game" :> Capture "sha1" Sha1 :> Get '[JSON] GameWithSolutions + :<|> "api" :> "private" :> "login" :> "status" :> AuthProtect "cookie-auth" :> Get '[JSON] UserAlias + :<|> "github-auth-callback" :> QueryParam "code" TokenExchangeCode :> Verb 'GET 303 '[JSON] LoginType + :<|> "api" :> "private" :> "login" :> "local" :> Header "Referer" TL.Text :> Verb 'GET 303 '[JSON] LoginType + :<|> "api" :> "private" :> "login" :> "logout" :> Header "Referer" TL.Text :> Verb 'GET 303 '[JSON] LoginType + +mkApp :: AppData -> Servant.Server TournamentAPI +mkApp appData = + uploadScenario appData + :<|> uploadSolution appData + :<|> getScenarioMetadata appData + :<|> downloadRedactedScenario appData + :<|> downloadSolution appData + :<|> listScenarios + :<|> listSolutions + :<|> echoUsername + :<|> doGithubCallback (authenticationStorage $ persistence appData) (gitHubCredentials appData) + :<|> doLocalDevelopmentLogin (authenticationStorage $ persistence appData) (developmentMode appData) + :<|> doLogout + where + echoUsername = return + +type ToplevelAPI = + TournamentAPI + :<|> "api" :> Raw + :<|> Raw + +tournamentsApiHtml :: LBS.ByteString +tournamentsApiHtml = + encodeUtf8 + . either (error . show) (Mark.renderHtml @()) + . Mark.commonmark "" + $ T.pack "No documentation at this time." + +toServantError :: Describable a => a -> ServerError +toServantError x = err500 {errBody = encodeUtf8 $ TL.fromStrict $ describeText x} + +-- | We need to specify the data returned after authentication +type instance AuthServerData (AuthProtect "cookie-auth") = UserAlias + +myAppCookieName :: BS.ByteString +myAppCookieName = "servant-auth-cookie" + +data LoginProblem = LoginProblem + { problemMessage :: TL.Text + , loginLink :: TL.Text + } + deriving (Generic, ToJSON) + +--- | The auth handler wraps a function from Request -> Handler UserAlias. +--- We look for a token in the request headers that we expect to be in the cookie. +--- The token is then passed to our `lookupAccount` function. +authHandler :: + AuthenticationStorage IO -> + GitHubCredentials -> + DeploymentEnvironment -> + AuthHandler Request UserAlias +authHandler authStorage creds deployMode = mkAuthHandler handler + where + url = case deployMode of + LocalDevelopment _ -> "api/private/login/local" + ProdDeployment -> decodeUtf8 . LBS.fromStrict $ genLoginUrl creds + + throw401 msg = throwError $ err401 {errBody = encode $ LoginProblem msg url} + handler req = either throw401 lookupAccount $ do + cookie <- maybeToEither "Missing cookie header" $ lookup hCookie $ requestHeaders req + maybeToEither "Missing token in cookie" + . fmap (decodeUtf8 . LBS.fromStrict) + . lookup myAppCookieName + $ parseCookies cookie + + -- A method that, when given a cookie/password, will return a 'UserAlias'. + lookupAccount :: TL.Text -> Handler UserAlias + lookupAccount cookieText = do + maybeUser <- liftIO $ usernameFromCookie authStorage cookieText + case maybeUser of + Nothing -> throwError (err403 {errBody = encode $ LoginProblem "Invalid cookie password" url}) + Just usr -> return usr + +-- * Handlers + +defaultRedirectPage :: TL.Text +defaultRedirectPage = "/list-games.html" + +defaultSolutionSubmissionRedirectPage :: TL.Text +defaultSolutionSubmissionRedirectPage = "/list-solutions.html" + +uploadScenario :: + AppData -> + Maybe TL.Text -> + UserAlias -> + MultipartData Mem -> + Handler (Headers '[Header "Location" TL.Text] ScenarioCharacterization) +uploadScenario (AppData gameVersion _ persistenceLayer _) maybeRefererUrl userName multipartData = + Handler . fmap addH . withExceptT toServantError . ExceptT $ + validateScenarioUpload + args + gameVersion + where + addH = addHeader (fromMaybe defaultRedirectPage maybeRefererUrl) + args = + CommonValidationArgs + defaultSolutionTimeout + $ PersistenceArgs + userName + multipartData + (scenarioStorage persistenceLayer) + +uploadSolution :: + AppData -> + Maybe TL.Text -> + UserAlias -> + MultipartData Mem -> + Handler (Headers '[Header "Location" TL.Text] SolutionFileCharacterization) +uploadSolution (AppData _ _ persistenceLayer _) maybeRefererUrl userName multipartData = + Handler . fmap addH . withExceptT toServantError . ExceptT $ + validateSubmittedSolution + args + ((getContent . scenarioStorage) persistenceLayer) + where + addH = addHeader (fromMaybe defaultSolutionSubmissionRedirectPage maybeRefererUrl) + args = + CommonValidationArgs + defaultSolutionTimeout + $ PersistenceArgs + userName + multipartData + (solutionStorage persistenceLayer) + +getScenarioMetadata :: AppData -> Sha1 -> Handler ScenarioMetadata +getScenarioMetadata (AppData _ _ persistenceLayer _) scenarioSha1 = + Handler . withExceptT toServantError $ do + doc <- + ExceptT $ + maybeToEither (DatabaseRetrievalFailure scenarioSha1) + <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1 + + s <- withExceptT RetrievedInstantiationFailure $ initScenarioObjectWithEnv doc + return $ view scenarioMetadata s + +genLoginUrl :: GitHubCredentials -> BS.ByteString +genLoginUrl creds = + "https://github.com/login/oauth/authorize" + <> renderSimpleQuery + True + [ ("client_id", clientId creds) + ] + +downloadSolution :: AppData -> Sha1 -> Handler TL.Text +downloadSolution (AppData _ _ persistenceLayer _) solutionSha1 = do + Handler . withExceptT toServantError $ do + ExceptT $ + maybeToEither (DatabaseRetrievalFailure solutionSha1) + <$> (fmap $ fmap decodeUtf8) ((getContent . solutionStorage) persistenceLayer solutionSha1) + +downloadRedactedScenario :: AppData -> Sha1 -> Handler TL.Text +downloadRedactedScenario (AppData _ _ persistenceLayer _) scenarioSha1 = do + Handler . withExceptT toServantError $ do + doc <- + ExceptT $ + maybeToEither (DatabaseRetrievalFailure scenarioSha1) + <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1 + + rawYamlDict :: Map Key Value <- withExceptT YamlParseFailure . except . decodeEither' $ LBS.toStrict doc + let redactedDict = M.delete "solution" rawYamlDict + withExceptT DecodingFailure . except . decodeUtf8' . LBS.fromStrict $ + encodeWith defaultEncodeOptions redactedDict + +listScenarios :: Handler [TournamentGame] +listScenarios = + Handler . liftIO . withConnection databaseFilename $ runReaderT listGames + +listSolutions :: Sha1 -> Handler GameWithSolutions +listSolutions sha1 = + Handler . liftIO . withConnection databaseFilename . runReaderT $ listSubmissions sha1 + +doGithubCallback :: + AuthenticationStorage IO -> + GitHubCredentials -> + Maybe TokenExchangeCode -> + LoginHandler +doGithubCallback authStorage creds maybeCode = do + c <- maybe (fail "Missing 'code' parameter") return maybeCode + + manager <- liftIO $ HC.newManager tlsManagerSettings + receivedTokens <- exchangeCode manager creds c + + let aToken = token $ accessToken receivedTokens + userInfo <- fetchAuthenticatedUser manager aToken + let user = UserAlias $ login userInfo + x <- doLoginResponse authStorage defaultRedirectPage user + liftIO . withConnection databaseFilename . runReaderT $ do + insertGitHubTokens user receivedTokens + return x + +doLocalDevelopmentLogin :: + AuthenticationStorage IO -> + DeploymentEnvironment -> + Maybe TL.Text -> + LoginHandler +doLocalDevelopmentLogin authStorage envType maybeRefererUrl = + case envType of + ProdDeployment -> error "Login bypass not available in production" + LocalDevelopment user -> + doLoginResponse authStorage refererUrl user + where + refererUrl = fromMaybe defaultRedirectPage maybeRefererUrl + +makeCookieHeader :: BS.ByteString -> SetCookie +makeCookieHeader val = + defaultSetCookie + { setCookieName = myAppCookieName + , setCookieValue = val + , setCookiePath = Just "/api/private" + } + +doLogout :: Maybe TL.Text -> LoginHandler +doLogout maybeRefererUrl = + return $ + addHeader (fromMaybe defaultRedirectPage maybeRefererUrl) $ + addHeader ((makeCookieHeader "") {setCookieMaxAge = Just 0}) NoContent + +doLoginResponse :: + AuthenticationStorage IO -> + TL.Text -> + UserAlias -> + LoginHandler +doLoginResponse authStorage refererUrl userAlias = do + cookieString <- + liftIO $ cookieFromUsername authStorage userAlias + return $ + addHeader refererUrl $ + addHeader (makeCookieHeader $ LBS.toStrict $ encodeUtf8 cookieString) NoContent + +-- * Web app declaration + +app :: Bool -> AppData -> Application +app unitTestFileserver appData = + Servant.serveWithContext (Proxy :: Proxy ToplevelAPI) context $ + server unitTestFileserver + where + size100kB = 100_000 :: Int64 + + multipartOpts :: MultipartOptions Mem + multipartOpts = + (defaultMultipartOptions (Proxy :: Proxy Mem)) + { generalOptions = + setMaxRequestFileSize size100kB + . setMaxRequestKeyLength 64 + . setMaxRequestNumFiles 1 + $ defaultParseRequestBodyOptions + } + + thisAuthHandler = + authHandler + (authenticationStorage $ persistence appData) + (gitHubCredentials appData) + (developmentMode appData) + context = thisAuthHandler :. multipartOpts :. EmptyContext + + server :: Bool -> Server ToplevelAPI + server fakeFileserverForUnitTest = + mkApp appData + :<|> Tagged serveDocs + :<|> fileserver + where + fileserver = + if fakeFileserverForUnitTest + then -- This is required because the data only files available to + -- the testing environment are included in the cabal file + -- in the "data-files" clause. + -- However, since that clause is global to the package, + -- we choose not to include the tournament server's web + -- 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!") + ] + else + serveDirectoryWith + (defaultFileServerSettings "tournament/web") + + serveDocs _ resp = + resp $ responseLBS ok200 [htmlType] tournamentsApiHtml + htmlType = ("Content-Type", "text/html") + +webMain :: + AppData -> + Warp.Port -> + IO () +webMain appData port = Warp.runSettings settings $ app False appData + where + settings = Warp.setPort port Warp.defaultSettings diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Database/Query.hs b/src/swarm-tournament/Swarm/Web/Tournament/Database/Query.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tournament/Swarm/Web/Tournament/Database/Query.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} + +{-# HLINT ignore "Functor law" #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- SQL Queries for Swarm tournaments. +module Swarm.Web.Tournament.Database.Query where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Control.Monad.Trans.Reader (ReaderT, ask) +import Data.ByteString.Lazy qualified as LBS +import Data.Maybe (listToMaybe) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Time.Clock +import Database.SQLite.Simple +import Database.SQLite.Simple.ToField +import Swarm.Game.Scenario.Scoring.CodeSize +import Swarm.Game.State (Sha1 (..)) +import Swarm.Game.Tick (TickNumber (..)) +import Swarm.Web.Auth +import Swarm.Web.Tournament.Type + +type ConnectInfo = String + +databaseFilename :: ConnectInfo +databaseFilename = "swarm-games.db" + +newtype UserId = UserId Int + +instance ToField UserId where + toField (UserId x) = toField x + +data AuthenticationStorage m = AuthenticationStorage + { usernameFromCookie :: TL.Text -> m (Maybe UserAlias) + , cookieFromUsername :: UserAlias -> m TL.Text + } + +data PersistenceLayer m = PersistenceLayer + { scenarioStorage :: ScenarioPersistence m ScenarioUploadResponsePayload + , solutionStorage :: ScenarioPersistence m SolutionUploadResponsePayload + , authenticationStorage :: AuthenticationStorage m + } + +data ScenarioPersistence m a = ScenarioPersistence + { lookupCache :: Sha1 -> m (Maybe AssociatedSolutionCharacterization) + -- ^ Looks up by key + , storeCache :: CharacterizationResponse a -> m Sha1 + -- ^ Stores and returns key + , getContent :: Sha1 -> m (Maybe LBS.ByteString) + -- ^ Dump file contents + } + +data UserAttributedUpload = UserAttributedUpload + { uploader :: UserAlias + , fileUpload :: FileUpload + } + +data CharacterizationResponse a = CharacterizationResponse + { upload :: UserAttributedUpload + , associatedCharacterization :: AssociatedSolutionCharacterization + , payload :: a + } + +data ScenarioUploadResponsePayload = ScenarioUploadResponsePayload + { swarmGameVersion :: Sha1 + , sTitle :: T.Text + } + +newtype SolutionUploadResponsePayload = SolutionUploadResponsePayload + { scenariohash :: Sha1 + } + +instance FromRow AssociatedSolutionCharacterization where + fromRow = + AssociatedSolutionCharacterization + <$> (Sha1 <$> field) + <*> fromRow + +instance FromRow SolutionCharacterization where + fromRow = + SolutionCharacterization + <$> field + <*> (TickNumber <$> field) + <*> field + <*> (ScenarioCodeMetrics <$> field <*> field) + +instance FromRow TournamentGame where + fromRow = + TournamentGame + <$> field + <*> field + <*> (Sha1 <$> field) + <*> field + <*> (Sha1 <$> field) + <*> field + +instance FromRow TournamentSolution where + fromRow = + TournamentSolution + <$> field + <*> field + <*> fromRow + +instance FromRow SolutionFileCharacterization where + fromRow = + SolutionFileCharacterization + <$> (Sha1 <$> field) + <*> fromRow + +-- * Authentication + +-- | If the username already exists, overwrite the row. +insertCookie :: + UserAlias -> + ReaderT Connection IO TL.Text +insertCookie gitHubUsername = do + conn <- ask + liftIO $ do + [Only cookieString] <- + query + conn + "REPLACE INTO users (alias) VALUES (?) RETURNING cookie;" + (Only gitHubUsername) + return cookieString + +-- | If the username already exists, overwrite the row. +insertGitHubTokens :: + UserAlias -> + ReceivedTokens -> + ReaderT Connection IO () +insertGitHubTokens gitHubUsername gitHubTokens = do + conn <- ask + currentTime <- liftIO getCurrentTime + let expirationOf = mkExpirationTime currentTime + liftIO $ do + execute + conn + "REPLACE INTO github_tokens (alias, github_access_token, github_access_token_expires_at, github_refresh_token, github_refresh_token_expires_at) VALUES (?, ?, ?, ?, ?);" + ( gitHubUsername + , token $ accessToken gitHubTokens + , expirationOf accessToken + , token $ refreshToken gitHubTokens + , expirationOf refreshToken + ) + return () + where + mkExpirationTime currTime accessor = + addUTCTime (fromIntegral $ expirationSeconds $ accessor gitHubTokens) currTime + +getUsernameFromCookie :: + TL.Text -> + ReaderT Connection IO (Maybe UserAlias) +getUsernameFromCookie cookieText = do + conn <- ask + liftIO . fmap (fmap (UserAlias . fromOnly) . listToMaybe) $ + query conn "SELECT alias FROM users WHERE cookie = ?;" (Only cookieText) + +-- * Retrieval + +lookupScenarioContent :: Sha1 -> ReaderT Connection IO (Maybe LBS.ByteString) +lookupScenarioContent sha1 = do + conn <- ask + liftIO . fmap (fmap fromOnly . listToMaybe) $ + query conn "SELECT content FROM scenarios WHERE content_sha1 = ?;" (Only sha1) + +lookupSolutionContent :: Sha1 -> ReaderT Connection IO (Maybe LBS.ByteString) +lookupSolutionContent sha1 = do + conn <- ask + liftIO . fmap (fmap fromOnly . listToMaybe) $ + query conn "SELECT content FROM solution_submission WHERE content_sha1 = ?;" (Only sha1) + +lookupSolutionSubmission :: Sha1 -> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization) +lookupSolutionSubmission contentSha1 = do + conn <- ask + liftIO $ runMaybeT $ do + evaluationId :: Int <- + MaybeT $ + fmap fromOnly . listToMaybe + <$> query conn "SELECT solution_evaluation FROM solution_submission WHERE content_sha1 = ?;" (Only contentSha1) + + MaybeT $ + listToMaybe + <$> query conn "SELECT scenario, wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE id = ?;" (Only evaluationId) + +-- | There should only be one builtin solution for the scenario. +lookupScenarioSolution :: Sha1 -> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization) +lookupScenarioSolution scenarioSha1 = do + conn <- ask + solnChar <- + liftIO . fmap listToMaybe $ + query conn "SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE builtin AND scenario = ? LIMIT 1;" (Only scenarioSha1) + return $ AssociatedSolutionCharacterization scenarioSha1 <$> solnChar + +listGames :: ReaderT Connection IO [TournamentGame] +listGames = do + conn <- ask + liftIO $ + query_ conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1, title FROM agg_scenario_submissions;" + +listSubmissions :: Sha1 -> ReaderT Connection IO GameWithSolutions +listSubmissions scenarioSha1 = do + conn <- ask + liftIO $ do + [game] <- query conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1, title FROM agg_scenario_submissions WHERE scenario = ?;" (Only scenarioSha1) + solns <- query conn "SELECT uploaded_at, solution_submitter, solution_sha1, wall_time_seconds, ticks, seed, char_count, ast_size FROM all_solution_submissions WHERE scenario = ?;" (Only scenarioSha1) + return $ GameWithSolutions game solns + +-- * Insertion + +insertScenario :: + CharacterizationResponse ScenarioUploadResponsePayload -> + ReaderT Connection IO Sha1 +insertScenario s = do + conn <- ask + h <- liftIO $ do + [Only resultList] <- + query + conn + "INSERT INTO scenarios (content_sha1, content, original_filename, title, uploader, swarm_git_sha1) VALUES (?, ?, ?, ?, ?, ?) RETURNING content_sha1;" + ( scenarioSha + , fileContent $ fileUpload $ upload s + , filename . fileMetadata . fileUpload $ upload s + , sTitle $ payload s + , uploader $ upload s + , swarmGameVersion $ payload s + ) + _ <- insertSolution conn True scenarioSha $ characterization $ associatedCharacterization s + + return resultList + return $ Sha1 h + where + scenarioSha = fileHash . fileMetadata . fileUpload $ upload s + +insertSolutionSubmission :: + CharacterizationResponse SolutionUploadResponsePayload -> + ReaderT Connection IO Sha1 +insertSolutionSubmission (CharacterizationResponse solutionUpload s (SolutionUploadResponsePayload scenarioSha)) = do + conn <- ask + liftIO $ do + solutionEvalId <- insertSolution conn False scenarioSha $ characterization s + [Only echoedSha1] <- + query + conn + "INSERT INTO solution_submission (uploader, content_sha1, solution_evaluation, content) VALUES (?, ?, ?, ?) RETURNING content_sha1;" + ( uploader solutionUpload + , fileHash $ fileMetadata $ fileUpload solutionUpload + , solutionEvalId + , fileContent $ fileUpload solutionUpload + ) + return $ Sha1 echoedSha1 + +insertSolution :: + Connection -> + Bool -> + Sha1 -> + SolutionCharacterization -> + IO Int +insertSolution conn isBuiltin scenarioSha s = do + [Only evaluationId] <- + query + conn + "INSERT INTO evaluated_solution (scenario, builtin, wall_time_seconds, ticks, seed, char_count, ast_size) VALUES (?, ?, ?, ?, ?, ?, ?) RETURNING id;" + insertion_items + return evaluationId + where + insertion_items = + ( scenarioSha + , isBuiltin + , solutionWallTime s + , getTickNumber $ solutionTicks s + , scenarioSeed s + , sourceTextLength $ solutionCodeMetrics s + , astSize $ solutionCodeMetrics s + ) diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Type.hs b/src/swarm-tournament/Swarm/Web/Tournament/Type.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tournament/Swarm/Web/Tournament/Type.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types for Swarm tournaments. +module Swarm.Web.Tournament.Type where + +import Data.Aeson +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Time (UTCTime) +import Database.SQLite.Simple.ToField +import GHC.Generics (Generic) +import Servant +import Servant.Docs (ToCapture) +import Servant.Docs qualified as SD +import Swarm.Game.Scenario.Scoring.CodeSize +import Swarm.Game.State (Sha1 (..)) +import Swarm.Game.Tick (TickNumber (..)) +import Swarm.Game.World.Gen (Seed) +import System.Time.Extra + +newtype UserAlias = UserAlias TL.Text + deriving (Generic, ToJSON) + +instance ToField UserAlias where + toField (UserAlias x) = toField x + +instance ToField Sha1 where + toField (Sha1 x) = toField x + +data FileMetadata = FileMetadata + { filename :: T.Text + , fileHash :: Sha1 + } + deriving (Generic, ToJSON) + +data FileUpload = FileUpload + { fileContent :: LBS.ByteString + , fileMetadata :: FileMetadata + } + +data TournamentGame = TournamentGame + { originalFilename :: T.Text + , scenarioUploader :: T.Text + , scenarioHash :: Sha1 + , submissionCount :: Int + , swarmGitSha1 :: Sha1 + , scenarioTitle :: T.Text + } + deriving (Generic, ToJSON) + +data TournamentSolution = TournamentSolution + { submissionTime :: UTCTime + , solutionSubmitter :: T.Text + , submissionScore :: SolutionFileCharacterization + } + deriving (Generic, ToJSON) + +data GameWithSolutions = GameWithSolutions + { theGame :: TournamentGame + , theSolutions :: [TournamentSolution] + } + deriving (Generic, ToJSON) + +data AssociatedSolutionCharacterization = AssociatedSolutionCharacterization + { forScenario :: Sha1 + , characterization :: SolutionCharacterization + } + +data SolutionCharacterization = SolutionCharacterization + { solutionWallTime :: Seconds + , solutionTicks :: TickNumber + , scenarioSeed :: Seed + , solutionCodeMetrics :: ScenarioCodeMetrics + } + deriving (Generic, ToJSON) + +data SolutionFileCharacterization = SolutionFileCharacterization + { solutionHash :: Sha1 + , solutionCharacterization :: SolutionCharacterization + } + deriving (Generic, ToJSON) + +data ScenarioCharacterization = ScenarioCharacterization + { scenarioFileMetadata :: FileMetadata + , builtinSolution :: SolutionCharacterization + } + deriving (Generic, ToJSON) + +instance FromHttpApiData Sha1 where + parseUrlPiece = return . Sha1 . T.unpack + +instance ToCapture (Capture "sha1" Sha1) where + toCapture _ = + SD.DocCapture + "sha1" -- name + "(text) scenario sha1" -- description diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs b/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Validates an uploaded scenario +module Swarm.Web.Tournament.Validate where + +import Control.Arrow (left) +import Control.Carrier.Accum.FixedStrict (evalAccum) +import Control.Carrier.Throw.Either (runThrow) +import Control.Lens +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State (evalStateT) +import Control.Monad.Trans.Except +import Data.ByteString.Lazy qualified as LBS +import Data.Either.Extra (maybeToEither) +import Data.Sequence (Seq) +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8') +import Data.Yaml (decodeEither', parseEither) +import Servant.Multipart +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.State +import Swarm.Game.State.Initialize (scenarioToGameState) +import Swarm.Game.State.Runtime (initGameStateConfig, initScenarioInputs) +import Swarm.Game.State.Substate (initState, seed) +import Swarm.Game.Step.Validate (playUntilWin) +import Swarm.Language.Pipeline +import Swarm.Language.Syntax (TSyntax) +import Swarm.Util.Yaml +import Swarm.Web.Tournament.Database.Query +import Swarm.Web.Tournament.Type +import Swarm.Web.Tournament.Validate.FailureMode +import Swarm.Web.Tournament.Validate.Upload +import System.Time.Extra + +newtype SolutionTimeout = SolutionTimeout Seconds + +data CommonValidationArgs m a + = CommonValidationArgs + SolutionTimeout + (PersistenceArgs m a) + +validateScenarioUpload :: + CommonValidationArgs IO ScenarioUploadResponsePayload -> + -- | Game version + Sha1 -> + IO (Either ScenarioUploadValidationFailure ScenarioCharacterization) +validateScenarioUpload (CommonValidationArgs solnTimeout persistenceArgs) gameVersion = + runExceptT $ do + (fileMeta, solnMetrics) <- + withFileCache + persistenceArgs + ScenarioUploadFailure + computeMetrics + + pure $ + ScenarioCharacterization + fileMeta + (characterization solnMetrics) + where + computeMetrics file = do + (gs, scenarioObject) <- + withExceptT ScenarioUploadInstantiationFailure $ + gamestateFromScenarioText $ + fileContent file + + soln <- except $ maybeToEither NoSolutionProvided $ gs ^. winSolution + + solnMetrics <- + withExceptT ScenarioSolutionEvaluationFailure $ + verifySolution solnTimeout soln gs + + return + ( AssociatedSolutionCharacterization (fileHash $ fileMetadata file) solnMetrics + , ScenarioUploadResponsePayload gameVersion $ + scenarioObject ^. scenarioMetadata . scenarioName + ) + +validateSubmittedSolution :: + CommonValidationArgs IO SolutionUploadResponsePayload -> + -- | Scenario lookup function + (Sha1 -> IO (Maybe LBS.ByteString)) -> + IO (Either SolutionSubmissionFailure SolutionFileCharacterization) +validateSubmittedSolution (CommonValidationArgs solnTimeout persistenceArgs) scenarioLookupFunc = + runExceptT $ do + userSuppliedScenarioSha1 <- + withExceptT MissingScenarioParameter + . except + . fmap (Sha1 . T.unpack) + $ lookupInput "scenario" multipartData + + (fileMeta, solnMetrics) <- + withFileCache + persistenceArgs + SolutionUploadFailure + (computeMetrics userSuppliedScenarioSha1) + + let retrievedScenarioHash = forScenario solnMetrics + + -- We validate that the uploaded solution, if retrieved from the + -- cache, actually is for the scenario with the hash they + -- supplied in the upload metadata. + -- If someone re-uploads a solution file that already happens to be + -- stored in the database, but specifies a different scenario hash, + -- we should alert about this mistake with an error. + unless (userSuppliedScenarioSha1 == retrievedScenarioHash) + . except + . Left + $ CachedSolutionScenarioMismatch userSuppliedScenarioSha1 retrievedScenarioHash + + pure $ SolutionFileCharacterization (fileHash fileMeta) $ characterization solnMetrics + where + PersistenceArgs _ multipartData _ = persistenceArgs + + computeMetrics scenarioSha1 file = do + solText <- + withExceptT SolutionUnicodeError + . except + . decodeUtf8' + . LBS.toStrict + $ fileContent file + soln <- withExceptT SolutionParseError . except $ processTermEither solText + + gs <- withExceptT ScenarioRetrievalFailure $ do + scenarioContent <- + withExceptT DatabaseRetrievalFailure $ + ExceptT + ( maybeToEither scenarioSha1 + <$> scenarioLookupFunc scenarioSha1 + ) + + fmap fst $ + withExceptT RetrievedInstantiationFailure $ + gamestateFromScenarioText scenarioContent + + solnMetrics <- + withExceptT SubmittedSolutionEvaluationFailure $ + verifySolution solnTimeout soln gs + + return + ( AssociatedSolutionCharacterization scenarioSha1 solnMetrics + , SolutionUploadResponsePayload scenarioSha1 + ) + +-- * Utils + +initScenarioObjectWithEnv :: + LBS.ByteString -> + ExceptT ScenarioInstantiationFailure IO Scenario +initScenarioObjectWithEnv content = do + scenarioInputs <- + withExceptT (ScenarioEnvironmentFailure . ContextInitializationFailure) + . ExceptT + . runThrow + $ evalAccum (mempty :: Seq SystemFailure) initScenarioInputs + + initScenarioObject scenarioInputs content + +initScenarioObject :: + ScenarioInputs -> + LBS.ByteString -> + ExceptT ScenarioInstantiationFailure IO Scenario +initScenarioObject scenarioInputs content = do + rawYaml <- withExceptT YamlDecodeError . except . decodeEither' $ LBS.toStrict content + withExceptT ScenarioParseFailure $ + except $ + parseEither (parseJSONE' scenarioInputs) rawYaml + +gamestateFromScenarioText :: + LBS.ByteString -> + ExceptT ScenarioInstantiationFailure IO (GameState, Scenario) +gamestateFromScenarioText content = do + gsc <- + withExceptT (ScenarioEnvironmentFailure . ContextInitializationFailure) + . ExceptT + . runThrow + $ evalAccum (mempty :: Seq SystemFailure) initGameStateConfig + + let scenarioInputs = gsiScenarioInputs $ initState gsc + scenarioObject <- initScenarioObject scenarioInputs content + gs <- liftIO $ scenarioToGameState scenarioObject emptyLaunchParams gsc + return (gs, scenarioObject) + +verifySolution :: + SolutionTimeout -> + TSyntax -> + GameState -> + ExceptT SolutionEvaluationFailure IO SolutionCharacterization +verifySolution (SolutionTimeout timeoutSeconds) sol gs = do + (actualTime, eitherTickCount) <- + ExceptT + . fmap (maybeToEither (SolutionExecutionTimeout timeoutSeconds)) + . timeout timeoutSeconds + . duration + $ evalStateT playUntilWin gs' + + tickCount <- except $ left ErrorsDuringExecution eitherTickCount + + return $ + SolutionCharacterization + actualTime + tickCount + (gs ^. randomness . seed) + codeMetrics + where + codeMetrics = codeMetricsFromSyntax sol + gs' = gs & baseRobot . machine %~ continue sol diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs b/src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Failure modes for validating an uploaded scenario +module Swarm.Web.Tournament.Validate.FailureMode where + +import Control.Exception.Base (displayException) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Data.Text.Encoding.Error (UnicodeException) +import Data.Yaml (ParseException) +import Swarm.Game.Failure (SystemFailure) +import Swarm.Game.State (Sha1 (..)) +import Swarm.Util (parens, showT) +import System.Time.Extra (Seconds, showDuration) + +class Describable a where + describeText :: a -> T.Text + +newtype GenericUploadFailure = GenericUploadFailure FileUploadFailure + +instance Describable GenericUploadFailure where + describeText (GenericUploadFailure x) = describeText x + +data FileUploadFailure + = NoFileSupplied + | MultipleFiles Int + +instance Describable FileUploadFailure where + describeText NoFileSupplied = "Must supply a file!" + describeText (MultipleFiles count) = + T.unwords + [ "Only one file is allowed! Provided" + , showT count + ] + +newtype ContextInitializationFailure = ContextInitializationFailure SystemFailure + +instance Describable ContextInitializationFailure where + describeText (ContextInitializationFailure x) = showT x + +data SolutionEvaluationFailure + = SolutionGameStateInitializationFailure ContextInitializationFailure + | SolutionExecutionTimeout Seconds + | ErrorsDuringExecution (NE.NonEmpty T.Text) + +instance Describable SolutionEvaluationFailure where + describeText (SolutionGameStateInitializationFailure x) = describeText x + describeText (SolutionExecutionTimeout s) = + T.unwords + [ "Timed out - this likely means that the solution did not work." + , "Limit is" + , T.pack $ showDuration s + ] + describeText (ErrorsDuringExecution x) = T.unlines $ NE.toList x + +data ScenarioInstantiationFailure + = ScenarioEnvironmentFailure ContextInitializationFailure + | YamlDecodeError ParseException + | ScenarioParseFailure String + +instance Describable ScenarioInstantiationFailure where + describeText (ScenarioEnvironmentFailure x) = describeText x + describeText (YamlDecodeError x) = T.pack $ displayException x + describeText (ScenarioParseFailure x) = T.pack x + +data ScenarioUploadValidationFailure + = ScenarioUploadFailure GenericUploadFailure + | NoSolutionProvided + | ScenarioUploadInstantiationFailure ScenarioInstantiationFailure + | ScenarioSolutionEvaluationFailure SolutionEvaluationFailure + +instance Describable ScenarioUploadValidationFailure where + describeText (ScenarioUploadFailure x) = describeText x + describeText NoSolutionProvided = "No solution to test!" + describeText (ScenarioUploadInstantiationFailure x) = describeText x + describeText (ScenarioSolutionEvaluationFailure x) = describeText x + +data ScenarioRetrievalFailure + = DatabaseRetrievalFailure Sha1 + | RetrievedInstantiationFailure ScenarioInstantiationFailure + | DecodingFailure UnicodeException + | YamlParseFailure ParseException + +instance Describable ScenarioRetrievalFailure where + describeText (DatabaseRetrievalFailure (Sha1 h)) = + T.unwords + [ "Scenario with hash" + , T.pack h + , "not found" + ] + describeText (RetrievedInstantiationFailure x) = describeText x + describeText (DecodingFailure x) = T.pack $ displayException x + describeText (YamlParseFailure x) = T.pack $ displayException x + +data SolutionSubmissionFailure + = SolutionUploadFailure GenericUploadFailure + | MissingScenarioParameter String + | SubmittedSolutionEvaluationFailure SolutionEvaluationFailure + | SolutionUnicodeError UnicodeException + | SolutionParseError T.Text + | ScenarioRetrievalFailure ScenarioRetrievalFailure + | CachedSolutionScenarioMismatch Sha1 Sha1 + +instance Describable SolutionSubmissionFailure where + describeText (SolutionUploadFailure x) = describeText x + describeText (MissingScenarioParameter x) = T.pack x + describeText (SubmittedSolutionEvaluationFailure x) = describeText x + describeText (SolutionUnicodeError x) = T.pack $ displayException x + describeText (SolutionParseError x) = x + describeText (ScenarioRetrievalFailure x) = describeText x + describeText (CachedSolutionScenarioMismatch (Sha1 userSuppliedScenarioSha1) (Sha1 retrievedScenarioHash)) = + T.unwords + [ "User-supplied scenario hash" + , parens $ T.pack userSuppliedScenarioSha1 + , "did not match scenario hash for previously computed solution" + , parens $ T.pack retrievedScenarioHash + ] diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Validate/Upload.hs b/src/swarm-tournament/Swarm/Web/Tournament/Validate/Upload.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tournament/Swarm/Web/Tournament/Validate/Upload.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Validates an uploaded scenario +module Swarm.Web.Tournament.Validate.Upload where + +import Control.Monad (void, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except +import Data.Digest.Pure.SHA (sha1, showDigest) +import Data.Either.Extra (maybeToEither) +import Data.List.NonEmpty qualified as NE +import Servant.Multipart +import Swarm.Game.State +import Swarm.Web.Tournament.Database.Query +import Swarm.Web.Tournament.Type +import Swarm.Web.Tournament.Validate.FailureMode + +data PersistenceArgs m a + = PersistenceArgs + UserAlias + (MultipartData Mem) + (ScenarioPersistence m a) + +obtainFileUpload :: + MultipartData Mem -> + ExceptT GenericUploadFailure IO FileUpload +obtainFileUpload multipartData = + withExceptT GenericUploadFailure $ do + nonemptyFiles <- + except $ + maybeToEither NoFileSupplied maybeNonemptyFiles + + let suppliedCount = NE.length nonemptyFiles + when (suppliedCount > 1) . except . Left $ MultipleFiles suppliedCount + + let file = NE.head nonemptyFiles + content = fdPayload file + theSha1Hash = Sha1 $ showDigest $ sha1 content + + return $ FileUpload content $ FileMetadata (fdFileName file) theSha1Hash + where + maybeNonemptyFiles = NE.nonEmpty $ files multipartData + +withFileCache :: + PersistenceArgs IO a -> + (GenericUploadFailure -> e) -> + (FileUpload -> ExceptT e IO (AssociatedSolutionCharacterization, a)) -> + ExceptT e IO (FileMetadata, AssociatedSolutionCharacterization) +withFileCache (PersistenceArgs userAlias multipartData persistenceFunctions) errorWrapper cacheStoreFunction = do + file <- withExceptT errorWrapper $ obtainFileUpload multipartData + maybePreexisting <- + liftIO + . lookupCache persistenceFunctions + . fileHash + $ fileMetadata file + solnMetrics <- maybe (doStore file) return maybePreexisting + return (fileMetadata file, solnMetrics) + where + doStore file = do + (result, a) <- cacheStoreFunction file + + liftIO + . void + . storeCache persistenceFunctions + $ CharacterizationResponse + (UserAttributedUpload userAlias file) + result + a + + return result diff --git a/src/swarm-tui/Swarm/TUI/Border.hs b/src/swarm-tui/Swarm/TUI/Border.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Border.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Special border drawing functions that can include labels in more +-- places than just the top center. +module Swarm.TUI.Border ( + -- * Horizontal border labels + HBorderLabels, + plainHBorder, + leftLabel, + centerLabel, + rightLabel, + + -- * Rectangular border labels + BorderLabels, + plainBorder, + topLabels, + bottomLabels, + + -- * Border-drawing functions + hBorderWithLabels, + borderWithLabels, +) where + +import Brick +import Brick.Widgets.Border +import Control.Lens (makeLenses, to, (^.)) +import Data.Function ((&)) +import Graphics.Vty qualified as V + +-- | Labels for a horizontal border, with optional left, middle, and +-- right labels. +data HBorderLabels n = HBorderLabels + { _leftLabel :: Maybe (Widget n) + , _centerLabel :: Maybe (Widget n) + , _rightLabel :: Maybe (Widget n) + } + +-- | A plain horizontal border with no labels. +plainHBorder :: HBorderLabels n +plainHBorder = HBorderLabels Nothing Nothing Nothing + +-- | Labels for a rectangular border, with optional left, middle, and +-- right labels on the top and bottom. +data BorderLabels n = BorderLabels + { _topLabels :: HBorderLabels n + , _bottomLabels :: HBorderLabels n + } + +-- | A plain rectangular border with no labels. +plainBorder :: BorderLabels n +plainBorder = BorderLabels plainHBorder plainHBorder + +makeLenses ''HBorderLabels +makeLenses ''BorderLabels + +-- | Draw a horizontal border with three optional labels. The left +-- label (if present) will be placed two units away from the left +-- end of the border, and the right label will be placed two units +-- away from the right end. The center label, if present, will +-- always be centered in the border overall, regardless of the width +-- of the left and right labels. This ensures that when the labels +-- change width, they do not cause the other labels to wiggle. +hBorderWithLabels :: + HBorderLabels n -> Widget n +hBorderWithLabels (HBorderLabels l c r) = + Widget Greedy Fixed $ do + let renderLabel = render . maybe emptyWidget (vLimit 1) + rl <- renderLabel l + rc <- renderLabel c + rr <- renderLabel r + + -- Figure out how wide the whole border is supposed to be + ctx <- getContext + let w = ctx ^. availWidthL + + -- Get the widths of the labels + lw = V.imageWidth (image rl) + cw = V.imageWidth (image rc) + + -- Now render the border with labels. + render $ + hBox + [ hLimit 2 hBorder + , Widget Fixed Fixed (return rl) + , -- We calculate the specific width of border between the left + -- and center labels needed to ensure that the center label is + -- in the right place. Note, using (cw + 1) `div` 2, as + -- opposed to cw `div` 2, means that the placement of the + -- center label will be left-biased: if it does not fit + -- exactly at the center it will be placed just to the left of + -- center. + hLimit (w `div` 2 - 2 - lw - (cw + 1) `div` 2) hBorder + , Widget Fixed Fixed (return rc) + , -- The border between center and right greedily fills up any + -- remaining width. + hBorder + , Widget Fixed Fixed (return rr) + , hLimit 2 hBorder + ] + +-- | Put a rectangular border around the specified widget with the +-- specified label widgets placed around the border. +borderWithLabels :: BorderLabels n -> Widget n -> Widget n +borderWithLabels labels wrapped = + Widget (hSize wrapped) (vSize wrapped) $ do + c <- getContext + + middleResult <- + wrapped + & vLimit (c ^. availHeightL - 2) + & hLimit (c ^. availWidthL - 2) + & render + + let tl = joinableBorder (Edges False True False True) + tr = joinableBorder (Edges False True True False) + bl = joinableBorder (Edges True False False True) + br = joinableBorder (Edges True False True False) + top = tl <+> hBorderWithLabels (labels ^. topLabels) <+> tr + bottom = bl <+> hBorderWithLabels (labels ^. bottomLabels) <+> br + middle = vBorder <+> Widget Fixed Fixed (return middleResult) <+> vBorder + total = top <=> middle <=> bottom + + total + & vLimit (middleResult ^. imageL . to V.imageHeight + 2) + & hLimit (middleResult ^. imageL . to V.imageWidth + 2) + & render diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -0,0 +1,799 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Event handlers for the TUI. +module Swarm.TUI.Controller ( + -- * Event handling + handleEvent, + quitGame, + + -- ** Handling 'Swarm.TUI.Model.Frame' events + runFrameUI, + ticksPerFrameCap, + runGameTickUI, + + -- ** REPL panel + runBaseWebCode, + handleREPLEvent, + validateREPLForm, + adjReplHistIndex, + TimeDir (..), + + -- ** Info panel + handleInfoPanelEvent, +) where + +-- See Note [liftA2 re-export from Prelude] +import Prelude hiding (Applicative (..)) + +import Brick hiding (Direction, Location) +import Brick.Focus +import Brick.Keybindings qualified as B +import Brick.Widgets.Dialog +import Brick.Widgets.Edit (Editor, applyEdit, handleEditorEvent) +import Brick.Widgets.List (handleListEvent) +import Brick.Widgets.List qualified as BL +import Control.Applicative (pure) +import Control.Category ((>>>)) +import Control.Lens as Lens +import Control.Monad (unless, void, when) +import Control.Monad.Extra (whenJust) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState, execState) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Set (Set) +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.Text.Zipper qualified as TZ +import Data.Text.Zipper.Generic.Words qualified as TZ +import Data.Vector qualified as V +import Graphics.Vty qualified as V +import Swarm.Game.Achievement.Definitions +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.ScenarioInfo +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.State.Runtime +import Swarm.Game.State.Substate +import Swarm.Language.Capability ( + Capability (CGod), + constCaps, + ) +import Swarm.Language.Context +import Swarm.Language.Key (KeyCombo, mkKeyCombo) +import Swarm.Language.Parser (readTerm') +import Swarm.Language.Parser.Core (defaultParserConfig) +import Swarm.Language.Parser.Lex (reservedWords) +import Swarm.Language.Parser.Util (showErrorPos) +import Swarm.Language.Pipeline (processParsedTerm', processTerm') +import Swarm.Language.Syntax hiding (Key) +import Swarm.Language.Typecheck ( + ContextualTypeErr (..), + ) +import Swarm.Language.Value (Value (VKey), envTypes) +import Swarm.Log +import Swarm.TUI.Controller.EventHandlers +import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Editor.Controller qualified as EC +import Swarm.TUI.Editor.Model +import Swarm.TUI.Launch.Controller +import Swarm.TUI.Launch.Model +import Swarm.TUI.Launch.Prep (prepareLaunchDialog) +import Swarm.TUI.List +import Swarm.TUI.Model +import Swarm.TUI.Model.Goal +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.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 + + 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)) + +-- | The event handler for the main menu. +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers +handleMainMenuEvent :: + BL.List Name MainMenuEntry -> BrickEvent Name AppEvent -> EventM Name AppState () +handleMainMenuEvent menu = \case + 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 + + -- 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 + VtyEvent ev -> do + menu' <- nestEventM' menu (handleListEvent ev) + uiState . uiMenu .= MainMenu menu' + _ -> pure () + +-- | If we are in a New Game menu, advance the menu to the next item in order. +-- +-- NOTE: be careful to maintain the invariant that the currently selected +-- menu item is always the same as the currently played scenario! `quitGame` +-- is the only place this function should be called. +advanceMenu :: Menu -> Menu +advanceMenu = _NewGameMenu . ix 0 %~ BL.listMoveDown + +handleMainAchievementsEvent :: + BL.List Name CategorizedAchievement -> + BrickEvent Name AppEvent -> + EventM Name AppState () +handleMainAchievementsEvent l e = case e of + Key V.KEsc -> returnToMainMenu + CharKey 'q' -> returnToMainMenu + ControlChar 'q' -> returnToMainMenu + VtyEvent ev -> do + l' <- nestEventM' l (handleListEvent ev) + uiState . uiMenu .= AchievementsMenu l' + _ -> pure () + where + returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages) + +handleMainMessagesEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleMainMessagesEvent = \case + Key V.KEsc -> returnToMainMenu + CharKey 'q' -> returnToMainMenu + ControlChar 'q' -> returnToMainMenu + _ -> pure () + where + returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages) + +-- TODO: #2010 Finish porting Controller to KeyEventHandlers +handleNewGameMenuEvent :: + NonEmpty (BL.List Name ScenarioItem) -> + 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) + CharKey 'o' -> showLaunchDialog + CharKey 'O' -> showLaunchDialog + Key V.KEsc -> exitNewGameMenu scenarioStack + CharKey 'q' -> exitNewGameMenu scenarioStack + ControlChar 'q' -> halt + 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 + _ -> pure () + +exitNewGameMenu :: NonEmpty (BL.List Name ScenarioItem) -> EventM Name AppState () +exitNewGameMenu stk = do + uiState + . uiMenu + .= case snd (NE.uncons stk) of + Nothing -> MainMenu (mainMenu NewGame) + Just stk' -> NewGameMenu stk' + +pressAnyKey :: Menu -> BrickEvent Name AppEvent -> EventM Name AppState () +pressAnyKey m (VtyEvent (V.EvKey _ _)) = uiState . uiMenu .= m +pressAnyKey _ _ = pure () + +-- | The top-level event handler while we are running the game itself. +handleMainEvent :: Bool -> BrickEvent Name AppEvent -> EventM Name AppState () +handleMainEvent forceRedraw ev = do + s <- get + 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 + VtyEvent (V.EvResize _ _) -> invalidateCache + EscapeKey | Just m <- s ^. uiState . uiGameplay . uiModal -> closeModal m + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] + VtyEvent (V.EvKey k m) + | isJust (B.lookupVtyEvent k m keyHandler) -> void $ B.handleKey keyHandler k m + -- pass keys on to modal event handler if a modal is open + VtyEvent vev + | isJust (s ^. uiState . uiGameplay . uiModal) -> handleModalEvent vev + MouseDown (TerrainListItem pos) V.BLeft _ _ -> + uiState . uiGameplay . uiWorldEditor . terrainList %= BL.listMoveTo pos + MouseDown (EntityPaintListItem pos) V.BLeft _ _ -> + uiState . uiGameplay . uiWorldEditor . entityPaintList %= BL.listMoveTo pos + MouseDown WorldPositionIndicator _ _ _ -> uiState . uiGameplay . uiWorldCursor .= Nothing + MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc -> + -- Eye Dropper tool + EC.handleMiddleClick mouseLoc + MouseDown (FocusablePanel WorldPanel) V.BRight _ mouseLoc -> + -- Eraser tool + EC.handleRightClick mouseLoc + MouseDown (FocusablePanel WorldPanel) V.BLeft [V.MCtrl] mouseLoc -> + -- Paint with the World Editor + EC.handleCtrlLeftClick mouseLoc + MouseDown n _ _ mouseLoc -> + case n of + FocusablePanel WorldPanel -> do + mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc + shouldUpdateCursor <- EC.updateAreaBounds mouseCoordsM + when shouldUpdateCursor $ + uiState . uiGameplay . uiWorldCursor .= mouseCoordsM + REPLInput -> handleREPLEvent ev + _ -> 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 () + -- dispatch any other events to the focused panel handler + _ev -> do + fring <- use $ uiState . uiGameplay . uiFocusRing + case focusGetCurrent fring of + Just (FocusablePanel x) -> case x of + REPLPanel -> handleREPLEvent ev + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] + WorldPanel | VtyEvent (V.EvKey k m) <- ev -> do + wh <- use $ keyEventHandling . keyDispatchers . to worldDispatcher + void $ B.handleKey wh k m + WorldPanel | otherwise -> continueWithoutRedraw + WorldEditorPanel -> EC.handleWorldEditorPanelEvent ev + RobotPanel -> handleRobotPanelEvent ev + InfoPanel -> handleInfoPanelEvent infoScroll ev + _ -> continueWithoutRedraw + +closeModal :: Modal -> EventM Name AppState () +closeModal m = do + safeAutoUnpause + uiState . uiGameplay . uiModal .= Nothing + -- message modal is not autopaused, so update notifications when leaving it + when ((m ^. modalType) == MessagesModal) $ do + t <- use $ gameState . temporal . ticks + gameState . messageInfo . lastSeenMessageTime .= t + +-- TODO: #2010 Finish porting Controller to KeyEventHandlers +handleModalEvent :: V.Event -> EventM Name AppState () +handleModalEvent = \case + V.EvKey V.KEnter [] -> do + 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 + 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 + _ -> do + focused <- use $ uiState . uiGameplay . uiGoal . focus + case focusGetCurrent focused of + Just (GoalWidgets w) -> case w of + ObjectivesList -> do + lw <- use $ uiState . uiGameplay . uiGoal . listWidget + newList <- refreshGoalList lw + uiState . uiGameplay . 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 + _ -> do + focused <- use $ uiState . uiGameplay . uiStructure . structurePanelFocus + case focusGetCurrent focused of + Just (StructureWidgets w) -> case w of + StructuresList -> + refreshList $ uiState . uiGameplay . uiStructure . structurePanelListWidget + StructureSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev) + _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) + _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) + where + refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection + refreshList z = Brick.zoom z $ BL.handleListEvent ev + +-- | Quit a game. +-- +-- * writes out the updated REPL history to a @.swarm_history@ file +-- * 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 + -- Write out REPL history. + history <- use $ uiState . uiGameplay . uiREPL . replHistory + let hist = mapMaybe getREPLSubmitted $ getLatestREPLHistoryItems maxBound history + liftIO $ (`T.appendFile` T.unlines hist) =<< getSwarmHistoryPath True + + -- Save scenario status info. + saveScenarioInfoOnQuit + + -- Automatically advance the menu to the next scenario iff the + -- player has won the current one. + wc <- use $ gameState . winCondition + case wc of + WinConditions (Won _ _) _ -> uiState . uiMenu %= advanceMenu + _ -> return () + + -- 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 + +------------------------------------------------------------ +-- REPL events +------------------------------------------------------------ + +-- | Handle a user input event for the REPL. +handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleREPLEvent x = do + s <- get + let controlMode = s ^. uiState . uiGameplay . uiREPL . replControlMode + let keyHandler = s ^. keyEventHandling . keyDispatchers . to replDispatcher + case x of + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] + VtyEvent (V.EvKey k m) + | isJust (B.lookupVtyEvent k m keyHandler) -> + void $ B.handleKey keyHandler k m + -- Handle other events in a way appropriate to the current REPL + -- control mode. + _ -> case controlMode of + Typing -> handleREPLEventTyping x + Piloting -> handleREPLEventPiloting x + Handling -> case x of + -- Handle keypresses using the custom installed handler + VtyEvent (V.EvKey k mods) -> runInputHandler (mkKeyCombo mods k) + -- Handle all other events normally + _ -> handleREPLEventTyping x + +-- | Run the installed input handler on a key combo entered by the user. +runInputHandler :: KeyCombo -> EventM Name AppState () +runInputHandler kc = do + mhandler <- use $ gameState . gameControls . inputHandler + case mhandler of + -- 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) + +-- | Handle a user "piloting" input event for the REPL. +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers +handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState () +handleREPLEventPiloting x = case x of + Key V.KUp -> inputCmd "move" + Key V.KDown -> inputCmd "turn back" + Key V.KLeft -> inputCmd "turn left" + Key V.KRight -> inputCmd "turn right" + ShiftKey V.KUp -> inputCmd "turn north" + ShiftKey V.KDown -> inputCmd "turn south" + ShiftKey V.KLeft -> inputCmd "turn west" + ShiftKey V.KRight -> inputCmd "turn east" + Key V.KDel -> inputCmd "selfdestruct" + CharKey 'g' -> inputCmd "grab" + CharKey 'h' -> inputCmd "harvest" + CharKey 'd' -> inputCmd "drill forward" + CharKey 'x' -> inputCmd "drill down" + CharKey 's' -> inputCmd "scan forward" + CharKey 'b' -> inputCmd "blocked" + CharKey 'u' -> inputCmd "upload base" + CharKey 'p' -> inputCmd "push" + _ -> inputCmd "noop" + where + inputCmd cmdText = do + uiState . uiGameplay . uiREPL %= setCmd (cmdText <> ";") + modify validateREPLForm + handleREPLEventTyping $ Key V.KEnter + + setCmd nt theRepl = + theRepl + & replPromptText .~ nt + & replPromptType .~ CmdPrompt [] + +runBaseWebCode :: (MonadState AppState m) => T.Text -> m () +runBaseWebCode uinput = do + s <- get + unless (s ^. gameState . gameControls . replWorking) $ + runBaseCode uinput + +runBaseCode :: (MonadState AppState m) => T.Text -> m () +runBaseCode uinput = do + addREPLHistItem (mkREPLSubmission uinput) + resetREPL "" (CmdPrompt []) + env <- use $ gameState . baseEnv + case processTerm' env uinput of + Right mt -> do + uiState . uiGameplay . uiREPL . replHistory . replHasExecutedManualInput .= True + runBaseTerm mt + Left err -> do + addREPLHistItem (mkREPLError 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 + -- Scroll the REPL on PageUp or PageDown + Key V.KPageUp -> vScrollPage replScroll Brick.Up + Key V.KPageDown -> vScrollPage replScroll Brick.Down + k -> do + -- 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 + s <- get + let theRepl = s ^. uiState . uiGameplay . uiREPL + uinput = theRepl ^. replPromptText + + if not $ s ^. gameState . gameControls . replWorking + then case theRepl ^. replPromptType of + CmdPrompt _ -> do + runBaseCode uinput + invalidateCacheEntry REPLHistoryCache + SearchPrompt hist -> + case lastEntry uinput hist of + Nothing -> resetREPL "" (CmdPrompt []) + Just found + | T.null uinput -> resetREPL "" (CmdPrompt []) + | otherwise -> do + resetREPL found (CmdPrompt []) + modify validateREPLForm + else continueWithoutRedraw + Key V.KUp -> modify $ adjReplHistIndex Older + Key V.KDown -> do + repl <- use $ uiState . uiGameplay . uiREPL + let hist = repl ^. replHistory + uinput = repl ^. replPromptText + case repl ^. replPromptType of + CmdPrompt {} + | hist ^. replIndex == replLength hist && not (T.null uinput) -> + -- 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) + 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 + 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) + modify validateREPLForm + EscapeKey -> do + formSt <- use $ uiState . uiGameplay . uiREPL . replPromptType + case formSt of + CmdPrompt {} -> continueWithoutRedraw + SearchPrompt _ -> resetREPL "" (CmdPrompt []) + ControlChar 'd' -> do + text <- use $ uiState . uiGameplay . uiREPL . replPromptText + if text == T.empty + then toggleModal QuitModal + else continueWithoutRedraw + MetaKey V.KBS -> + uiState . 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 + _ -> handleEditorEvent ev + uiState . uiGameplay . uiREPL . replPromptType %= \case + CmdPrompt _ -> CmdPrompt [] -- reset completions on any event passed to editor + SearchPrompt a -> SearchPrompt a + modify validateREPLForm + +insertMatchingPair :: Char -> EventM Name (Editor Text Name) () +insertMatchingPair c = modify . applyEdit $ TZ.insertChar c >>> TZ.insertChar (close c) >>> TZ.moveLeft + where + close = \case + '(' -> ')' + '[' -> ']' + '{' -> '}' + _ -> c + +data CompletionType + = FunctionName + | EntityName + deriving (Eq) + +newtype CompletionContext = CompletionContext {ctxCreativeMode :: Bool} + deriving (Eq) + +-- | Reserved words corresponding to commands that can only be used in +-- creative mode. We only autocomplete to these when in creative mode. +creativeWords :: Set Text +creativeWords = + S.fromList + . map (syntax . constInfo) + . filter (\w -> constCaps w == Just CGod) + $ allConst + +-- | 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 {..} names em theRepl = case theRepl ^. replPromptType of + SearchPrompt _ -> theRepl + CmdPrompt mms + -- Case 1: If completion candidates have already been + -- populated via case (3), cycle through them. + -- Note that tabbing through the candidates *does* update the value + -- of "t", which one might think would narrow the candidate list + -- to only that match and therefore halt the cycling. + -- However, the candidate list only gets recomputed (repopulated) + -- if the user subsequently presses a non-Tab key. Thus the current + -- value of "t" is ignored for all Tab presses subsequent to the + -- first. + | (m : ms) <- mms -> setCmd (replacementFunc m) (ms ++ [m]) + -- Case 2: Require at least one letter to be typed in order to offer completions for + -- function names. + -- We allow suggestions for Entity Name strings without anything having been typed. + | T.null lastWord && completionType == FunctionName -> setCmd t [] + -- Case 3: Typing another character in the REPL clears the completion candidates from + -- the CmdPrompt, so when Tab is pressed again, this case then gets executed and + -- repopulates them. + | otherwise -> case candidateMatches of + [] -> setCmd t [] + [m] -> setCmd (completeWith m) [] + -- Perform completion with the first candidate, then populate the list + -- of all candidates with the current completion moved to the back + -- of the queue. + (m : ms) -> setCmd (completeWith m) (ms ++ [m]) + where + -- checks the "parity" of the number of quotes. If odd, then there is an open quote. + hasOpenQuotes = (== 1) . (`mod` 2) . T.count "\"" + + completionType = + if hasOpenQuotes t + then EntityName + else FunctionName + + replacementFunc = T.append $ T.dropWhileEnd replacementBoundaryPredicate t + completeWith m = T.append t $ T.drop (T.length lastWord) m + lastWord = T.takeWhileEnd replacementBoundaryPredicate t + candidateMatches = filter (lastWord `T.isPrefixOf`) replacementCandidates + + (replacementCandidates, replacementBoundaryPredicate) = case completionType of + EntityName -> (entityNames, (/= '"')) + FunctionName -> (possibleWords, isIdentChar) + + possibleWords = + names <> case ctxCreativeMode of + True -> S.toList reservedWords + False -> S.toList $ reservedWords `S.difference` creativeWords + + entityNames = M.keys $ entitiesByName em + + t = theRepl ^. replPromptText + setCmd nt ms = + theRepl + & replPromptText .~ nt + & replPromptType .~ CmdPrompt ms + +-- | Validate the REPL input when it changes: see if it parses and +-- typechecks, and set the color accordingly. +validateREPLForm :: AppState -> AppState +validateREPLForm s = + case replPrompt of + CmdPrompt _ + | T.null uinput -> + let theType = s ^. gameState . gameControls . replStatus . replActiveType + in s & uiState . uiGameplay . uiREPL . replType .~ theType + CmdPrompt _ + | otherwise -> + let env = s ^. gameState . baseEnv + (theType, errSrcLoc) = case readTerm' defaultParserConfig uinput of + Left err -> + let ((_y1, x1), (_y2, x2), _msg) = showErrorPos err + in (Nothing, Left (SrcLoc x1 x2)) + Right Nothing -> (Nothing, Right ()) + Right (Just theTerm) -> case processParsedTerm' env theTerm of + Right t -> (Just (t ^. sType), Right ()) + Left err -> (Nothing, Left (cteSrcLoc err)) + in s + & uiState . uiGameplay . uiREPL . replValid .~ errSrcLoc + & uiState . uiGameplay . uiREPL . replType .~ theType + SearchPrompt _ -> s + where + uinput = s ^. uiState . uiGameplay . uiREPL . replPromptText + replPrompt = s ^. uiState . uiGameplay . uiREPL . replPromptType + +-- | Update our current position in the REPL history. +adjReplHistIndex :: TimeDir -> AppState -> AppState +adjReplHistIndex d s = + s + & uiState . 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) + where + -- new AppState after moving the repl index + newREPL :: REPLState + newREPL = theRepl & replHistory %~ moveReplHistIndex d oldEntry + + saveLastEntry = replLast .~ (theRepl ^. replPromptText) + showNewEntry = (replPromptEditor .~ newREPLEditor newEntry) . (replPromptType .~ CmdPrompt []) + -- get REPL data + getCurrEntry = fromMaybe (theRepl ^. replLast) . getCurrentItemText . view replHistory + oldEntry = getCurrEntry theRepl + newEntry = getCurrEntry newREPL + +------------------------------------------------------------ +-- Info panel events +------------------------------------------------------------ + +-- | Handle user events in the info panel (just scrolling). +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers +handleInfoPanelEvent :: ViewportScroll Name -> BrickEvent Name AppEvent -> EventM Name AppState () +handleInfoPanelEvent vs = \case + Key V.KDown -> vScrollBy vs 1 + Key V.KUp -> vScrollBy vs (-1) + CharKey 'k' -> vScrollBy vs 1 + CharKey 'j' -> vScrollBy vs (-1) + Key V.KPageDown -> vScrollPage vs Brick.Down + Key V.KPageUp -> vScrollPage vs Brick.Up + Key V.KHome -> vScrollToBeginning vs + Key V.KEnd -> vScrollToEnd vs + _ -> return () diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Swarm (abstract) event handlers allow players to customize some keybindings. +-- This all comes together in 'Swarm.TUI.Controller' which calls the handlers +-- for parts of UI and also handles mouse events and frame updates. +module Swarm.TUI.Controller.EventHandlers ( + -- * Documentation + createKeyDispatchers, + allEventHandlers, + + -- ** Main game handler + mainEventHandlers, + + -- ** REPL panel handler + replEventHandlers, + + -- ** World panel handler + worldEventHandlers, + + -- ** Robot panel handler + robotEventHandlers, + handleRobotPanelEvent, + + -- ** Frame + runFrameUI, + runGameTickUI, + ticksPerFrameCap, +) where + +import Brick hiding (on) +import Brick.Keybindings as BK +import Control.Effect.Accum +import Control.Effect.Throw +import Data.List (sortOn) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Swarm.Game.Failure (SystemFailure (..)) +import Swarm.TUI.Controller.EventHandlers.Frame (runFrameUI, runGameTickUI, ticksPerFrameCap) +import Swarm.TUI.Controller.EventHandlers.Main (mainEventHandlers) +import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers) +import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, robotEventHandlers) +import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents) +import Swarm.Util (parens, squote) + +-- ~~~~ Note [how Swarm event handlers work] +-- +-- Allowing players to customize keybindings requires storing the configuration in AppState. +-- By doing it as declaratively as possible, Brick also allows us to detect conflicts. +-- +-- The high level overview is this: +-- 1. The 'SwarmEvent' is a enumeration of abstracts key events ('PauseEvent', etc.) +-- 2. The 'AppState' definition contains the key configuration and dispatchers (keys to handlers) +-- 3. Here in 'Swarm.TUI.Controller.EventHandlers' we declare the handlers for abstract events +-- and also some non-customizable key handlers (e.g. escape and enter). +-- 4. When provided with 'KeyConfig' (can include customized keybindings) we can +-- 'createKeyDispatchers' in 'Swarm.TUI.Model.StateUpdate' and store them in 'AppState'. +-- 5. Finally in 'Swarm.TUI.Controller' the Brick event handler calls the stored dispatchers. + +-- | Create key dispatchers that call (abstract) event handlers based on given key config. +-- +-- Fails if any key events have conflict within one dispatcher or when a main dispatcher +-- has conflict with one of the subdispatchers. +createKeyDispatchers :: + (Has (Throw SystemFailure) sig m) => + KeyConfig SwarmEvent -> + m SwarmKeyDispatchers +createKeyDispatchers config = do + mainGameDispatcher <- buildDispatcher mainEventHandlers + let buildSubMainDispatcher = buildSubDispatcher "Main game events" mainGameDispatcher + replDispatcher <- buildSubMainDispatcher "REPL panel events" replEventHandlers + worldDispatcher <- buildSubMainDispatcher "World view panel events" worldEventHandlers + robotDispatcher <- buildSubMainDispatcher "Robot inventory panel events" robotEventHandlers + return SwarmKeyDispatchers {..} + where + -- this error handling code is modified version of the brick demo app: + -- https://github.com/jtdaugherty/brick/blob/764e66897/programs/CustomKeybindingDemo.hs#L216 + buildDispatcher handlers = case keyDispatcher config handlers of + Left collisions -> + throwLoadingFailure $ + "Error: some key events have the same keys bound to them.\n" + : handlerErrors collisions + Right d -> return d + buildSubDispatcher parentName parentDispatcher name handlers = do + d <- buildDispatcher handlers + let collisions = conflicts parentDispatcher d + if null collisions + then return d + else + throwLoadingFailure $ + ("Error: some key events have keys bound to them in '" <> parentName <> "' and in '" <> name <> "'") + : handlerErrors collisions + + throwLoadingFailure = throwError . CustomFailure . T.intercalate "\n" + handlerErrors collisions = flip map collisions $ \(b, hs) -> + let hsm = "Handlers with the " <> squote (BK.ppBinding b) <> " binding:" + hss = flip map hs $ \h -> + let trigger = case BK.kehEventTrigger $ BK.khHandler h of + ByKey k -> "triggered by the key " <> squote (BK.ppBinding k) + ByEvent e -> "triggered by the event " <> maybe "" squote (BK.keyEventName swarmEvents e) + desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h + in " " <> desc <> " " <> parens trigger + in T.intercalate "\n" (hsm : hss) + +-- | Take two dispatchers (that do not have conflict themselves) and find conflicting keys between them. +conflicts :: SwarmKeyDispatcher -> SwarmKeyDispatcher -> [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])] +conflicts d1 d2 = combine <$> badGroups + where + l1 = keyDispatcherToList d1 + l2 = keyDispatcherToList d2 + gs = NE.groupWith fst $ sortOn fst (l1 <> l2) + badGroups = filter ((1 <) . length) gs + combine :: NE.NonEmpty (Binding, KeyHandler k m) -> (Binding, [KeyHandler k m]) + combine as = + let b = fst $ NE.head as + in (b, snd <$> NE.toList as) + +allEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +allEventHandlers = + concat + [ mainEventHandlers + , replEventHandlers + , worldEventHandlers + , robotEventHandlers + ] diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs @@ -0,0 +1,160 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Handling 'Swarm.TUI.Model.Frame' events. +module Swarm.TUI.Controller.EventHandlers.Frame ( + runFrameUI, + runGameTickUI, + + -- ** Constants + ticksPerFrameCap, +) where + +import Brick +import Control.Lens as Lens +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Bits +import Data.Map qualified as M +import Swarm.Game.Achievement.Attainment (achievement) +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Achievement.Persistence +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.Game.Step (gameTick) +import Swarm.TUI.Controller.UpdateUI +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Achievements (popupAchievement) +import Swarm.TUI.Model.UI +import System.Clock + +ticksPerFrameCap :: Int +ticksPerFrameCap = 30 + +-- | Run the game for a single /frame/ (/i.e./ screen redraw), then +-- update the UI. Depending on how long it is taking to draw each +-- frame, and how many ticks per second we are trying to achieve, +-- this may involve stepping the game any number of ticks (including +-- zero). +runFrameUI :: Bool -> EventM Name AppState () +runFrameUI forceRedraw = do + runFrame + redraw <- updateUI + unless (forceRedraw || redraw) continueWithoutRedraw + +-- | Run the game for a single frame, without updating the UI. +runFrame :: EventM Name AppState () +runFrame = do + -- Reset the needsRedraw flag. While processing the frame and stepping the robots, + -- the flag will get set to true if anything changes that requires redrawing the + -- world (e.g. a robot moving or disappearing). + gameState . needsRedraw .= False + + -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ . + + -- Find out how long the previous frame took, by subtracting the + -- previous time from the current time. + prevTime <- use (uiState . uiGameplay . uiTiming . lastFrameTime) + curTime <- liftIO $ getTime Monotonic + let frameTime = diffTimeSpec curTime prevTime + + -- Remember now as the new previous time. + uiState . uiGameplay . uiTiming . lastFrameTime .= curTime + + -- We now have some additional accumulated time to play with. The + -- idea is to now "catch up" by doing as many ticks as are supposed + -- to fit in the accumulated time. Some accumulated time may be + -- left over, but it will roll over to the next frame. This way we + -- deal smoothly with things like a variable frame rate, the frame + -- rate not being a nice multiple of the desired ticks per second, + -- etc. + uiState . uiGameplay . uiTiming . accumulatedTime += frameTime + + -- Figure out how many ticks per second we're supposed to do, + -- and compute the timestep `dt` for a single tick. + lgTPS <- use (uiState . uiGameplay . uiTiming . lgTicksPerSecond) + let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds + dt + | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS) + | otherwise = oneSecond * (1 `shiftL` abs lgTPS) + + -- Update TPS/FPS counters every second + infoUpdateTime <- use (uiState . uiGameplay . uiTiming . lastInfoTime) + let updateTime = toNanoSecs $ diffTimeSpec curTime infoUpdateTime + when (updateTime >= oneSecond) $ do + -- Wait for at least one second to have elapsed + when (infoUpdateTime /= 0) $ do + -- set how much frame got processed per second + frames <- use (uiState . uiGameplay . uiTiming . frameCount) + uiState . uiGameplay . uiTiming . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime + + -- set how much ticks got processed per frame + uiTicks <- use (uiState . uiGameplay . uiTiming . tickCount) + uiState . uiGameplay . uiTiming . uiTPF .= fromIntegral uiTicks / fromIntegral frames + + -- ensure this frame gets drawn + gameState . needsRedraw .= True + + -- Reset the counter and wait another seconds for the next update + uiState . uiGameplay . uiTiming . tickCount .= 0 + uiState . uiGameplay . uiTiming . frameCount .= 0 + uiState . uiGameplay . uiTiming . lastInfoTime .= curTime + + -- Increment the frame count + uiState . uiGameplay . uiTiming . frameCount += 1 + + -- Now do as many ticks as we need to catch up. + uiState . uiGameplay . uiTiming . frameTickCount .= 0 + runFrameTicks (fromNanoSecs dt) + +-- | Do zero or more ticks, with each tick notionally taking the given +-- timestep, until we have used up all available accumulated time, +-- OR until we have hit the cap on ticks per frame, whichever comes +-- first. +runFrameTicks :: TimeSpec -> EventM Name AppState () +runFrameTicks dt = do + a <- use (uiState . uiGameplay . uiTiming . accumulatedTime) + t <- use (uiState . uiGameplay . uiTiming . frameTickCount) + + -- Ensure there is still enough time left, and we haven't hit the + -- tick limit for this frame. + when (a >= dt && t < ticksPerFrameCap) $ do + -- If so, do a tick, count it, subtract dt from the accumulated time, + -- and loop! + runGameTick + Brick.zoom (uiState . uiGameplay . uiTiming) $ do + tickCount += 1 + frameTickCount += 1 + accumulatedTime -= dt + runFrameTicks dt + +-- | Run the game for a single tick, and update the UI. +runGameTickUI :: EventM Name AppState () +runGameTickUI = runGameTick >> void updateUI + +updateAchievements :: EventM Name AppState () +updateAchievements = do + -- Merge the in-game achievements with the master list in UIState + achievementsFromGame <- use $ gameState . discovery . gameAchievements + let wrappedGameAchievements = M.mapKeys GameplayAchievement achievementsFromGame + + oldMasterAchievementsList <- use $ uiState . uiAchievements + uiState . uiAchievements %= M.unionWith (<>) wrappedGameAchievements + + -- Don't save to disk unless there was a change in the attainment list. + let incrementalAchievements = wrappedGameAchievements `M.difference` oldMasterAchievementsList + unless (null incrementalAchievements) $ do + mapM_ (popupAchievement . view achievement) incrementalAchievements + + newAchievements <- use $ uiState . uiAchievements + liftIO $ saveAchievementsInfo $ M.elems newAchievements + +-- | Run the game for a single tick (/without/ updating the UI). +-- Every robot is given a certain amount of maximum computation to +-- perform a single world action (like moving, turning, grabbing, +-- etc.). +runGameTick :: EventM Name AppState () +runGameTick = do + ticked <- zoomGameState gameTick + when ticked updateAchievements diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Here is the main player configurable key event handler while playing the game. +module Swarm.TUI.Controller.EventHandlers.Main ( + mainEventHandlers, +) where + +import Brick +import Brick.Keybindings +import Control.Lens as Lens +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (liftIO) +import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.Game.Step (finishGameTick) +import Swarm.TUI.Controller.EventHandlers.Frame (runGameTickUI) +import Swarm.TUI.Controller.UpdateUI (updateUI) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Editor.Model (isWorldEditorEnabled, worldOverdraw) +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (MainEvent (..), SwarmEvent (..)) +import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.UI +import System.Clock (Clock (..), TimeSpec (..), getTime) + +-- | Main keybindings event handler while running the game itself. +-- +-- See 'Swarm.TUI.Controller.handleMainEvent'. +mainEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +mainEventHandlers = allHandlers Main $ \case + QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) + ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) + ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) + ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) + ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) + ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) + ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) + ViewGoalEvent -> ("View scenario goal description", viewGoal) + HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) + ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) + PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) + RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) + IncreaseTpsEvent -> ("Double game speed", whenRunning . modify $ adjustTPS (+)) + DecreaseTpsEvent -> ("Halve game speed", whenRunning . modify $ adjustTPS (-)) + FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) + FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) + FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) + FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) + ToggleCreativeModeEvent -> ("Toggle creative mode", whenCheating toggleCreativeMode) + ToggleWorldEditorEvent -> ("Toggle world editor mode", whenCheating toggleWorldEditor) + ToggleREPLVisibilityEvent -> ("Collapse/Expand REPL panel", toggleREPLVisibility) + +toggleQuitGameDialog :: EventM Name AppState () +toggleQuitGameDialog = do + s <- get + case s ^. gameState . winCondition of + WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal + WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal + _ -> toggleModal QuitModal + +toggleGameModal :: Foldable t => ModalType -> Getter GameState (t a) -> EventM Name AppState Bool +toggleGameModal m l = do + s <- get + let nothingToShow = null $ s ^. gameState . l + unless nothingToShow $ toggleModal m + return nothingToShow + +toggleDiscoveryModal :: Foldable t => ModalType -> Lens' Discovery (t a) -> EventM Name AppState () +toggleDiscoveryModal m l = void $ toggleGameModal m (discovery . l) + +toggleDiscoveryNotificationModal :: ModalType -> Lens' Discovery (Notifications a) -> EventM Name AppState () +toggleDiscoveryNotificationModal m l = do + nothingToShow <- toggleGameModal m (discovery . l . notificationsContent) + unless nothingToShow $ gameState . discovery . l . notificationsCount .= 0 + +toggleMessagesModal :: EventM Name AppState () +toggleMessagesModal = do + s <- get + nothingToShow <- toggleGameModal MessagesModal (messageNotifications . notificationsContent) + unless nothingToShow $ gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks + +viewGoal :: EventM Name AppState () +viewGoal = do + s <- get + if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent + then toggleModal GoalModal + else continueWithoutRedraw + +hideRobots :: EventM Name AppState () +hideRobots = do + t <- liftIO $ getTime Monotonic + h <- use $ uiState . uiGameplay . uiHideRobotsUntil + case h >= t of + -- ignore repeated keypresses + True -> continueWithoutRedraw + -- hide for two seconds + False -> do + uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 + invalidateCacheEntry WorldCache + +showCESKDebug :: EventM Name AppState () +showCESKDebug = do + s <- get + let isPaused = s ^. gameState . temporal . paused + let isCreative = s ^. gameState . creativeMode + let hasDebug = hasDebugCapability isCreative s + when (isPaused && hasDebug) $ do + debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not + if debug + then gameState . temporal . gameStep .= RobotStep SBefore + else zoomGameState finishGameTick >> void updateUI + +runSingleTick :: EventM Name AppState () +runSingleTick = do + gameState . temporal . runStatus .= ManualPause + runGameTickUI + +-- | Adjust the ticks per second speed. +adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState +adjustTPS (+/-) = uiState . uiGameplay . uiTiming . lgTicksPerSecond %~ (+/- 1) + +toggleCreativeMode :: EventM Name AppState () +toggleCreativeMode = gameState . creativeMode %= not + +toggleWorldEditor :: EventM Name AppState () +toggleWorldEditor = do + uiState . uiGameplay . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not + setFocus WorldEditorPanel + +toggleREPLVisibility :: EventM Name AppState () +toggleREPLVisibility = do + invalidateCacheEntry WorldCache + uiState . uiGameplay . uiShowREPL %= not + +-- ---------------------------------------------- +-- HELPER UTILS +-- ---------------------------------------------- + +isRunning :: EventM Name AppState Bool +isRunning = do + mt <- preuse $ uiState . uiGameplay . uiModal . _Just . modalType + return $ maybe True isRunningModal mt + +whenRunning :: EventM Name AppState () -> EventM Name AppState () +whenRunning a = isRunning >>= \r -> when r a + +whenCheating :: EventM Name AppState () -> EventM Name AppState () +whenCheating a = do + s <- get + when (s ^. uiState . uiCheatMode) a diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Here is the REPL player configurable key event handler. +module Swarm.TUI.Controller.EventHandlers.REPL ( + replEventHandlers, +) where + +import Brick +import Brick.Keybindings qualified as B +import Control.Lens as Lens +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.Text qualified as T +import Swarm.Game.CESK (cancel) +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Event +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI + +-- | Handle a user input key event for the REPL. +-- +-- See 'Swarm.TUI.Controller.handleREPLEvent'. +replEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] +replEventHandlers = allHandlers REPL $ \case + CancelRunningProgramEvent -> ("Cancel running base robot program", cancelRunningBase) + TogglePilotingModeEvent -> ("Toggle piloting mode", onlyCreative togglePilotingMode) + ToggleCustomKeyHandlingEvent -> ("Toggle custom key handling mode", toggleCustomKeyHandling) + +-- | Cancel the running base CESK machine and clear REPL input text. +-- +-- It is handled in top REPL handler so we can always cancel the currently running +-- base program no matter what REPL control mode we are in. +cancelRunningBase :: EventM Name AppState () +cancelRunningBase = do + working <- use $ gameState . gameControls . replWorking + when working $ gameState . baseRobot . machine %= cancel + Brick.zoom (uiState . uiGameplay . uiREPL) $ do + replPromptType .= CmdPrompt [] + replPromptText .= "" + +togglePilotingMode :: EventM Name AppState () +togglePilotingMode = do + s <- get + let theRepl = s ^. uiState . uiGameplay . uiREPL + uinput = theRepl ^. replPromptText + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + case curMode of + Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing + _ -> + if T.null uinput + then uiState . uiGameplay . uiREPL . replControlMode .= Piloting + else do + addREPLHistItem $ mkREPLError "Please clear the REPL before engaging pilot mode." + invalidateCacheEntry REPLHistoryCache + +toggleCustomKeyHandling :: EventM Name AppState () +toggleCustomKeyHandling = do + s <- get + when (isJust (s ^. gameState . gameControls . inputHandler)) $ do + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Here is the RobotPanel key event handler. +-- +-- Because of how tricky the search logic is, +-- the player configurable part and the dynamic +-- search handler are both here. +module Swarm.TUI.Controller.EventHandlers.Robot ( + robotEventHandlers, + handleRobotPanelEvent, +) where + +import Brick +import Brick.Keybindings +import Control.Lens as Lens +import Control.Lens.Extras as Lens (is) +import Control.Monad (unless, when) +import Data.Text qualified as T +import Graphics.Vty qualified as V +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Language.Pipeline.QQ (tmQ) +import Swarm.Language.Syntax hiding (Key) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) +import Swarm.TUI.List +import Swarm.TUI.Model +import Swarm.TUI.Model.Event +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Util (generateModal) + +-- | Handle user input events in the robot panel. +handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleRobotPanelEvent bev = do + search <- use $ uiState . uiGameplay . uiInventory . uiInventorySearch + keyHandler <- use $ keyEventHandling . keyDispatchers . to robotDispatcher + case search of + Just _ -> handleInventorySearchEvent bev + Nothing -> case bev of + VtyEvent ev@(V.EvKey k m) -> do + handled <- handleKey keyHandler k m + unless handled $ handleInventoryListEvent ev + _ -> continueWithoutRedraw + +-- | Handle key events in the robot panel. +robotEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +robotEventHandlers = nonCustomizableHandlers <> customizableHandlers + where + nonCustomizableHandlers = + [ onKey V.KEnter "Show entity description" showEntityDescription + ] + customizableHandlers = allHandlers Robot $ \case + MakeEntityEvent -> ("Make the selected entity", makeFocusedEntity) + ShowZeroInventoryEntitiesEvent -> ("Show entities with zero count in inventory", zoomInventory showZero) + CycleInventorySortEvent -> ("Cycle inventory sorting type", zoomInventory cycleSort) + SwitchInventorySortDirection -> ("Switch ascending/descending inventory sort", zoomInventory switchSortDirection) + SearchInventoryEvent -> ("Start inventory search", zoomInventory searchInventory) + +-- | Display a modal window with the description of an entity. +showEntityDescription :: EventM Name AppState () +showEntityDescription = gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal + where + descriptionModal :: Entity -> EventM Name AppState () + descriptionModal e = do + s <- get + resetViewport modalScroll + uiState . uiGameplay . uiModal ?= generateModal s (DescriptionModal e) + +-- | Attempt to make an entity selected from the inventory, if the +-- base is not currently busy. +makeFocusedEntity :: EventM Name AppState () +makeFocusedEntity = gets focusedEntity >>= maybe continueWithoutRedraw makeEntity + where + makeEntity :: Entity -> EventM Name AppState () + makeEntity e = do + s <- get + let name = e ^. entityName + mkT = [tmQ| make $str:name |] + case isActive <$> (s ^? gameState . baseRobot) of + Just False -> runBaseTerm (Just mkT) + _ -> continueWithoutRedraw + +showZero :: EventM Name UIInventory () +showZero = uiShowZero %= not + +cycleSort :: EventM Name UIInventory () +cycleSort = uiInventorySort %= cycleSortOrder + +switchSortDirection :: EventM Name UIInventory () +switchSortDirection = uiInventorySort %= cycleSortDirection + +searchInventory :: EventM Name UIInventory () +searchInventory = uiInventorySearch .= Just "" + +-- | Handle an event to navigate through the inventory list. +handleInventoryListEvent :: V.Event -> EventM Name AppState () +handleInventoryListEvent ev = do + -- Note, refactoring like this is tempting: + -- + -- Brick.zoom (uiState . ... . _Just . _2) (handleListEventWithSeparators ev (is _Separator)) + -- + -- However, this does not work since we want to skip redrawing in the no-list case! + mList <- preuse $ uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 + case mList of + Nothing -> continueWithoutRedraw + Just l -> do + when (isValidListMovement ev) $ resetViewport infoScroll + l' <- nestEventM' l (handleListEventWithSeparators ev (is _Separator)) + uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 .= l' + +-- ---------------------------------------------- +-- INVENTORY SEARCH +-- ---------------------------------------------- + +-- | Handle a user input event in the robot/inventory panel, while in +-- inventory search mode. +handleInventorySearchEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleInventorySearchEvent = \case + -- Escape: stop filtering and go back to regular inventory mode + EscapeKey -> + zoomInventory $ uiInventorySearch .= Nothing + -- Enter: return to regular inventory mode, and pop out the selected item + Key V.KEnter -> do + zoomInventory $ uiInventorySearch .= Nothing + showEntityDescription + -- Any old character: append to the current search string + CharKey c -> do + resetViewport infoScroll + zoomInventory $ uiInventorySearch %= fmap (`snoc` c) + -- Backspace: chop the last character off the end of the current search string + BackspaceKey -> do + zoomInventory $ uiInventorySearch %= fmap (T.dropEnd 1) + -- Handle any other event as list navigation, so we can look through + -- the filtered inventory using e.g. arrow keys + VtyEvent ev -> handleInventoryListEvent ev + _ -> continueWithoutRedraw + +-- ---------------------------------------------- +-- HELPER UTILS +-- ---------------------------------------------- + +zoomInventory :: EventM Name UIInventory () -> EventM Name AppState () +zoomInventory act = Brick.zoom (uiState . uiGameplay . uiInventory) $ do + uiInventoryShouldUpdate .= True + act diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Here is the WorldPanel player configurable key event handler. +module Swarm.TUI.Controller.EventHandlers.World ( + worldEventHandlers, +) where + +import Brick hiding (Location) +import Brick.Keybindings +import Control.Lens +import Control.Monad (when) +import Data.Int (Int32) +import Linear +import Swarm.Game.Location +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Language.Syntax.Direction (Direction (..), directionSyntax) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Event +import Swarm.TUI.Model.UI + +-- | Handle a user input event in the world view panel. +worldEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +worldEventHandlers = allHandlers World $ \case + ViewBaseEvent -> ("View the base robot", viewBase) + ShowFpsEvent -> ("Show frames per second", showFps) + MoveViewEvent d -> ("Scroll world view in the " <> directionSyntax (DAbsolute d) <> " direction", scrollViewInDir $ toHeading d) + +viewBase :: EventM Name AppState () +viewBase = do + invalidateCacheEntry WorldCache + gameState . robotInfo . viewCenterRule .= VCRobot 0 + +showFps :: EventM Name AppState () +showFps = uiState . uiGameplay . uiTiming . uiShowFPS %= not + +scrollViewInDir :: V2 Int32 -> EventM Name AppState () +scrollViewInDir d = do + c <- use $ gameState . creativeMode + s <- use $ gameState . landscape . worldScrollable + when (c || s) $ scrollView (.+^ (worldScrollDist *^ d)) + +worldScrollDist :: Int32 +worldScrollDist = 8 + +-- | Manually scroll the world view. +scrollView :: (Location -> Location) -> EventM Name AppState () +scrollView update = do + -- Manually invalidate the 'WorldCache' instead of just setting + -- 'needsRedraw'. I don't quite understand why the latter doesn't + -- always work, but there seems to be some sort of race condition + -- where 'needsRedraw' gets reset before the UI drawing code runs. + invalidateCacheEntry WorldCache + gameState . robotInfo %= modifyViewCenter (fmap update) diff --git a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs @@ -0,0 +1,118 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Collection of functions used to save the scenario metadata. +module Swarm.TUI.Controller.SaveScenario ( + saveScenarioInfoOnFinish, + saveScenarioInfoOnFinishNocheat, + saveScenarioInfoOnQuit, +) where + +-- See Note [liftA2 re-export from Prelude] +import Brick.Widgets.List qualified as BL +import Control.Lens as Lens +import Control.Monad (forM_, unless, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState) +import Data.Maybe (fromMaybe) +import Data.Time (getZonedTime) +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Scenario.Status (updateScenarioInfoOnFinish) +import Swarm.Game.ScenarioInfo +import Swarm.Game.State +import Swarm.Game.State.Runtime +import Swarm.Game.State.Substate +import Swarm.TUI.Model +import Swarm.TUI.Model.Achievements (attainAchievement') +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI +import System.FilePath (splitDirectories) +import Prelude hiding (Applicative (..)) + +getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) +getNormalizedCurrentScenarioPath = + -- the path should be normalized and good to search in scenario collection + use (gameState . currentScenarioPath) >>= \case + Nothing -> return Nothing + Just p' -> do + gs <- use $ runtimeState . scenarios + Just <$> liftIO (normalizeScenarioPath gs p') + +saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo) +saveScenarioInfoOnFinish p = do + initialRunCode <- use $ gameState . gameControls . initiallyRunCode + t <- liftIO getZonedTime + wc <- use $ gameState . winCondition + let won = case wc of + WinConditions (Won _ _) _ -> True + _ -> False + ts <- use $ gameState . temporal . ticks + + -- NOTE: This traversal is apparently not the same one as used by + -- the scenario selection menu, so the menu needs to be updated separately. + -- See Note [scenario menu update] + let currentScenarioInfo :: Traversal' AppState ScenarioInfo + currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2 + + replHist <- use $ uiState . uiGameplay . uiREPL . replHistory + let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput + currentScenarioInfo + %= updateScenarioInfoOnFinish determinator t ts won + status <- preuse currentScenarioInfo + case status of + Nothing -> return () + Just si -> do + let segments = splitDirectories p + case segments of + firstDir : _ -> do + when (won && firstDir == tutorialsDirname) $ + attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial) + _ -> return () + liftIO $ saveScenarioInfo p si + return status + +-- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit). +saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m () +saveScenarioInfoOnFinishNocheat = do + -- Don't save progress if we are in cheat mode + cheat <- use $ uiState . uiCheatMode + unless cheat $ do + -- the path should be normalized and good to search in scenario collection + getNormalizedCurrentScenarioPath >>= \case + Nothing -> return () + Just p -> void $ saveScenarioInfoOnFinish p + +-- | Write the @ScenarioInfo@ out to disk when exiting a game. +saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () +saveScenarioInfoOnQuit = do + -- Don't save progress if we are in cheat mode + -- NOTE This check is duplicated in "saveScenarioInfoOnFinishNocheat" + cheat <- use $ uiState . uiCheatMode + unless cheat $ do + getNormalizedCurrentScenarioPath >>= \case + Nothing -> return () + Just p -> do + maybeSi <- saveScenarioInfoOnFinish p + -- Note [scenario menu update] + -- Ensures that the scenario selection menu gets updated + -- with the high score/completion status + forM_ + maybeSi + ( uiState + . uiMenu + . _NewGameMenu + . ix 0 + . BL.listSelectedElementL + . _SISingle + . _2 + .= + ) + + -- See what scenario is currently focused in the menu. Depending on how the + -- previous scenario ended (via quit vs. via win), it might be the same as + -- currentScenarioPath or it might be different. + curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath + -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, + -- being sure to preserve the same focused scenario. + sc <- use $ runtimeState . scenarios + forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=) diff --git a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- The main TUI update logic that is called from other controller parts. +module Swarm.TUI.Controller.UpdateUI ( + updateUI, +) where + +import Brick hiding (Direction, Location) +import Brick.Focus + +-- See Note [liftA2 re-export from Prelude] +import Brick.Widgets.List qualified as BL +import Control.Applicative (liftA2, pure) +import Control.Lens as Lens +import Control.Monad (unless, when) +import Data.Foldable (toList) +import Data.List.Extra (enumerate) +import Data.Maybe (isNothing) +import Data.String (fromString) +import Data.Text qualified as T +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Robot +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Substate +import Swarm.Language.Pretty +import Swarm.Language.Typed (Typed (..)) +import Swarm.Language.Types +import Swarm.Language.Value (Value (VExc, VUnit), envTydefs, prettyValue) +import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnFinishNocheat) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.Popup (Popup (..), addPopup) +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Objective qualified as GR +import Witch (into) +import Prelude hiding (Applicative (..)) + +-- | Update the UI. This function is used after running the +-- game for some number of ticks. +updateUI :: EventM Name AppState Bool +updateUI = do + loadVisibleRegion + + -- If the game state indicates a redraw is needed, invalidate the + -- world cache so it will be redrawn. + g <- use gameState + when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache + + -- The hash of the robot whose inventory is currently displayed (if any) + listRobotHash <- fmap fst <$> use (uiState . uiGameplay . uiInventory . uiInventoryList) + + -- The hash of the focused robot (if any) + fr <- use (gameState . to focusedRobot) + let focusedRobotHash = view inventoryHash <$> fr + + -- Check if the inventory list needs to be updated. + shouldUpdate <- use (uiState . uiGameplay . uiInventory . uiInventoryShouldUpdate) + + -- Whether the focused robot is too far away to sense, & whether + -- that has recently changed + dist <- use (gameState . to focusedRange) + farOK <- liftA2 (||) (use (gameState . creativeMode)) (use (gameState . landscape . worldScrollable)) + let tooFar = not farOK && dist == Just Far + farChanged = tooFar /= isNothing listRobotHash + + -- If the robot moved in or out of range, or hashes don't match + -- (either because which robot (or whether any robot) is focused + -- changed, or the focused robot's inventory changed), or the + -- inventory was flagged to be updated, regenerate the inventory list. + inventoryUpdated <- + if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate + then do + Brick.zoom (uiState . uiGameplay . uiInventory) $ do + populateInventoryList $ if tooFar then Nothing else fr + uiInventoryShouldUpdate .= False + pure True + else pure False + + -- Now check if the base finished running a program entered at the REPL. + replUpdated <- case g ^. gameControls . replStatus of + REPLWorking pty (Just v) + -- It did, and the result was the unit value or an exception. Just reset replStatus. + | v `elem` [VUnit, VExc] -> do + gameState . gameControls . replStatus .= REPLDone (Just (pty, v)) + pure True + + -- It did, and returned some other value. Create new 'it' + -- variables, pretty-print the result as a REPL output, with its + -- type, and reset the replStatus. + | otherwise -> do + itIx <- use (gameState . gameControls . replNextValueIndex) + env <- use (gameState . baseEnv) + let finalType = stripCmd (env ^. envTydefs) pty + itName = fromString $ "it" ++ show itIx + out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] + 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 + + -- Otherwise, do nothing. + _ -> pure False + + -- If the focused robot's log has been updated and the UI focus + -- isn't currently on the inventory or info panels, attempt to + -- automatically switch to the logger and scroll all the way down so + -- the new message can be seen. + uiState . uiGameplay . uiScrollToEnd .= False + logUpdated <- do + -- If the inventory or info panels are currently focused, it would + -- be rude to update them right under the user's nose, so consider + -- them "sticky". They will be updated as soon as the player moves + -- the focus away. + fring <- use $ uiState . uiGameplay . uiFocusRing + let sticky = focusGetCurrent fring `elem` map (Just . FocusablePanel) [RobotPanel, InfoPanel] + + -- Check if the robot log was updated and we are allowed to change + -- the inventory+info panels. + case maybe False (view robotLogUpdated) fr && not sticky of + False -> pure False + True -> do + -- Reset the log updated flag + zoomGameState $ zoomRobots clearFocusedRobotLogUpdated + + -- Find and focus an equipped "logger" device in the inventory list. + let isLogger (EquippedEntry e) = e ^. entityName == "logger" + isLogger _ = False + focusLogger = BL.listFindBy isLogger + + uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 %= focusLogger + + -- Now inform the UI that it should scroll the info panel to + -- the very end. + uiState . uiGameplay . uiScrollToEnd .= True + pure True + + goalOrWinUpdated <- doGoalUpdates + + newPopups <- generateNotificationPopups + + let redraw = + g ^. needsRedraw + || inventoryUpdated + || replUpdated + || logUpdated + || goalOrWinUpdated + || newPopups + pure redraw + +-- | Either pops up the updated Goals modal +-- or pops up the Congratulations (Win) modal, or pops +-- up the Condolences (Lose) modal. +-- The Win modal will take precedence if the player +-- has met the necessary conditions to win the game. +-- +-- If the player chooses to "Keep Playing" from the Win modal, the +-- updated Goals will then immediately appear. +-- This is desirable for: +-- * feedback as to the final goal the player accomplished, +-- * as a summary of all of the goals of the game +-- * shows the player more "optional" goals they can continue to pursue +doGoalUpdates :: EventM Name AppState Bool +doGoalUpdates = do + curGoal <- use (uiState . uiGameplay . uiGoal . goalsContent) + isCheating <- use (uiState . uiCheatMode) + curWinCondition <- use (gameState . winCondition) + announcementsSeq <- use (gameState . messageInfo . announcementQueue) + let announcementsList = toList announcementsSeq + + -- Decide whether we need to update the current goal text and pop + -- up a modal dialog. + case curWinCondition of + NoWinCondition -> return False + WinConditions (Unwinnable False) x -> do + -- This clears the "flag" that the Lose dialog needs to pop up + gameState . winCondition .= WinConditions (Unwinnable True) x + openModal $ ScenarioEndModal LoseModal + saveScenarioInfoOnFinishNocheat + return True + WinConditions (Won False ts) x -> do + -- This clears the "flag" that the Win dialog needs to pop up + gameState . winCondition .= WinConditions (Won True ts) x + openModal $ ScenarioEndModal WinModal + saveScenarioInfoOnFinishNocheat + -- We do NOT advance the New Game menu to the next item here (we + -- used to!), because we do not know if the user is going to + -- select 'keep playing' or 'next challenge'. We maintain the + -- invariant that the current menu item is always the same as + -- the scenario currently being played. If the user either (1) + -- quits to the menu or (2) selects 'next challenge' we will + -- advance the menu at that point. + return True + WinConditions _ oc -> do + let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc + -- The "uiGoal" field is initialized with empty members, so we know that + -- this will be the first time showing it if it will be nonempty after previously + -- being empty. + isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal) + goalWasUpdated = isFirstGoalDisplay || not (null announcementsList) + + -- Decide whether to show a pop-up modal congratulating the user on + -- successfully completing the current challenge. + when goalWasUpdated $ do + let hasMultiple = hasMultipleGoals newGoalTracking + defaultFocus = + if hasMultiple + then ObjectivesList + else GoalSummary + + ring = + focusRing $ + map GoalWidgets $ + if hasMultiple + then enumerate + else [GoalSummary] + + -- The "uiGoal" field is necessary at least to "persist" the data that is needed + -- if the player chooses to later "recall" the goals dialog with CTRL+g. + uiState + . uiGameplay + . uiGoal + .= GoalDisplay + newGoalTracking + (GR.makeListWidget newGoalTracking) + (focusSetCurrent (GoalWidgets defaultFocus) ring) + + -- This clears the "flag" that indicate that the goals dialog needs to be + -- automatically popped up. + gameState . messageInfo . announcementQueue .= mempty + + hideGoals <- use $ uiState . uiGameplay . uiHideGoals + unless hideGoals $ + openModal GoalModal + + return goalWasUpdated + +-- | Pops up notifications when new recipes or commands are unlocked. +generateNotificationPopups :: EventM Name AppState Bool +generateNotificationPopups = do + rs <- use $ gameState . discovery . availableRecipes + let newRecipes = rs ^. notificationsShouldAlert + when newRecipes $ do + uiState . uiPopups %= addPopup RecipesPopup + gameState . discovery . availableRecipes . notificationsShouldAlert .= False + + cs <- use $ 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 + + 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 diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Controller.Util where + +import Brick hiding (Direction) +import Brick.Focus +import Brick.Keybindings +import Control.Carrier.Lift qualified as Fused +import Control.Carrier.State.Lazy qualified as Fused +import Control.Lens as Lens +import Control.Monad (forM_, unless, when) +import Control.Monad.IO.Class (MonadIO (liftIO), liftIO) +import Control.Monad.State (MonadState, execState) +import Data.List.Extra (enumerate) +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text (Text) +import Graphics.Vty qualified as V +import Swarm.Effect (TimeIOC, runTimeIO) +import Swarm.Game.CESK (continue) +import Swarm.Game.Device +import Swarm.Game.Robot (robotCapabilities) +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Step (finishGameTick) +import Swarm.Game.Universe +import Swarm.Game.World qualified as W +import Swarm.Game.World.Coords +import Swarm.Language.Capability (Capability (CDebug)) +import Swarm.Language.Syntax hiding (Key) +import Swarm.TUI.Model +import Swarm.TUI.Model.Repl (REPLHistItem, REPLPrompt, REPLState, addREPLItem, replHistory, replPromptText, replPromptType) +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Util (generateModal) +import System.Clock (Clock (..), getTime) + +-- | Pattern synonyms to simplify brick event handler +pattern Key :: V.Key -> BrickEvent n e +pattern Key k = VtyEvent (V.EvKey k []) + +pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e +pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) []) +pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl]) +pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta]) + +pattern ShiftKey :: V.Key -> BrickEvent n e +pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift]) + +pattern MetaKey :: V.Key -> BrickEvent n e +pattern MetaKey k = VtyEvent (V.EvKey k [V.MMeta]) + +pattern EscapeKey :: BrickEvent n e +pattern EscapeKey = VtyEvent (V.EvKey V.KEsc []) + +pattern BackspaceKey :: BrickEvent n e +pattern BackspaceKey = VtyEvent (V.EvKey V.KBS []) + +pattern FKey :: Int -> BrickEvent n e +pattern FKey c = VtyEvent (V.EvKey (V.KFun c) []) + +openModal :: ModalType -> EventM Name AppState () +openModal mt = do + resetViewport modalScroll + newModal <- gets $ flip generateModal mt + ensurePause + uiState . uiGameplay . uiModal ?= newModal + -- Beep + case mt of + ScenarioEndModal _ -> do + vty <- getVtyHandle + liftIO $ V.ringTerminalBell $ V.outputIface vty + _ -> return () + where + -- Set the game to AutoPause if needed + ensurePause = do + pause <- use $ gameState . temporal . paused + unless (pause || isRunningModal mt) $ gameState . temporal . runStatus .= AutoPause + +-- | The running modals do not autopause the game. +isRunningModal :: ModalType -> Bool +isRunningModal = \case + RobotsModal -> True + MessagesModal -> True + _ -> False + +-- | Set the game to Running if it was (auto) paused otherwise to paused. +-- +-- Also resets the last frame time to now. If we are pausing, it +-- doesn't matter; if we are unpausing, this is critical to +-- ensure the next frame doesn't think it has to catch up from +-- whenever the game was paused! +safeTogglePause :: EventM Name AppState () +safeTogglePause = do + curTime <- liftIO $ getTime Monotonic + uiState . uiGameplay . uiTiming . lastFrameTime .= curTime + uiState . uiGameplay . uiShowDebug .= False + p <- gameState . temporal . runStatus Lens.<%= toggleRunStatus + when (p == Running) $ zoomGameState finishGameTick + +-- | Only unpause the game if leaving autopaused modal. +-- +-- Note that the game could have been paused before opening +-- the modal, in that case, leave the game paused. +safeAutoUnpause :: EventM Name AppState () +safeAutoUnpause = do + runs <- use $ gameState . temporal . runStatus + when (runs == AutoPause) safeTogglePause + +toggleModal :: ModalType -> EventM Name AppState () +toggleModal mt = do + modal <- use $ uiState . uiGameplay . uiModal + case modal of + Nothing -> openModal mt + Just _ -> uiState . uiGameplay . uiModal .= Nothing >> safeAutoUnpause + +setFocus :: FocusablePanel -> EventM Name AppState () +setFocus name = uiState . uiGameplay . uiFocusRing %= focusSetCurrent (FocusablePanel name) + +immediatelyRedrawWorld :: EventM Name AppState () +immediatelyRedrawWorld = do + invalidateCacheEntry WorldCache + loadVisibleRegion + +-- | Make sure all tiles covering the visible part of the world are +-- loaded. +loadVisibleRegion :: EventM Name AppState () +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) + +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) + +hasDebugCapability :: Bool -> AppState -> Bool +hasDebugCapability isCreative s = + maybe isCreative (S.member CDebug . getCapabilitySet) $ + s ^? gameState . to focusedRobot . _Just . robotCapabilities + +-- | Resets the viewport scroll position +resetViewport :: ViewportScroll Name -> EventM Name AppState () +resetViewport n = do + vScrollToBeginning n + hScrollToBeginning n + +-- | Modifies the game state using a fused-effect state action. +zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> m a +zoomGameState f = do + gs <- use gameState + (gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f))) + gameState .= gs' + return a + +onlyCreative :: (MonadState AppState m) => m () -> m () +onlyCreative a = do + c <- use $ gameState . creativeMode + when c a + +-- | Create a list of handlers with embedding events and using pattern matching. +allHandlers :: + (Ord e2, Enum e1, Bounded e1) => + (e1 -> e2) -> + (e1 -> (Text, EventM Name AppState ())) -> + [KeyEventHandler e2 (EventM Name AppState)] +allHandlers eEmbed f = map handleEvent1 enumerate + where + handleEvent1 e1 = let (n, a) = f e1 in onEvent (eEmbed e1) n a + +runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () +runBaseTerm = maybe (pure ()) startBaseProgram + where + -- The player typed something at the REPL and hit Enter; this + -- function takes the resulting term (if the REPL + -- input is valid) and sets up the base robot to run it. + startBaseProgram t = do + -- Set the REPL status to Working + gameState . gameControls . replStatus .= REPLWorking (t ^. sType) Nothing + -- Set up the robot's CESK machine to evaluate/execute the + -- given term. + gameState . baseRobot . machine %= continue t + -- Finally, be sure to activate the base robot. + gameState %= execState (zoomRobots $ activateRobot 0) + +-- | Set the REPL to the given text and REPL prompt type. +modifyResetREPL :: Text -> REPLPrompt -> REPLState -> REPLState +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 + +-- | Add an item to the REPL history. +addREPLHistItem :: MonadState AppState m => REPLHistItem -> m () +addREPLHistItem item = uiState . 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 new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Editor/Controller.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Editor.Controller where + +import Brick hiding (Direction (..), Location (..)) +import Brick qualified as B +import Brick.Focus +import Brick.Widgets.List qualified as BL +import Control.Lens +import Control.Monad (forM_, guard, when) +import Control.Monad.Extra (whenJust) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Map qualified as M +import Data.Yaml qualified as Y +import Graphics.Vty qualified as V +import Swarm.Game.Land +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.Universe +import Swarm.Game.World.Coords +import Swarm.TUI.Controller.Util +import Swarm.TUI.Editor.Model +import Swarm.TUI.Editor.Palette +import Swarm.TUI.Editor.Util qualified as EU +import Swarm.TUI.Model +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.UI +import Swarm.Util (hoistMaybe) +import Swarm.Util.Erasable (maybeToErasable) +import System.Clock + +------------------------------------------------------------ +-- 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 OutputPathSelector = + -- TODO: #1371 + liftIO $ putStrLn "File selection" +activateWorldEditorFunction MapSaveButton = saveMapFile +activateWorldEditorFunction ClearEntityButton = + uiState . uiGameplay . uiWorldEditor . entityPaintList . BL.listSelectedL .= Nothing + +handleCtrlLeftClick :: B.Location -> EventM Name AppState () +handleCtrlLeftClick mouseLoc = do + worldEditor <- use $ uiState . uiGameplay . uiWorldEditor + _ <- runMaybeT $ do + guard $ worldEditor ^. worldOverdraw . isWorldEditorEnabled + let getSelected x = snd <$> BL.listSelectedElement x + maybeTerrainType = getSelected $ worldEditor ^. terrainList + maybeEntityPaint = getSelected $ worldEditor ^. entityPaintList + terrain <- hoistMaybe maybeTerrainType + mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc + Brick.zoom (uiState . uiGameplay . uiWorldEditor) $ do + worldOverdraw . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeToErasable maybeEntityPaint) + lastWorldEditorMessage .= Nothing + immediatelyRedrawWorld + return () + +handleRightClick :: B.Location -> EventM Name AppState () +handleRightClick mouseLoc = do + worldEditor <- use $ uiState . 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 () + +-- | "Eye Dropper" tool: +handleMiddleClick :: B.Location -> EventM Name AppState () +handleMiddleClick mouseLoc = do + worldEditor <- use $ uiState . uiGameplay . uiWorldEditor + when (worldEditor ^. worldOverdraw . isWorldEditorEnabled) $ do + w <- use $ gameState . landscape . multiWorld + tm <- use $ gameState . landscape . terrainAndEntities . terrainMap + let setTerrainPaint coords = do + let (terrain, maybeElementPaint) = + EU.getEditorContentAt + tm + (worldEditor ^. worldOverdraw) + w + coords + uiState . 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 + + 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 = \case + Key V.KEsc -> uiState . uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete + Key V.KEnter -> do + fring <- use $ uiState . 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 + _ -> return () + +-- | Return value: whether the cursor position should be updated +updateAreaBounds :: Maybe (Cosmic Coords) -> EventM Name AppState Bool +updateAreaBounds = \case + Nothing -> return True + Just mouseCoords -> do + selectorStage <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsSelectionStep + case selectorStage of + UpperLeftPending -> do + uiState . 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 + lastWorldEditorMessage .= Nothing + Brick.zoom editingBounds $ do + boundsRect .= Just (fmap (,view planar mouseCoords) upperLeftMouseCoords) + boundsSelectionStep .= SelectionComplete + boundsPersistDisplayUntil .= t + TimeSpec 2 0 + setFocus WorldEditorPanel + return False + SelectionComplete -> return True + +saveMapFile :: EventM Name AppState () +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 = + 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 + + uiState . uiGameplay . uiWorldEditor . lastWorldEditorMessage .= Just "Saved." diff --git a/src/swarm-tui/Swarm/TUI/Editor/Json.hs b/src/swarm-tui/Swarm/TUI/Editor/Json.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Editor/Json.hs @@ -0,0 +1,24 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Editor.Json where + +import Data.Text (Text) +import Data.Yaml as Y +import GHC.Generics (Generic) +import Swarm.Game.Entity (Entity) +import Swarm.Game.Scenario.Topography.WorldDescription +import Swarm.Language.Syntax (Syntax) +import Swarm.Language.Text.Markdown (Document) + +data SkeletonScenario = SkeletonScenario + { version :: Int + , name :: Text + , description :: Document Syntax + , creative :: Bool + , entities :: [Entity] + , world :: WorldDescriptionPaint + , robots :: [String] + } + deriving (Generic) + +instance ToJSON SkeletonScenario diff --git a/src/swarm-tui/Swarm/TUI/Editor/Masking.hs b/src/swarm-tui/Swarm/TUI/Editor/Masking.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Editor/Masking.hs @@ -0,0 +1,33 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Editor.Masking where + +import Control.Lens hiding (Const, from) +import Data.Maybe (fromMaybe) +import Swarm.Game.Universe +import Swarm.Game.World.Coords +import Swarm.TUI.Editor.Model +import Swarm.TUI.Editor.Util qualified as EU +import Swarm.TUI.Model.UI + +shouldHideWorldCell :: UIGameplay -> Coords -> Bool +shouldHideWorldCell ui coords = + isOutsideSingleSelectedCorner || isOutsideMapSaveBounds + where + we = ui ^. uiWorldEditor + withinTimeout = ui ^. uiTiming . lastFrameTime < we ^. editingBounds . boundsPersistDisplayUntil + + isOutsideMapSaveBounds = + withinTimeout + && fromMaybe + False + ( do + bounds <- we ^. editingBounds . boundsRect + pure $ EU.isOutsideRegion (bounds ^. planar) coords + ) + + isOutsideSingleSelectedCorner = fromMaybe False $ do + Cosmic _ cornerCoords <- case we ^. editingBounds . boundsSelectionStep of + LowerRightPending cornerCoords -> Just cornerCoords + _ -> Nothing + pure $ EU.isOutsideTopLeftCorner cornerCoords coords diff --git a/src/swarm-tui/Swarm/TUI/Editor/Model.hs b/src/swarm-tui/Swarm/TUI/Editor/Model.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Editor/Model.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Editor.Model where + +import Brick.Focus +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (from, (.=), (<.>)) +import Data.List.Extra (enumerate) +import Data.Map qualified as M +import Data.Vector qualified as V +import Swarm.Game.Display (Display) +import Swarm.Game.Entity qualified as E +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Scenario.Topography.WorldPalette +import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Universe +import Swarm.Game.World.Coords +import Swarm.TUI.Model.Name +import System.Clock + +data BoundsSelectionStep + = UpperLeftPending + | -- | Stores the *world coords* of the upper-left click + LowerRightPending (Cosmic Coords) + | SelectionComplete + +data EntityPaint + = Facade EntityFacade + | Ref E.Entity + deriving (Eq) + +getDisplay :: EntityPaint -> Display +getDisplay (Facade (EntityFacade _ d)) = d +getDisplay (Ref e) = e ^. E.entityDisplay + +toFacade :: EntityPaint -> EntityFacade +toFacade = \case + 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 + -- of the map to be saved. + , _boundsPersistDisplayUntil :: TimeSpec + , _boundsSelectionStep :: BoundsSelectionStep + } + +makeLenses ''MapEditingBounds + +data WorldOverdraw = WorldOverdraw + { _isWorldEditorEnabled :: Bool + -- ^ This field has deferred initialization; it gets populated when a game + -- is initialized. + , _paintedTerrain :: M.Map Coords (TerrainWith EntityFacade) + } + +makeLenses ''WorldOverdraw + +data WorldEditor n = WorldEditor + { _worldOverdraw :: WorldOverdraw + , _terrainList :: BL.List n TerrainType + , _entityPaintList :: BL.List n EntityFacade + , _editingBounds :: MapEditingBounds + , _editorFocusRing :: FocusRing n + , _outputFilePath :: FilePath + , _lastWorldEditorMessage :: Maybe String + } + +makeLenses ''WorldEditor + +initialWorldEditor :: TimeSpec -> WorldEditor Name +initialWorldEditor ts = + WorldEditor + (WorldOverdraw False mempty) + (BL.list TerrainList (V.fromList []) 1) + (BL.list EntityPaintList (V.fromList []) 1) + bounds + (focusRing $ map WorldEditorPanelControl enumerate) + "mymap.yaml" + Nothing + where + bounds = + MapEditingBounds + -- Note that these are in "world coordinates", + -- not in player-facing "Location" coordinates + (Just $ Cosmic DefaultRootSubworld (Coords (-10, -20), Coords (10, 20))) + (ts - 1) + SelectionComplete diff --git a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Editor.Palette where + +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) +import Data.Map qualified as M +import Data.Maybe (catMaybes, mapMaybe) +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) +import Swarm.Game.Land +import Swarm.Game.Location +import Swarm.Game.Scenario +import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Scenario.Topography.Grid +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.WorldPalette +import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName) +import Swarm.Game.Universe +import Swarm.Language.Text.Markdown (fromText) +import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario)) +import Swarm.Util (binTuples, histogram) +import Swarm.Util.Erasable + +makeSuggestedPalette :: + TerrainMap -> + KM.KeyMap (AugmentedCell Entity) -> + Grid (Maybe CellPaintDisplay) -> + KM.KeyMap (AugmentedCell EntityFacade) +makeSuggestedPalette tm originalScenarioPalette cellGrid = + KM.fromMapText + . M.map (SignpostableCell Nothing) + . M.fromList + . M.elems + -- NOTE: the left-most maps take precedence! + $ paletteCellsByKey <> pairsWithDisplays <> terrainOnlyPalette + where + cellList = catMaybes $ allMembers cellGrid + + getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display) + getMaybeEntityDisplay (Cell _terrain (erasableToMaybe -> maybeEntity) _) = do + EntityFacade eName d <- maybeEntity + return (eName, d) + + getMaybeEntityNameTerrainPair :: PCell EntityFacade -> Maybe (EntityName, TerrainType) + getMaybeEntityNameTerrainPair (Cell terrain (erasableToMaybe -> maybeEntity) _) = do + EntityFacade eName _ <- maybeEntity + return (eName, terrain) + + getEntityTerrainMultiplicity :: Map EntityName (Map TerrainType Int) + getEntityTerrainMultiplicity = + M.map histogram $ binTuples $ mapMaybe getMaybeEntityNameTerrainPair cellList + + usedEntityDisplays :: Map EntityName Display + usedEntityDisplays = + M.fromList $ mapMaybe getMaybeEntityDisplay cellList + + -- Finds the most-used terrain type (the "mode" in the statistical sense) + -- paired with each entity + entitiesWithModalTerrain :: [(TerrainType, EntityName)] + entitiesWithModalTerrain = + map (swap . fmap (fst . NE.head)) + . mapMaybe sequenceA + . M.toList + $ M.map (NE.nonEmpty . sortOn snd . M.toList) getEntityTerrainMultiplicity + + invertPaletteMapToDedupe :: + Map a CellPaintDisplay -> + [(TerrainWith EntityName, (a, CellPaintDisplay))] + invertPaletteMapToDedupe = + map (\x@(_, c) -> (toKey $ cellToTerrainPair c, x)) . M.toList + + paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + paletteCellsByKey = + M.map (NE.head . NE.sortWith toSortVal) + . binTuples + . invertPaletteMapToDedupe + $ KM.toMapText originalPalette + where + toSortVal (symbol, Cell _terrain _maybeEntity robots) = Down (null robots, symbol) + + excludedPaletteChars :: Set Char + excludedPaletteChars = Set.fromList [' '] + + originalPalette :: KM.KeyMap CellPaintDisplay + originalPalette = + KM.map (toCellPaintDisplay . standardCell) originalScenarioPalette + + pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain + where + g (terrain, eName) = do + eDisplay <- M.lookup eName usedEntityDisplays + 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)) + + -- TODO (#1153): Filter out terrain-only palette entries that aren't actually + -- used in the map. + terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + terrainOnlyPalette = M.fromList . map f . M.keys $ terrainByName tm + where + f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing [])) + +-- | Generate a \"skeleton\" scenario with placeholders for certain required fields +constructScenario :: Maybe Scenario -> Grid (Maybe CellPaintDisplay) -> SkeletonScenario +constructScenario maybeOriginalScenario cellGrid = + SkeletonScenario + (maybe 1 (^. scenarioMetadata . scenarioVersion) maybeOriginalScenario) + (maybe "My Scenario" (^. scenarioMetadata . scenarioName) maybeOriginalScenario) + (maybe (fromText "The scenario description...") (^. scenarioOperation . scenarioDescription) maybeOriginalScenario) + -- (maybe True (^. scenarioCreative) maybeOriginalScenario) + True + (M.elems $ entitiesByName customEntities) + wd + [] -- robots + where + tem = maybe mempty (^. scenarioLandscape . scenarioTerrainAndEntities) maybeOriginalScenario + customEntities = tem ^. entityMap + wd = + WorldDescription + { offsetOrigin = False + , scrollable = True + , palette = StructurePalette suggestedPalette + , ul = upperLeftCoord + , area = PositionedGrid upperLeftCoord cellGrid + , navigation = Navigation mempty mempty + , placedStructures = mempty + , worldName = DefaultRootSubworld + , worldProg = Nothing + } + + extractPalette = unPalette . palette . NE.head . (^. scenarioLandscape . scenarioWorlds) + originalPalette = maybe mempty extractPalette maybeOriginalScenario + suggestedPalette = makeSuggestedPalette (tem ^. terrainMap) originalPalette cellGrid + + upperLeftCoord = + Location + (negate $ w `div` 2) + (h `div` 2) + where + AreaDimensions w h = getGridDimensions cellGrid diff --git a/src/swarm-tui/Swarm/TUI/Editor/Util.hs b/src/swarm-tui/Swarm/TUI/Editor/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Editor/Util.hs @@ -0,0 +1,115 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Editor.Util where + +import Control.Applicative ((<|>)) +import Control.Lens hiding (Const, from) +import Control.Monad (guard) +import Data.Map qualified as M +import Data.Map qualified as Map +import Data.Maybe qualified as Maybe +import Data.Vector qualified as V +import Swarm.Game.Entity +import Swarm.Game.Scenario.Topography.Area qualified as EA +import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.WorldDescription +import Swarm.Game.Terrain (TerrainMap, TerrainType) +import Swarm.Game.Universe +import Swarm.Game.World qualified as W +import Swarm.Game.World.Coords +import Swarm.TUI.Editor.Model +import Swarm.Util.Content +import Swarm.Util.Erasable + +getEntitiesForList :: EntityMap -> V.Vector EntityFacade +getEntitiesForList em = + V.fromList $ map mkFacade entities + where + entities = M.elems $ entitiesByName em + +getEditingBounds :: WorldDescription -> (Bool, Cosmic BoundsRectangle) +getEditingBounds myWorld = + (EA.isEmpty a, newBounds) + where + newBounds = Cosmic DefaultRootSubworld (locToCoords upperLeftLoc, locToCoords lowerRightLoc) + upperLeftLoc = ul myWorld + a = EA.getGridDimensions $ gridContent $ area myWorld + lowerRightLoc = EA.computeBottomRightFromUpperLeft a upperLeftLoc + +getEditorContentAt :: + TerrainMap -> + WorldOverdraw -> + W.MultiWorld Int Entity -> + Cosmic Coords -> + (TerrainType, Maybe EntityPaint) +getEditorContentAt tm editorOverdraw w coords = + (terrainWithOverride, entityWithOverride) + where + terrainWithOverride = Maybe.fromMaybe underlyingCellTerrain $ do + (terrainOverride, _) <- maybePaintedCell + return terrainOverride + + maybeEntityOverride :: Maybe EntityPaint + maybeEntityOverride = do + (_, e) <- maybePaintedCell + Facade <$> erasableToMaybe e + + maybePaintedCell = do + guard $ editorOverdraw ^. isWorldEditorEnabled + Map.lookup (coords ^. planar) pm + + pm = editorOverdraw ^. paintedTerrain + + entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride + (underlyingCellTerrain, underlyingCellEntity) = getContentAt tm w coords + +getEditorTerrainAt :: + TerrainMap -> + WorldOverdraw -> + W.MultiWorld Int Entity -> + Cosmic Coords -> + TerrainType +getEditorTerrainAt tm editor w coords = + fst $ getEditorContentAt tm editor w coords + +isOutsideTopLeftCorner :: + -- | top left corner coords + Coords -> + -- | current coords + Coords -> + Bool +isOutsideTopLeftCorner (Coords (yTop, xLeft)) (Coords (y, x)) = + x < xLeft || y < yTop + +isOutsideBottomRightCorner :: + -- | bottom right corner coords + Coords -> + -- | current coords + Coords -> + Bool +isOutsideBottomRightCorner (Coords (yBottom, xRight)) (Coords (y, x)) = + x > xRight || y > yBottom + +isOutsideRegion :: + -- | full bounds + BoundsRectangle -> + -- | current coords + Coords -> + Bool +isOutsideRegion (tl, br) coord = + isOutsideTopLeftCorner tl coord || isOutsideBottomRightCorner br coord + +getEditedMapRectangle :: + TerrainMap -> + WorldOverdraw -> + Maybe (Cosmic BoundsRectangle) -> + W.MultiWorld Int Entity -> + Grid CellPaintDisplay +getEditedMapRectangle _ _ Nothing _ = EmptyGrid +getEditedMapRectangle tm worldEditor (Just (Cosmic subworldName coords)) w = + getMapRectangle toFacade getContent coords + where + getContent = getEditorContentAt tm worldEditor w . Cosmic subworldName diff --git a/src/swarm-tui/Swarm/TUI/Editor/View.hs b/src/swarm-tui/Swarm/TUI/Editor/View.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Editor/View.hs @@ -0,0 +1,170 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Editor.View where + +import Brick hiding (Direction) +import Brick.Focus +import Brick.Widgets.Center (hCenter) +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (Const, from) +import Data.List qualified as L +import Swarm.Game.Land +import Swarm.Game.Scenario +import Swarm.Game.Scenario.Topography.Area qualified as EA +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Terrain (TerrainMap, TerrainType) +import Swarm.Game.Universe +import Swarm.Game.World.Coords +import Swarm.TUI.Border +import Swarm.TUI.Editor.Model +import Swarm.TUI.Model +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.UI +import Swarm.TUI.Panel +import Swarm.TUI.View.Attribute.Attr +import Swarm.TUI.View.CellDisplay (renderDisplay) +import Swarm.TUI.View.Util qualified as VU + +extractTerrainMap :: UIState -> TerrainMap +extractTerrainMap uis = + maybe mempty (view (scenarioLandscape . scenarioTerrainAndEntities . terrainMap) . fst) $ + uis ^. uiGameplay . scenarioRef + +drawWorldEditor :: FocusRing Name -> UIState -> Widget Name +drawWorldEditor toplevelFocusRing uis = + if worldEditor ^. worldOverdraw . isWorldEditorEnabled + then + panel + highlightAttr + toplevelFocusRing + (FocusablePanel WorldEditorPanel) + plainBorder + innerWidget + else emptyWidget + where + privateFocusRing = worldEditor ^. editorFocusRing + maybeCurrentFocus = focusGetCurrent privateFocusRing + + controlsBox = + padBottom Max $ + vBox + [ brushWidget + , entityWidget + , clearEntityButtonWidget + , areaWidget + , outputWidget + , str " " + , saveButtonWidget + ] + + innerWidget = + padLeftRight 1 $ + hLimit 30 $ + controlsBox <=> statusBox + + worldEditor = uis ^. uiGameplay . uiWorldEditor + maybeAreaBounds = worldEditor ^. editingBounds . boundsRect + + -- TODO (#1150): Use withFocusRing? + mkFormControl n w = + clickable n $ transformation w + where + transformation = + if Just n == maybeCurrentFocus + then withAttr BL.listSelectedFocusedAttr + else id + + swatchContent list drawFunc = + maybe emptyWidget drawFunc selectedThing + where + selectedThing = snd <$> BL.listSelectedElement list + + tm = extractTerrainMap uis + + brushWidget = + mkFormControl (WorldEditorPanelControl BrushSelector) $ + padRight (Pad 1) (str "Brush:") + <+> swatchContent (worldEditor ^. terrainList) (VU.drawLabeledTerrainSwatch tm) + + entityWidget = + mkFormControl (WorldEditorPanelControl EntitySelector) $ + padRight (Pad 1) (str "Entity:") + <+> swatchContent (worldEditor ^. entityPaintList) drawLabeledEntitySwatch + + clearEntityButtonWidget = + if null $ worldEditor ^. entityPaintList . BL.listSelectedL + then emptyWidget + else + mkFormControl (WorldEditorPanelControl ClearEntityButton) + . hLimit 20 + . hCenter + $ str "None" + + areaContent = case worldEditor ^. editingBounds . boundsSelectionStep of + UpperLeftPending -> str "Click top-left" + LowerRightPending _wcoords -> str "Click bottom-right" + SelectionComplete -> maybe emptyWidget (renderBounds . view planar) maybeAreaBounds + + areaWidget = + mkFormControl (WorldEditorPanelControl AreaSelector) $ + vBox + [ str "Area:" + , areaContent + ] + + renderBounds (upperLeftCoord, lowerRightCoord) = + str $ + unwords $ + L.intersperse + "@" + [ EA.renderRectDimensions rectArea + , VU.locationToString upperLeftLoc + ] + where + upperLeftLoc = coordsToLoc upperLeftCoord + lowerRightLoc = coordsToLoc lowerRightCoord + rectArea = EA.cornersToArea upperLeftLoc lowerRightLoc + + outputWidget = + mkFormControl (WorldEditorPanelControl OutputPathSelector) $ + padRight (Pad 1) (str "Output:") <+> outputWidgetContent + + outputWidgetContent = str $ worldEditor ^. outputFilePath + + saveButtonWidget = + mkFormControl (WorldEditorPanelControl MapSaveButton) + . hLimit 20 + . hCenter + $ str "Save" + + statusBox = maybe emptyWidget str $ worldEditor ^. lastWorldEditorMessage + +drawLabeledEntitySwatch :: EntityFacade -> Widget Name +drawLabeledEntitySwatch (EntityFacade eName eDisplay) = + tile <+> txt eName + where + tile = padRight (Pad 1) $ renderDisplay eDisplay + +drawTerrainSelector :: AppState -> Widget Name +drawTerrainSelector s = + padAll 1 + . hCenter + . vLimit 8 + . BL.renderListWithIndex (listDrawTerrainElement $ extractTerrainMap $ s ^. uiState) True + $ s ^. uiState . uiGameplay . 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 = + padAll 1 + . hCenter + . vLimit 10 + . BL.renderListWithIndex listDrawEntityPaintElement True + $ s ^. uiState . uiGameplay . uiWorldEditor . entityPaintList + +listDrawEntityPaintElement :: Int -> Bool -> EntityFacade -> Widget Name +listDrawEntityPaintElement pos _isSelected a = + clickable (EntityPaintListItem pos) $ drawLabeledEntitySwatch a diff --git a/src/swarm-tui/Swarm/TUI/Inventory/Sorting.hs b/src/swarm-tui/Swarm/TUI/Inventory/Sorting.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Inventory/Sorting.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Inventory.Sorting ( + InventorySortOptions (..), + InventorySortDirection (..), + InventorySortOrder (..), + cycleSortOrder, + cycleSortDirection, + defaultSortOptions, + sortInventory, + renderSortMethod, +) where + +import Algorithms.NaturalSort (sortKey) +import Control.Lens (view) +import Data.List (sortBy) +import Data.Ord (Down (Down), comparing) +import Data.Text qualified as T +import Swarm.Game.Entity as E +import Swarm.Util (cycleEnum) + +data InventorySortDirection + = Ascending + | Descending + deriving (Enum, Bounded, Eq) + +data InventorySortOrder + = ByNaturalAlphabetic + | ByQuantity + | ByType + deriving (Enum, Bounded, Eq) + +data InventorySortOptions = InventorySortOptions InventorySortDirection InventorySortOrder + +defaultSortOptions :: InventorySortOptions +defaultSortOptions = InventorySortOptions Ascending ByNaturalAlphabetic + +renderSortMethod :: InventorySortOptions -> T.Text +renderSortMethod (InventorySortOptions direction order) = + T.unwords [prefix, label] + where + prefix = case direction of + Ascending -> "↑" + Descending -> "↓" + label = case order of + ByNaturalAlphabetic -> "name" + ByQuantity -> "count" + ByType -> "type" + +cycleSortOrder :: InventorySortOptions -> InventorySortOptions +cycleSortOrder (InventorySortOptions direction order) = + InventorySortOptions direction (cycleEnum order) + +cycleSortDirection :: InventorySortOptions -> InventorySortOptions +cycleSortDirection (InventorySortOptions direction order) = + InventorySortOptions (cycleEnum direction) order + +-- | All non-alphabetic sort criteria perform alphabetic tie-breaking. +-- "Reverse ordering" only applies to the *primary* sort criteria; the secondary +-- alphabetic sort is always in ascending order. +getSortComparator :: Ord a => InventorySortOptions -> (a, Entity) -> (a, Entity) -> Ordering +getSortComparator (InventorySortOptions direction order) = case order of + ByNaturalAlphabetic -> compReversible (alphabetic . snd) + ByQuantity -> compReversible fst <> secondary + ByType -> compReversible (view entityProperties . snd) <> secondary + where + alphabetic = sortKey . T.toLower . view entityName + secondary = comparing (alphabetic . snd) + + compReversible :: Ord a => (b -> a) -> b -> b -> Ordering + compReversible = case direction of + Ascending -> comparing + Descending -> \f -> comparing (Down . f) + +sortInventory :: Ord a => InventorySortOptions -> [(a, Entity)] -> [(a, Entity)] +sortInventory opts = + sortBy $ getSortComparator opts diff --git a/src/swarm-tui/Swarm/TUI/Launch/Controller.hs b/src/swarm-tui/Swarm/TUI/Launch/Controller.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Launch/Controller.hs @@ -0,0 +1,172 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Event handling for the scenario launch configuration dialog. +module Swarm.TUI.Launch.Controller where + +import Brick hiding (Direction, Location) +import Brick.Focus +import Brick.Widgets.Edit (handleEditorEvent) +import Brick.Widgets.FileBrowser +import Brick.Widgets.FileBrowser qualified as FB +import Control.Lens +import Control.Monad (forM_, when) +import Control.Monad.IO.Class (liftIO) +import Data.List.Extra (enumerate) +import Data.Maybe (listToMaybe) +import Graphics.Vty qualified as V +import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (LaunchParams)) +import Swarm.Game.ScenarioInfo +import Swarm.TUI.Controller.Util +import Swarm.TUI.Launch.Model +import Swarm.TUI.Launch.Prep (initFileBrowserWidget, makeFocusRingWith, parseSeedInput, parseWidgetParams, toValidatedParams) +import Swarm.TUI.Model +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.StateUpdate +import Swarm.TUI.Model.UI + +updateFocusRing :: EditingLaunchParams -> EventM Name LaunchOptions () +updateFocusRing parsedParams = do + currentRing <- use $ controls . scenarioConfigFocusRing + let eitherLaunchParams = toValidatedParams parsedParams + modifyRingMembers = case eitherLaunchParams of + Left _ -> filter (/= StartGameButton) + Right _ -> id + maybeCurrentFocus = focusGetCurrent currentRing + refocusRing = maybe id focusSetCurrent maybeCurrentFocus + + controls . scenarioConfigFocusRing .= refocusRing (makeFocusRingWith $ modifyRingMembers enumerate) + +cacheValidatedInputs :: EventM Name LaunchOptions () +cacheValidatedInputs = do + launchControls <- use controls + parsedParams <- liftIO $ parseWidgetParams launchControls + editingParams .= parsedParams + updateFocusRing parsedParams + +-- | This is split out from the combined parameter-validation function +-- because validating the seed is cheap, and shouldn't have to pay +-- the cost of re-parsing script code as the user types in the seed +-- selection field. +cacheValidatedSeedInput :: EventM Name LaunchOptions () +cacheValidatedSeedInput = do + seedEditor <- use $ controls . seedValueEditor + let eitherMaybeSeed = parseSeedInput seedEditor + LaunchParams _ eitherParsedCode <- use editingParams + let newParams = LaunchParams eitherMaybeSeed eitherParsedCode + editingParams .= newParams + updateFocusRing newParams + +-- | If the 'FileBrowser' is in "search mode", then we allow +-- more of the key events to pass through. Otherwise, +-- we intercept things like "q" (for quit) and Space (so that +-- we can restrict file selection to at most one). +handleFBEvent :: + BrickEvent Name AppEvent -> + EventM Name AppState () +handleFBEvent ev = do + fb <- use $ uiState . uiLaunchConfig . controls . fileBrowser . fbWidget + let isSearching = fileBrowserIsSearching fb + case (isSearching, ev) of + (False, Key V.KEsc) -> closeModal + (False, CharKey 'q') -> closeModal + (False, ControlChar 'q') -> closeModal + -- Intercept the "space" key so that it cannot be used to select files + -- (see note below). + (False, CharKey ' ') -> return () + (_, VtyEvent e) -> do + (shouldClose, maybeSingleFile) <- Brick.zoom (uiState . uiLaunchConfig . controls . fileBrowser . fbWidget) $ do + handleFileBrowserEvent e + -- If the browser has a selected file after handling the + -- event (because the user pressed Enter), close the dialog. + case e of + V.EvKey V.KEnter [] -> do + b' <- get + case FB.fileBrowserSelection b' of + [] -> return (False, Nothing) + -- We only allow one file to be selected + -- by closing immediately. + -- This is a hack illustrated in the Brick FileBrowser demo: + -- https://github.com/jtdaugherty/brick/blob/4b40476d5d58c40720170d21503c11596bc9ee39/programs/FileBrowserDemo.hs#L68-L69 + -- It is not foolproof on its own, so we also intercept + -- the "Space" key above. + xs -> return (True, FB.fileInfoFilePath <$> listToMaybe xs) + -- NOTE: The "Space" key also selects a file. + -- Apparently, even when directories are specified as + -- non-selectable via "FB.selectNonDirectories", the internal state + -- of the FileBrowser dialog + -- briefly adds a directory to its "fileBrowserSelection" list + -- when the "space" key is pressed. + -- So it is not enough to simply check whether the selection list + -- is nonempty after *any* keypress; we specifically have to listen for "Enter". + -- + -- WARNING: There is still a bug when one presses the "space" key to mark + -- a directory, then presses "Enter" right afterward. + -- The directory will get selected, and then swarm will crash. + -- This is why we prevent the Space key from being handled by the FileBrowser + -- unless we are in file searching mode. + _ -> return (False, Nothing) + + when shouldClose $ do + uiState . uiLaunchConfig . controls . fileBrowser . maybeSelectedFile .= maybeSingleFile + closeModal + _ -> return () + where + closeModal = Brick.zoom (uiState . uiLaunchConfig) $ do + controls . fileBrowser . fbIsDisplayed .= False + cacheValidatedInputs + +handleLaunchOptionsEvent :: + ScenarioInfoPair -> + BrickEvent Name AppEvent -> + EventM Name AppState () +handleLaunchOptionsEvent siPair = \case + Key V.KBackTab -> + uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusPrev + Key V.KUp -> + uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusPrev + CharKey '\t' -> + uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusNext + Key V.KDown -> + uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusNext + MouseDown n _ _ _ -> + case n of + ScenarioConfigControl (ScenarioConfigPanelControl x) -> do + uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusSetCurrent n + activateFocusedControl x + _ -> return () + CharKey ' ' -> activateControl + Key V.KEnter -> activateControl + Key V.KEsc -> closeModal + CharKey 'q' -> closeModal + ControlChar 'q' -> closeModal + ev -> do + fr <- use $ uiState . uiLaunchConfig . controls . scenarioConfigFocusRing + case focusGetCurrent fr of + Just (ScenarioConfigControl (ScenarioConfigPanelControl SeedSelector)) -> Brick.zoom (uiState . uiLaunchConfig) $ do + Brick.zoom (controls . seedValueEditor) (handleEditorEvent ev) + cacheValidatedSeedInput + _ -> return () + where + activateControl = do + fr <- use $ uiState . uiLaunchConfig . controls . scenarioConfigFocusRing + case focusGetCurrent fr of + Just (ScenarioConfigControl (ScenarioConfigPanelControl item)) -> + activateFocusedControl item + _ -> return () + + activateFocusedControl item = case item of + SeedSelector -> return () + ScriptSelector -> Brick.zoom (uiState . uiLaunchConfig . controls . fileBrowser) $ do + maybeSingleFile <- use maybeSelectedFile + configuredFB <- initFileBrowserWidget maybeSingleFile + fbWidget .= configuredFB + fbIsDisplayed .= True + StartGameButton -> do + params <- use $ uiState . uiLaunchConfig . editingParams + let eitherLaunchParams = toValidatedParams params + forM_ eitherLaunchParams $ \launchParams -> do + closeModal + startGameWithSeed siPair launchParams + + closeModal = uiState . uiLaunchConfig . controls . isDisplayedFor .= Nothing diff --git a/src/swarm-tui/Swarm/TUI/Launch/Model.hs b/src/swarm-tui/Swarm/TUI/Launch/Model.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Launch/Model.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types for representing state of the launch dialog, +-- along with conversion functions for validated launch parameters. +module Swarm.TUI.Launch.Model where + +import Brick.Focus qualified as Focus +import Brick.Widgets.Edit +import Brick.Widgets.FileBrowser qualified as FB +import Control.Carrier.Throw.Either (runThrow) +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.Game.State (LaunchParams, ValidatedLaunchParams, getRunCodePath, parseCodeFile) +import Swarm.Language.Pretty (prettyText) +import Swarm.TUI.Model.Name +import Swarm.Util.Effect (withThrow) + +-- | Use this to store error messages +-- on individual fields +type EditingLaunchParams = LaunchParams (Either Text) + +toSerializableParams :: ValidatedLaunchParams -> SerializableLaunchParams +toSerializableParams (LaunchParams seedValue (Identity codeToRun)) = + LaunchParams seedValue $ pure $ getRunCodePath =<< codeToRun + +fromSerializableParams :: SerializableLaunchParams -> IO EditingLaunchParams +fromSerializableParams (LaunchParams (Identity maybeSeedValue) (Identity maybeCodePath)) = do + eitherCode <- + runThrow . withThrow (prettyText @SystemFailure) $ + traverse parseCodeFile maybeCodePath + return $ LaunchParams (Right maybeSeedValue) eitherCode + +data FileBrowserControl = FileBrowserControl + { _fbWidget :: FB.FileBrowser Name + , _maybeSelectedFile :: Maybe FilePath + , _fbIsDisplayed :: Bool + } + +makeLenses ''FileBrowserControl + +-- | UI elements to configure scenario launch options +data LaunchControls = LaunchControls + { _fileBrowser :: FileBrowserControl + , _seedValueEditor :: Editor Text Name + , _scenarioConfigFocusRing :: Focus.FocusRing Name + , _isDisplayedFor :: Maybe ScenarioInfoPair + } + +makeLenses ''LaunchControls + +-- | UI elements to configure scenario launch options +data LaunchOptions = LaunchOptions + { _controls :: LaunchControls + , _editingParams :: EditingLaunchParams + } + +makeLenses ''LaunchOptions diff --git a/src/swarm-tui/Swarm/TUI/Launch/Prep.hs b/src/swarm-tui/Swarm/TUI/Launch/Prep.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Launch/Prep.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- HLINT ignore "Use <$>" -} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Prepares and validates scenario launch parameters +module Swarm.TUI.Launch.Prep where + +import Brick (EventM) +import Brick.Focus qualified as Focus +import Brick.Widgets.Edit +import Brick.Widgets.FileBrowser qualified as FB +import Control.Arrow (left) +import Control.Carrier.Throw.Either (runThrow) +import Control.Lens ((.=), (^.)) +import Control.Monad.IO.Class (MonadIO, liftIO) +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.Game.State (ValidatedLaunchParams, getRunCodePath, parseCodeFile) +import Swarm.Game.World.Gen (Seed) +import Swarm.Language.Pretty (prettyText) +import Swarm.TUI.Launch.Model +import Swarm.TUI.Model.Name +import Swarm.Util.Effect (withThrow) +import System.FilePath (takeDirectory) +import Text.Read (readEither) + +swarmLangFileExtension :: String +swarmLangFileExtension = "sw" + +toValidatedParams :: EditingLaunchParams -> Either T.Text ValidatedLaunchParams +toValidatedParams (LaunchParams eitherSeedVal eitherInitialCode) = do + maybeSeed <- eitherSeedVal + maybeParsedCode <- eitherInitialCode + return $ LaunchParams (pure maybeSeed) (pure maybeParsedCode) + +parseSeedInput :: Editor T.Text Name -> Either T.Text (Maybe Seed) +parseSeedInput seedEditor = + if T.null seedFieldText + then Right Nothing + else + fmap Just + . left T.pack + . readEither + . T.unpack + $ seedFieldText + where + seedFieldText = mconcat $ getEditContents seedEditor + +parseWidgetParams :: LaunchControls -> IO EditingLaunchParams +parseWidgetParams (LaunchControls (FileBrowserControl _fb maybeSelectedScript _) seedEditor _ _) = do + eitherParsedCode <- + runThrow . withThrow (prettyText @SystemFailure) $ + traverse parseCodeFile maybeSelectedScript + return $ LaunchParams eitherMaybeSeed eitherParsedCode + where + eitherMaybeSeed = parseSeedInput seedEditor + +makeFocusRingWith :: [ScenarioConfigPanelFocusable] -> Focus.FocusRing Name +makeFocusRingWith = Focus.focusRing . map (ScenarioConfigControl . ScenarioConfigPanelControl) + +initEditorWidget :: T.Text -> Editor T.Text Name +initEditorWidget = + editorText + (ScenarioConfigControl $ ScenarioConfigPanelControl SeedSelector) + (Just 1) -- only allow a single line + +-- | Called before any particular scenario is selected, so we +-- supply some 'Nothing's as defaults to the 'ValidatedLaunchParams'. +initConfigPanel :: IO LaunchOptions +initConfigPanel = do + -- NOTE: This is kind of pointless, because we must re-instantiate the 'FB.FileBrowser' + -- when it is first displayed, anyway. + fb <- + FB.newFileBrowser + FB.selectNonDirectories + (ScenarioConfigControl $ ScenarioConfigPanelControl ScriptSelector) + Nothing -- Initial working directory to display + return $ + LaunchOptions + (LaunchControls (FileBrowserControl fb Nothing False) myForm ring Nothing) + (LaunchParams (Right Nothing) (Right Nothing)) + where + myForm = initEditorWidget "" + ring = makeFocusRingWith enumerate + +initFileBrowserWidget :: + (MonadIO m) => + Maybe FilePath -> + m (FB.FileBrowser Name) +initFileBrowserWidget maybePlayedScript = do + fb <- + liftIO $ + FB.newFileBrowser + FB.selectNonDirectories + (ScenarioConfigControl $ ScenarioConfigPanelControl ScriptSelector) + (takeDirectory <$> maybePlayedScript) -- Initial working directory to display + return $ FB.setFileBrowserEntryFilter (Just $ FB.fileExtensionMatch swarmLangFileExtension) fb + +-- | If the selected scenario has been launched with an initial script before, +-- set the file browser to initially open that script's directory. +-- Then set the launch dialog to be displayed. +-- +-- Note that the 'FB.FileBrowser' widget normally allows multiple selections ("marked" files). +-- However, there do not exist any public "setters" set the marked files, so we have +-- some workarounds: +-- +-- * When the user marks the first file, we immediately close the 'FB.FileBrowser' widget. +-- * We re-instantiate the 'FB.FileBrowser' from scratch every time it is opened, so that +-- it is not possible to mark more than one file. +-- * 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 -> + EventM Name LaunchOptions () +prepareLaunchDialog siPair@(_, si) = do + let serializableLaunchParams = getLaunchParams $ si ^. scenarioStatus + launchEditingParams <- liftIO $ fromSerializableParams serializableLaunchParams + editingParams .= launchEditingParams + + let maybePlayedScript = case initialCode launchEditingParams of + Right codeToRun -> getRunCodePath =<< codeToRun + Left _ -> Nothing + + controls . fileBrowser . maybeSelectedFile .= maybePlayedScript + controls . seedValueEditor .= initEditorWidget (maybe "" (T.pack . show) $ runIdentity $ seedVal serializableLaunchParams) + controls . isDisplayedFor .= Just siPair diff --git a/src/swarm-tui/Swarm/TUI/Launch/View.hs b/src/swarm-tui/Swarm/TUI/Launch/View.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Launch/View.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Rendering of the scenario launch configuration dialog. +module Swarm.TUI.Launch.View where + +import Brick +import Brick.Focus +import Brick.Forms qualified as BF +import Brick.Widgets.Border +import Brick.Widgets.Center (centerLayer, hCenter) +import Brick.Widgets.Edit +import Brick.Widgets.Edit qualified as E +import Brick.Widgets.FileBrowser qualified as FB +import Control.Exception qualified as E +import Control.Lens +import Data.Either (isRight) +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.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) + +drawFileBrowser :: FB.FileBrowser Name -> Widget Name +drawFileBrowser b = + centerLayer $ hLimit 50 $ ui <=> help + where + ui = + vLimit 15 $ + borderWithLabel (txt "Choose a file") $ + FB.renderFileBrowser True b + + footerRows = + map + (withDefAttr dimAttr . hCenter . txt) + [ "Up/Down: navigate" + , "/: search, Ctrl-C or Esc: cancel search" + , "Enter: change directory or select file" + , "Esc: quit" + ] + + help = + padTop (Pad 1) $ + vBox $ + [ case FB.fileBrowserException b of + Nothing -> emptyWidget + Just e -> + hCenter + . withDefAttr BF.invalidFormInputAttr + . txt + . T.pack + $ E.displayException e + ] + <> footerRows + +optionDescription :: ScenarioConfigPanelFocusable -> Maybe Text +optionDescription = \case + SeedSelector -> Just "Leaving this field blank will use the default seed for the scenario." + ScriptSelector -> Just "Selecting a script to be run upon start permits eligibility for code size scoring." + StartGameButton -> Nothing + +drawLaunchConfigPanel :: LaunchOptions -> [Widget Name] +drawLaunchConfigPanel (LaunchOptions lc launchParams) = + addFileBrowser [panelWidget] + where + validatedOptions = toValidatedParams launchParams + LaunchControls (FileBrowserControl fb _ isFbDisplayed) seedEditor ring displayedFor = lc + addFileBrowser = + if isFbDisplayed + then (drawFileBrowser fb :) + else id + + getFocusedConfigPanel :: Maybe ScenarioConfigPanelFocusable + getFocusedConfigPanel = case focusGetCurrent ring of + Just (ScenarioConfigControl (ScenarioConfigPanelControl x)) -> Just x + _ -> Nothing + + isFocused = (== getFocusedConfigPanel) . Just + + highlightIfFocused x = + if isFocused x + then withDefAttr highlightAttr + else id + + mkButton name label = + clickable (ScenarioConfigControl $ ScenarioConfigPanelControl name) + . highlightIfFocused name + . withAttr boldAttr + $ txt label + + mkSeedEditorWidget = + hLimit 10 $ + overrideAttr E.editFocusedAttr customEditFocusedAttr $ + renderEditor (txt . mconcat) (isFocused SeedSelector) seedEditor + seedEntryWidget = case seedVal launchParams of + Left _ -> mkSeedEditorWidget + Right x -> mkSeedEntryWidget x + + scenarioSeedText = + maybe "random" show $ + view (scenarioLandscape . scenarioSeed) . fst =<< displayedFor + + mkSeedEntryWidget seedEntryContent = + if isFocused SeedSelector + then mkSeedEditorWidget + else case seedEntryContent of + Just x -> str $ show x + Nothing -> + withDefAttr dimAttr $ + txt $ + T.unwords + [ "scenario default" + , parens $ T.pack scenarioSeedText + ] + + unspecifiedFileMessage = + if isFocused ScriptSelector + then str "<[Enter] to select>" + else withDefAttr dimAttr $ str "" + + fileEntryWidget = case initialCode launchParams of + Left _ -> str "" + Right maybeFilepath -> + maybe + unspecifiedFileMessage + (withEllipsis Beginning . T.pack) + (getRunCodePath =<< maybeFilepath) + + panelWidget = + centerLayer + . borderWithLabel (str " Configure scenario launch ") + . hLimit 60 + . padAll 1 + $ vBox widgetMembers + where + startButton = + hCenter . mkButton StartGameButton $ + T.unwords + [ ">>" + , "Launch with these settings" + , "<<" + ] + + widgetMembers = + [ controlsBox + , infoBox + , if isRight validatedOptions then startButton else emptyWidget + ] + + formatInfo header content = + hBox + [ padLeft (Pad 6) . withAttr boldAttr . txt $ brackets header + , padLeft (Pad 1) $ txtWrap content + ] + + infoContent = case validatedOptions of + Left errmsg -> withDefAttr BF.invalidFormInputAttr $ formatInfo "Error" errmsg + Right _ -> case optionDescription =<< getFocusedConfigPanel of + Just desc -> withDefAttr dimAttr $ formatInfo "Info" desc + Nothing -> str " " + + infoBox = + vLimit 4 + . padBottom Max + . padRight (Pad 2) + $ infoContent + + padControl widgetName label widgetObj = + padBottom (Pad 1) $ + padLeft (Pad 2) $ + hBox + [ mkButton widgetName (label <> ": ") + , widgetObj + ] + + controlsBox = + vBox + [ padControl ScriptSelector "Script" fileEntryWidget + , padControl SeedSelector "Seed" seedEntryWidget + ] diff --git a/src/swarm-tui/Swarm/TUI/List.hs b/src/swarm-tui/Swarm/TUI/List.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/List.hs @@ -0,0 +1,43 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A special modified version of 'Brick.Widgets.List.handleListEvent' +-- to deal with skipping over separators. +module Swarm.TUI.List ( + handleListEventWithSeparators, + isValidListMovement, +) where + +import Brick (EventM) +import Brick.Widgets.List qualified as BL +import Brick.Widgets.List.Skip +import Graphics.Vty qualified as V + +-- | Handle a list event, taking an extra predicate to identify which +-- list elements are separators; separators will be skipped if +-- possible. +handleListEventWithSeparators :: + (Foldable t, BL.Splittable t, Ord n, Searchable t) => + V.Event -> + -- | Is this element a separator? + (e -> Bool) -> + EventM n (BL.GenericList n t e) () +handleListEventWithSeparators e isSep = + listSkip isSep (movement e) + +-- | A movement is considered legitimate when a key event +-- results in @Move@ action. +isValidListMovement :: V.Event -> Bool +isValidListMovement e = movement e /= NoMove + +movement :: V.Event -> Move +movement = \case + V.EvKey V.KUp [] -> Move One Bwd + V.EvKey (V.KChar 'k') [] -> Move One Bwd + V.EvKey V.KDown [] -> Move One Fwd + V.EvKey (V.KChar 'j') [] -> Move One Fwd + V.EvKey V.KHome [] -> Move Most Bwd + V.EvKey V.KEnd [] -> Move Most Fwd + V.EvKey V.KPageDown [] -> Move Page Fwd + V.EvKey V.KPageUp [] -> Move Page Bwd + _ -> NoMove diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Application state for the @brick@-based Swarm TUI. +module Swarm.TUI.Model ( + -- * Custom UI label types + -- $uilabel + AppEvent (..), + WebCommand (..), + FocusablePanel (..), + Name (..), + + -- * Menus and dialogs + ModalType (..), + ScenarioOutcome (..), + Button (..), + ButtonAction (..), + Modal (..), + modalType, + modalDialog, + MainMenuEntry (..), + mainMenu, + Menu (..), + _NewGameMenu, + mkScenarioList, + mkNewGameMenu, + + -- * UI state + + -- ** Inventory + InventoryListEntry (..), + _Separator, + _InventoryEntry, + _EquippedEntry, + + -- ** Updating + populateInventoryList, + infoScroll, + modalScroll, + replScroll, + + -- ** Utility + logEvent, + SwarmKeyDispatcher, + KeyEventHandlingState (KeyEventHandlingState), + SwarmKeyDispatchers (..), + keyConfig, + keyDispatchers, + + -- * App state + AppState (AppState), + gameState, + uiState, + keyEventHandling, + runtimeState, + + -- ** Initialization + AppOpts (..), + defaultAppOpts, + + -- *** Re-exported types used in options + ColorMode (..), + + -- ** Utility + focusedItem, + focusedEntity, + nextScenario, +) where + +import Brick (EventM, ViewportScroll, viewportScroll) +import Brick.Keybindings as BK +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (from, (<.>)) +import Control.Monad ((>=>)) +import Control.Monad.State (MonadState) +import Data.List (findIndex) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) +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.Entity as E +import Swarm.Game.Ingredients +import Swarm.Game.Robot +import Swarm.Game.Scenario.Status +import Swarm.Game.ScenarioInfo (_SISingle) +import Swarm.Game.State +import Swarm.Game.State.Runtime +import Swarm.Game.State.Substate +import Swarm.Game.Tick (TickNumber (..)) +import Swarm.Game.World.Gen (Seed) +import Swarm.Log +import Swarm.TUI.Inventory.Sorting +import Swarm.TUI.Model.Event (SwarmEvent) +import Swarm.TUI.Model.Menu +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.UI +import Swarm.Util.Lens (makeLensesNoSigs) +import Swarm.Version (NewReleaseFailure) +import Text.Fuzzy qualified as Fuzzy + +------------------------------------------------------------ +-- Custom UI label types +------------------------------------------------------------ + +-- $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. +data AppEvent + = Frame + | Web WebCommand + | UpstreamVersion (Either NewReleaseFailure String) + deriving (Show) + +infoScroll :: ViewportScroll Name +infoScroll = viewportScroll InfoViewport + +modalScroll :: ViewportScroll Name +modalScroll = viewportScroll ModalViewport + +replScroll :: ViewportScroll Name +replScroll = viewportScroll REPLViewport + +-------------------------------------------------- +-- Utility + +-- | Simply log to the runtime event log. +logEvent :: LogSource -> Severity -> Text -> Text -> Notifications LogEntry -> Notifications LogEntry +logEvent src sev who msg el = + el + & notificationsCount %~ succ + & notificationsContent %~ (l :) + where + l = LogEntry (TickNumber 0) src sev who msg + +data KeyEventHandlingState = KeyEventHandlingState + { _keyConfig :: KeyConfig SwarmEvent + , _keyDispatchers :: SwarmKeyDispatchers + } + +type SwarmKeyDispatcher = KeyDispatcher SwarmEvent (EventM Name AppState) + +data SwarmKeyDispatchers = SwarmKeyDispatchers + { mainGameDispatcher :: SwarmKeyDispatcher + , replDispatcher :: SwarmKeyDispatcher + , worldDispatcher :: SwarmKeyDispatcher + , robotDispatcher :: SwarmKeyDispatcher + } + +-- ---------------------------------------------------------------------------- +-- APPSTATE -- +-- ---------------------------------------------------------------------------- + +-- | The 'AppState' just stores together the other states. +-- +-- This is so you can use a smaller state when e.g. writing some game logic +-- 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 + , _uiState :: UIState + , _keyEventHandling :: KeyEventHandlingState + , _runtimeState :: RuntimeState + } + +------------------------------------------------------------ +-- Functions for updating the UI state +------------------------------------------------------------ + +-- | Given the focused robot, populate the UI inventory list in the info +-- panel with information about its inventory. +populateInventoryList :: (MonadState UIInventory m) => Maybe Robot -> m () +populateInventoryList Nothing = uiInventoryList .= Nothing +populateInventoryList (Just r) = do + mList <- preuse $ uiInventoryList . _Just . _2 + showZero <- use uiShowZero + sortOptions <- use uiInventorySort + search <- use uiInventorySearch + let mkInvEntry (n, e) = InventoryEntry n e + mkInstEntry (_, e) = EquippedEntry e + itemList isInventoryDisplay mk label = + (\case [] -> []; xs -> Separator label : xs) + . map mk + . sortInventory sortOptions + . filter ((&&) <$> matchesSearch <*> shouldDisplay) + . elems + where + -- Display items if we have a positive number of them, or they + -- aren't an equipped device. In other words we don't need to + -- display equipped devices twice unless we actually have some + -- in our inventory in addition to being equipped. + shouldDisplay (n, e) = + n > 0 + || isInventoryDisplay + && showZero + && not ((r ^. equippedDevices) `E.contains` e) + + matchesSearch :: (Count, Entity) -> Bool + matchesSearch (_, e) = maybe (const True) Fuzzy.test search (e ^. E.entityName) + + items = + (r ^. robotInventory . to (itemList True mkInvEntry "Compendium")) + ++ (r ^. equippedDevices . to (itemList False mkInstEntry "Equipped devices")) + + -- Attempt to keep the selected element steady. + sel = mList >>= BL.listSelectedElement -- Get the currently selected element+index. + idx = case sel of + -- If there is no currently selected element, just focus on + -- index 1 (not 0, to avoid the separator). + Nothing -> 1 + -- Otherwise, try to find the same entry in the list; + -- if it's not there, keep the index the same. + Just (selIdx, InventoryEntry _ e) -> + fromMaybe selIdx (findIndex ((== Just e) . preview (_InventoryEntry . _2)) items) + Just (selIdx, EquippedEntry e) -> + fromMaybe selIdx (findIndex ((== Just e) . preview _EquippedEntry) items) + Just (selIdx, _) -> selIdx + + -- Create the new list, focused at the desired index. + lst = BL.listMoveTo idx $ BL.list InventoryList (V.fromList items) 1 + + -- Finally, populate the newly created list in the UI, and remember + -- the hash of the current robot. + uiInventoryList .= Just (r ^. inventoryHash, lst) + +------------------------------------------------------------ +-- App state (= UI state + game state) initialization +------------------------------------------------------------ + +-- | Command-line options for configuring the app. +data AppOpts = AppOpts + { userSeed :: Maybe Seed + -- ^ Explicit seed chosen by the user. + , userScenario :: Maybe FilePath + -- ^ Scenario the user wants to play. + , scriptToRun :: Maybe FilePath + -- ^ Code to be run on base. + , autoPlay :: Bool + -- ^ Automatically run the solution defined in the scenario file + , speed :: Int + -- ^ Initial game speed (logarithm) + , cheatMode :: Bool + -- ^ Should cheat mode be enabled? + , colorMode :: Maybe ColorMode + -- ^ What colour mode should be used? + , userWebPort :: Maybe Port + -- ^ Explicit port on which to run the web API + , repoGitInfo :: Maybe GitInfo + -- ^ Information about the Git repository (not present in release). + } + +-- | A default/empty 'AppOpts' record. +defaultAppOpts :: AppOpts +defaultAppOpts = + AppOpts + { userSeed = Nothing + , userScenario = Nothing + , scriptToRun = Nothing + , autoPlay = False + , speed = defaultInitLgTicksPerSecond + , cheatMode = False + , 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 KeyEventHandlingState + +makeLensesNoSigs ''KeyEventHandlingState + +-- | Keybindings (possibly customized by player) for 'SwarmEvent's. +keyConfig :: Lens' KeyEventHandlingState (KeyConfig SwarmEvent) + +-- | Dispatchers that will call handler on key combo. +keyDispatchers :: Lens' KeyEventHandlingState SwarmKeyDispatchers + +-------------------------------------------------- +-- Lenses for AppState + +makeLensesNoSigs ''AppState + +-- | The 'GameState' record. +gameState :: Lens' AppState GameState + +-- | The 'UIState' record. +uiState :: Lens' AppState UIState + +-- | The key event handling configuration. +keyEventHandling :: Lens' AppState KeyEventHandlingState + +-- | The 'RuntimeState' record +runtimeState :: Lens' AppState RuntimeState + +-------------------------------------------------- +-- Utility functions + +-- | Get the currently focused 'InventoryListEntry' from the robot +-- info panel (if any). +focusedItem :: AppState -> Maybe InventoryListEntry +focusedItem s = do + list <- s ^? uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 + (_, entry) <- BL.listSelectedElement list + return entry + +-- | Get the currently focused entity from the robot info panel (if +-- any). This is just like 'focusedItem' but forgets the +-- distinction between plain inventory items and equipped devices. +focusedEntity :: AppState -> Maybe Entity +focusedEntity = + focusedItem >=> \case + Separator _ -> Nothing + InventoryEntry _ e -> Just e + EquippedEntry e -> Just e diff --git a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs @@ -0,0 +1,50 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Collection of helper functions for managing achievements in other controllers. +module Swarm.TUI.Model.Achievements ( + attainAchievement, + attainAchievement', + popupAchievement, +) where + +import Control.Lens hiding (from, (<.>)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState) +import Data.Map qualified as M +import Data.Maybe (isNothing) +import Data.Time (ZonedTime, getZonedTime) +import Swarm.Game.Achievement.Attainment +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Achievement.Persistence +import Swarm.TUI.Model +import Swarm.TUI.Model.Popup (Popup (AchievementPopup), addPopup) +import Swarm.TUI.Model.UI + +attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m () +attainAchievement a = do + currentTime <- liftIO getZonedTime + attainAchievement' currentTime Nothing a + +attainAchievement' :: + (MonadIO m, MonadState AppState m) => + ZonedTime -> + Maybe FilePath -> + CategorizedAchievement -> + m () +attainAchievement' t p a = do + mAttainment <- use $ uiState . uiAchievements . at a + when (isNothing mAttainment) $ popupAchievement a + + (uiState . uiAchievements) + %= M.insertWith + (<>) + a + (Attainment a p t) + newAchievements <- use $ uiState . uiAchievements + liftIO $ saveAchievementsInfo $ M.elems newAchievements + +-- | Generate a popup for an achievement. +popupAchievement :: MonadState AppState m => CategorizedAchievement -> m () +popupAchievement ach = uiState . uiPopups %= addPopup (AchievementPopup ach) diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sum types representing the Swarm events +-- abstracted away from keybindings. +module Swarm.TUI.Model.Event ( + SwarmEvent (..), + MainEvent (..), + REPLEvent (..), + WorldEvent (..), + RobotEvent (..), + swarmEvents, + defaultSwarmBindings, +) where + +import Brick.Keybindings +import Control.Arrow ((&&&)) +import Data.Bifunctor (first) +import Data.List.Extra (enumerate) +import Data.Text (Text) +import Graphics.Vty qualified as V +import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..), directionSyntax) + +-- See Note [how Swarm event handlers work] + +data SwarmEvent + = Main MainEvent + | REPL REPLEvent + | World WorldEvent + | Robot RobotEvent + deriving (Eq, Ord, Show) + +swarmEvents :: KeyEvents SwarmEvent +swarmEvents = + keyEvents $ + concat + [ embed Main mainEvents + , embed REPL replEvents + , embed World worldPanelEvents + , embed Robot robotPanelEvents + ] + where + embed f = map (fmap f) . keyEventsList + +defaultSwarmBindings :: [(SwarmEvent, [Binding])] +defaultSwarmBindings = + concat + [ embed Main defaultMainBindings + , embed REPL defaultReplBindings + , embed World defaultWorldPanelBindings + , embed Robot defaultRobotPanelBindings + ] + where + embed = map . first + +-- ---------------------------------------------- +-- MAIN EVENTS +-- ---------------------------------------------- + +-- | Main abstract keybinding events while running the game itself. +-- +-- See 'Swarm.TUI.Controller.MainEventHandler.'. +data MainEvent + = QuitEvent + | ViewHelpEvent + | ViewRobotsEvent + | ViewRecipesEvent + | ViewCommandsEvent + | ViewMessagesEvent + | ViewStructuresEvent + | ViewGoalEvent + | HideRobotsEvent + | ShowCESKDebugEvent + | PauseEvent + | RunSingleTickEvent + | IncreaseTpsEvent + | DecreaseTpsEvent + | FocusWorldEvent + | FocusRobotEvent + | FocusREPLEvent + | FocusInfoEvent + | ToggleCreativeModeEvent + | ToggleWorldEditorEvent + | ToggleREPLVisibilityEvent + deriving (Eq, Ord, Show, Enum, Bounded) + +mainEvents :: KeyEvents MainEvent +mainEvents = allKeyEvents $ \case + QuitEvent -> "quit" + ViewHelpEvent -> "view help" + ViewRobotsEvent -> "view robots" + ViewRecipesEvent -> "view recipes" + ViewCommandsEvent -> "view commands" + ViewMessagesEvent -> "view messages" + ViewStructuresEvent -> "view structures" + ViewGoalEvent -> "view goal" + HideRobotsEvent -> "hide robots" + ShowCESKDebugEvent -> "debug CESK" + PauseEvent -> "pause" + RunSingleTickEvent -> "run single tick" + IncreaseTpsEvent -> "increse TPS" + DecreaseTpsEvent -> "decrease TPS" + FocusWorldEvent -> "focus World" + FocusRobotEvent -> "focus Robot" + FocusREPLEvent -> "focus REPL" + FocusInfoEvent -> "focus Info" + ToggleCreativeModeEvent -> "creative mode" + ToggleWorldEditorEvent -> "world editor" + ToggleREPLVisibilityEvent -> "toggle REPL" + +defaultMainBindings :: [(MainEvent, [Binding])] +defaultMainBindings = allBindings $ \case + QuitEvent -> [ctrl 'q'] + ViewHelpEvent -> [fn 1] + ViewRobotsEvent -> [fn 2] + ViewRecipesEvent -> [fn 3] + ViewCommandsEvent -> [fn 4] + ViewMessagesEvent -> [fn 5] + ViewStructuresEvent -> [fn 6] + ViewGoalEvent -> [ctrl 'g'] + HideRobotsEvent -> [meta 'h'] + ShowCESKDebugEvent -> [meta 'd'] + PauseEvent -> [ctrl 'p'] + RunSingleTickEvent -> [ctrl 'o'] + IncreaseTpsEvent -> [ctrl 'x'] + DecreaseTpsEvent -> [ctrl 'z'] + FocusWorldEvent -> [meta 'w'] + FocusRobotEvent -> [meta 'e'] + FocusREPLEvent -> [meta 'r'] + FocusInfoEvent -> [meta 't'] + ToggleCreativeModeEvent -> [ctrl 'v'] + ToggleWorldEditorEvent -> [] + ToggleREPLVisibilityEvent -> [meta ','] + +-- ---------------------------------------------- +-- REPL EVENTS +-- ---------------------------------------------- + +-- | REPL abstract keybinding events. +-- +-- See 'Swarm.TUI.Controller.REPLEventHandler'. +data REPLEvent + = CancelRunningProgramEvent + | TogglePilotingModeEvent + | ToggleCustomKeyHandlingEvent + deriving (Eq, Ord, Show, Enum, Bounded) + +replEvents :: KeyEvents REPLEvent +replEvents = allKeyEvents $ \case + CancelRunningProgramEvent -> "cancel running program" + ToggleCustomKeyHandlingEvent -> "toggle custom key handling" + TogglePilotingModeEvent -> "toggle piloting mode" + +defaultReplBindings :: [(REPLEvent, [Binding])] +defaultReplBindings = allBindings $ \case + CancelRunningProgramEvent -> [ctrl 'c', bind V.KEsc] + TogglePilotingModeEvent -> [meta 'p'] + ToggleCustomKeyHandlingEvent -> [meta 'k'] + +-- ---------------------------------------------- +-- REPL EVENTS +-- ---------------------------------------------- + +data WorldEvent + = ViewBaseEvent + | ShowFpsEvent + | MoveViewEvent AbsoluteDir + deriving (Eq, Ord, Show) + +instance Enum WorldEvent where + fromEnum = \case + ViewBaseEvent -> 0 + ShowFpsEvent -> 1 + MoveViewEvent d -> 2 + fromEnum d + toEnum = \case + 0 -> ViewBaseEvent + 1 -> ShowFpsEvent + n -> MoveViewEvent . toEnum $ n - 2 + +instance Bounded WorldEvent where + minBound = ViewBaseEvent + maxBound = MoveViewEvent maxBound + +worldPanelEvents :: KeyEvents WorldEvent +worldPanelEvents = allKeyEvents $ \case + ViewBaseEvent -> "view base" + ShowFpsEvent -> "show fps" + MoveViewEvent d -> "move view " <> directionSyntax (DAbsolute d) + +defaultWorldPanelBindings :: [(WorldEvent, [Binding])] +defaultWorldPanelBindings = allBindings $ \case + ViewBaseEvent -> [bind 'c'] + ShowFpsEvent -> [bind 'f'] + MoveViewEvent DWest -> [bind V.KLeft, bind 'h'] + MoveViewEvent DSouth -> [bind V.KDown, bind 'j'] + MoveViewEvent DNorth -> [bind V.KUp, bind 'k'] + MoveViewEvent DEast -> [bind V.KRight, bind 'l'] + +-- ---------------------------------------------- +-- ROBOT EVENTS +-- ---------------------------------------------- + +data RobotEvent + = MakeEntityEvent + | ShowZeroInventoryEntitiesEvent + | CycleInventorySortEvent + | SwitchInventorySortDirection + | SearchInventoryEvent + deriving (Eq, Ord, Show, Enum, Bounded) + +robotPanelEvents :: KeyEvents RobotEvent +robotPanelEvents = allKeyEvents $ \case + MakeEntityEvent -> "make entity" + ShowZeroInventoryEntitiesEvent -> "show zero inventory entities" + CycleInventorySortEvent -> "cycle inventory sort" + SwitchInventorySortDirection -> "switch inventory direction" + SearchInventoryEvent -> "search inventory" + +defaultRobotPanelBindings :: [(RobotEvent, [Binding])] +defaultRobotPanelBindings = allBindings $ \case + MakeEntityEvent -> [bind 'm'] + ShowZeroInventoryEntitiesEvent -> [bind '0'] + CycleInventorySortEvent -> [bind ';'] + SwitchInventorySortDirection -> [bind ':'] + SearchInventoryEvent -> [bind '/'] + +-- ---------------- +-- Helper methods + +allKeyEvents :: (Ord e, Bounded e, Enum e) => (e -> Text) -> KeyEvents e +allKeyEvents f = keyEvents $ map (f &&& id) enumerate + +allBindings :: (Bounded e, Enum e) => (e -> [Binding]) -> [(e, [Binding])] +allBindings f = map (\e -> (e, f e)) enumerate diff --git a/src/swarm-tui/Swarm/TUI/Model/Goal.hs b/src/swarm-tui/Swarm/TUI/Model/Goal.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Goal.hs @@ -0,0 +1,125 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Load and show Swarm keybindings. +-- +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Model.KeyBindings ( + initKeyHandlingState, + KeybindingPrint (..), + showKeybindings, + handlerNameKeysDescription, +) where + +import Brick +import Brick.Keybindings as BK +import Control.Carrier.Lift (runM) +import Control.Carrier.Throw.Either (runThrow) +import Control.Effect.Accum +import Control.Effect.Lift +import Control.Effect.Throw +import Control.Lens hiding (from, (<.>)) +import Data.Bifunctor (second) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Game.Failure (Asset (..), LoadingFailure (..), SystemFailure (..)) +import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) +import Swarm.Language.Pretty (prettyText) +import Swarm.TUI.Controller.EventHandlers +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents) + +-- See Note [how Swarm event handlers work] + +loadKeybindingConfig :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m [(SwarmEvent, BindingState)] +loadKeybindingConfig = do + (iniExists, ini) <- sendIO $ getSwarmConfigIniFile False + if not iniExists + then return [] + else do + loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini + case loadedCustomBindings of + Left e -> throwError $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e) + Right bs -> pure $ fromMaybe [] bs + +initKeyHandlingState :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m KeyEventHandlingState +initKeyHandlingState = do + customBindings <- loadKeybindingConfig + let cfg = newKeyConfig swarmEvents defaultSwarmBindings customBindings + dispatchers <- createKeyDispatchers cfg + return $ KeyEventHandlingState cfg dispatchers + +data KeybindingPrint = MarkdownPrint | TextPrint | IniPrint + deriving (Eq, Ord, Show) + +showKeybindings :: KeybindingPrint -> IO Text +showKeybindings kPrint = do + bindings <- runM $ runThrow @SystemFailure initKeyHandlingState + pure $ case bindings of + Left e -> prettyText e + Right bs -> showTable kPrint (bs ^. keyConfig) keySections + where + showTable = \case + MarkdownPrint -> keybindingMarkdownTable + TextPrint -> keybindingTextTable + IniPrint -> keybindingINI + +keySections :: [(Text, [KeyEventHandler SwarmEvent (EventM Name AppState)])] +keySections = + [ ("Main game (always active)", mainEventHandlers) + , ("REPL panel", replEventHandlers) + , ("World view panel", worldEventHandlers) + , ("Robot inventory panel", robotEventHandlers) + ] + +keybindingINI :: Ord k => KeyConfig k -> [(Text, [KeyEventHandler k m])] -> Text +keybindingINI kc sections = + T.intercalate "\n" $ + "[keybindings]\n" + : "; Uncomment the assignment and set comma separated list" + : "; of keybindings or \"unbound\" on the right. See:" + : "; https://hackage.haskell.org/package/brick/docs/Brick-Keybindings-Parse.html#v:parseBinding\n" + : concatMap sectionsINI handlersData + where + handlersData = map (second $ mapMaybe handlerData) sections + handlerData h = case kehEventTrigger h of + ByKey _ -> Nothing + ByEvent k -> Just (k, handlerDescription $ kehHandler h) + section s = "\n;;;; " <> s <> "\n" + sectionsINI (s, hs) = section s : map (keyBindingEventINI kc) hs + +keyBindingEventINI :: Ord k => KeyConfig k -> (k, Text) -> Text +keyBindingEventINI kc (ev, description) = + T.unlines + [ ";; " <> description + , commentDefault <> name <> " = " <> bindingList + ] + where + commentDefault = if custom then "" else "; " + (custom, bindingList) = case lookupKeyConfigBindings kc ev of + Just Unbound -> (True, "unbound") + Just (BindingList bs) -> (True, listBindings bs) + Nothing -> + ( False + , if null (allDefaultBindings kc ev) + then "unbound" + else listBindings $ allDefaultBindings kc ev + ) + listBindings = T.intercalate "," . fmap ppBinding + name = case keyEventName (keyConfigEvents kc) ev of + Just n -> n + Nothing -> error $ "unnamed event: " <> T.unpack description + +handlerNameKeysDescription :: Ord k => KeyConfig k -> KeyEventHandler k m -> (Text, Text, Text) +handlerNameKeysDescription kc keh = (name, keys, desc) + where + desc = handlerDescription $ kehHandler keh + (name, keys) = case kehEventTrigger keh of + ByKey b -> ("(non-customizable key)", ppBinding b) + ByEvent ev -> + let name' = fromMaybe "(unnamed)" $ keyEventName (keyConfigEvents kc) ev + in case lookupKeyConfigBindings kc ev of + Nothing -> + if not (null (allDefaultBindings kc ev)) + then (name', T.intercalate "," $ ppBinding <$> allDefaultBindings kc ev) + else (name', "unbound") + Just Unbound -> + (name', "unbound") + Just (BindingList bs) -> + let result = + if not (null bs) + then T.intercalate "," $ ppBinding <$> bs + else "unbound" + in (name', result) diff --git a/src/swarm-tui/Swarm/TUI/Model/Menu.hs b/src/swarm-tui/Swarm/TUI/Model/Menu.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Menu.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sum types that represent menu options, +-- modal dialogs, and buttons. +module Swarm.TUI.Model.Menu where + +import Brick.Widgets.Dialog (Dialog) +import Brick.Widgets.List qualified as BL +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.ScenarioInfo ( + ScenarioCollection, + ScenarioInfo (..), + ScenarioInfoPair, + ScenarioItem (..), + scMap, + scenarioCollectionToList, + ) +import Swarm.Game.World.Gen (Seed) +import Swarm.TUI.Model.Name +import System.FilePath (dropTrailingPathSeparator, splitPath, takeFileName) +import Witch (into) + +------------------------------------------------------------ +-- Menus and dialogs +------------------------------------------------------------ + +data ScenarioOutcome = WinModal | LoseModal + deriving (Show, Eq) + +data ModalType + = HelpModal + | RecipesModal + | CommandsModal + | MessagesModal + | StructuresModal + | EntityPaletteModal + | TerrainPaletteModal + | RobotsModal + | ScenarioEndModal ScenarioOutcome + | QuitModal + | KeepPlayingModal + | DescriptionModal Entity + | GoalModal + deriving (Show, Eq) + +data ButtonAction + = Cancel + | KeepPlaying + | StartOver Seed ScenarioInfoPair + | QuitAction + | Next ScenarioInfoPair + +data Modal = Modal + { _modalType :: ModalType + , _modalDialog :: Dialog ButtonAction Name + } + +makeLenses ''Modal + +data MainMenuEntry + = NewGame + | Tutorial + | Achievements + | Messages + | About + | Quit + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +data Menu + = -- | We started playing directly from command line, no menu to show + NoMenu + | MainMenu (BL.List Name MainMenuEntry) + | -- | Stack of scenario item lists. INVARIANT: the currently selected + -- 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)) + | AchievementsMenu (BL.List Name CategorizedAchievement) + | MessagesMenu + | AboutMenu + +mainMenu :: MainMenuEntry -> BL.List Name MainMenuEntry +mainMenu e = BL.list MenuList (V.fromList enumerate) 1 & BL.listMoveToElement e + +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 + +------------------------------------------------------------ +-- Inventory list entries +------------------------------------------------------------ + +-- | An entry in the inventory list displayed in the info panel. We +-- can either have an entity with a count in the robot's inventory, +-- an entity equipped on the robot, or a labelled separator. The +-- purpose of the separators is to show a clear distinction between +-- the robot's /inventory/ and its /equipped devices/. +data InventoryListEntry + = Separator Text + | InventoryEntry Count Entity + | EquippedEntry Entity + deriving (Eq) + +makePrisms ''InventoryListEntry diff --git a/src/swarm-tui/Swarm/TUI/Model/Name.hs b/src/swarm-tui/Swarm/TUI/Model/Name.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Name.hs @@ -0,0 +1,117 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sum types representing the Brick names +-- for every referenceable widget. +-- +-- Nesting of name types is utilized often to simplify +-- case matching. +module Swarm.TUI.Model.Name where + +import Data.Text (Text) + +data WorldEditorFocusable + = BrushSelector + | EntitySelector + | AreaSelector + | OutputPathSelector + | MapSaveButton + | ClearEntityButton + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +data FocusablePanel + = -- | The panel containing the REPL. + REPLPanel + | -- | The panel containing the world view. + WorldPanel + | -- | The panel containing the world editor controls. + WorldEditorPanel + | -- | The panel showing robot info and inventory on the top left. + RobotPanel + | -- | The info panel on the bottom left. + InfoPanel + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +data ScenarioConfigPanel + = ScenarioConfigFileSelector + | ScenarioConfigPanelControl ScenarioConfigPanelFocusable + deriving (Eq, Ord, Show, Read) + +data ScenarioConfigPanelFocusable + = -- | The file selector for launching a scenario with a script + ScriptSelector + | SeedSelector + | StartGameButton + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +data GoalWidget + = ObjectivesList + | GoalSummary + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +data StructureWidget + = StructuresList + | StructureSummary + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +-- | Clickable buttons in modal dialogs. +data Button + = CancelButton + | KeepPlayingButton + | StartOverButton + | QuitButton + | NextButton + deriving (Eq, Ord, Show, Read, Bounded, Enum) + +-- | 'Name' represents names to uniquely identify various components +-- of the UI, such as forms, panels, caches, extents, lists, and buttons. +data Name + = FocusablePanel FocusablePanel + | -- | An individual control within the world editor panel. + WorldEditorPanelControl WorldEditorFocusable + | -- | The REPL input form. + REPLInput + | -- | The REPL history cache. + REPLHistoryCache + | -- | The render cache for the world view. + WorldCache + | -- | The cached extent for the world view. + WorldExtent + | -- | The cursor/viewCenter display in the bottom left of the World view + WorldPositionIndicator + | -- | The list of possible entities to paint a map with. + EntityPaintList + | -- | The entity paint item position in the EntityPaintList. + EntityPaintListItem Int + | -- | The list of possible terrain materials. + TerrainList + | -- | The terrain item position in the TerrainList. + TerrainListItem Int + | -- | The list of inventory items for the currently + -- focused robot. + InventoryList + | -- | The inventory item position in the InventoryList. + InventoryListItem Int + | -- | The list of main menu choices. + MenuList + | -- | The list of achievements. + AchievementList + | -- | An individual control within the scenario launch config panel + ScenarioConfigControl ScenarioConfigPanel + | -- | The list of goals/objectives. + GoalWidgets GoalWidget + | -- | The list of goals/objectives. + StructureWidgets StructureWidget + | -- | The list of scenario choices. + ScenarioList + | -- | The scrollable viewport for the info panel. + InfoViewport + | -- | The scrollable viewport for any modal dialog. + ModalViewport + | -- | The scrollable viewport for the REPL. + REPLViewport + | -- | A clickable button in a modal dialog. + Button Button + | -- | 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 new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Popup.hs @@ -0,0 +1,96 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Repl.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Model.Repl ( + -- ** REPL + REPLEntryType (..), + REPLHistItemType (..), + REPLHistItem (..), + mkREPLSubmission, + mkREPLSaved, + mkREPLOutput, + mkREPLError, + isREPLEntry, + getREPLSubmitted, + isREPLSaved, + getREPLEntry, + REPLHistory, + replIndex, + replLength, + replHasExecutedManualInput, + replSeq, + newREPLHistory, + addREPLItem, + restartREPLHistory, + getLatestREPLHistoryItems, + getSessionREPLHistoryItems, + moveReplHistIndex, + getCurrentItemText, + replIndexIsAtInput, + TimeDir (..), + + -- ** Prompt utils + REPLPrompt (..), + removeEntry, + + -- *** REPL Panel Model + REPLState, + ReplControlMode (..), + replPromptType, + replPromptEditor, + replPromptText, + replValid, + replLast, + replType, + replControlMode, + replHistory, + newREPLEditor, + + -- ** Initialization + initREPLState, + defaultPrompt, + lastEntry, +) 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) +import Data.Maybe (fromMaybe, isJust) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Zipper qualified as TZ +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Language.Syntax (SrcLoc (..)) +import Swarm.Language.Types +import Swarm.TUI.Model.Name +import Swarm.Util.Lens (makeLensesNoSigs) +import Prelude hiding (Applicative (..)) + +------------------------------------------------------------ +-- REPL History +------------------------------------------------------------ + +-- | Whether a user REPL entry was submitted or merely saved. +data REPLEntryType + = -- | The entry was submitted (with Enter) and should thus be shown + -- in the REPL scrollback. + REPLEntrySubmitted + | -- | 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 + deriving (Eq, Ord, Show, Read) + +-- | Various types of REPL history items (user input, output, error). +data REPLHistItemType + = -- | Something entered by the user. + REPLEntry REPLEntryType + | -- | A response printed by the system. + REPLOutput + | -- | An error printed by the system. + REPLError + deriving (Eq, Ord, Show, Read) + +-- | An item in the REPL history. +data REPLHistItem = REPLHistItem {replItemType :: REPLHistItemType, 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" + ] + +instance ToJSON REPLHistItem where + toJSON (REPLHistItem itemType x) = object [label .= x] + where + label = case itemType of + REPLEntry REPLEntrySubmitted -> "in" + REPLEntry REPLEntrySaved -> "save" + REPLOutput -> "out" + REPLError -> "err" + +-- | Useful helper function to only get user input text. Gets all +-- user input, including both submitted and saved history items. +getREPLEntry :: REPLHistItem -> Maybe Text +getREPLEntry = \case + REPLHistItem (REPLEntry {}) t -> Just t + _ -> Nothing + +-- | Useful helper function to filter out REPL output. Returns True +-- for all user input, including both submitted and saved history +-- items. +isREPLEntry :: REPLHistItem -> Bool +isREPLEntry = isJust . getREPLEntry + +-- | Helper function to get only submitted user input text. +getREPLSubmitted :: REPLHistItem -> Maybe Text +getREPLSubmitted = \case + REPLHistItem (REPLEntry REPLEntrySubmitted) 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 _ = False + +-- | History of the REPL with indices (0 is first entry) to the current +-- line and to the first entry since loading saved history. +-- We also (ab)use the length of the REPL as the index of current +-- input line, since that number is one past the index of last entry. +data REPLHistory = REPLHistory + { _replSeq :: Seq REPLHistItem + , _replIndex :: Int + , _replStart :: Int + , _replHasExecutedManualInput :: Bool + } + deriving (Show) + +makeLensesNoSigs ''REPLHistory + +-- | Sequence of REPL inputs and outputs, oldest entry is leftmost. +replSeq :: Lens' REPLHistory (Seq REPLHistItem) + +-- | The current index in the REPL history (if the user is going back +-- through the history using up/down keys). +replIndex :: Lens' REPLHistory Int + +-- | The index of the first entry since loading saved history. +-- +-- It will be set on load and reset on save (happens during exit). +replStart :: Lens' REPLHistory Int + +-- | Keep track of whether the user has explicitly executed commands +-- at the REPL prompt, thus making them ineligible for code size scoring. +-- +-- Note: Instead of adding a dedicated field to the 'REPLHistory' record, +-- an early attempt entailed checking for: +-- +-- @_replIndex > _replStart@ +-- +-- However, executing an initial script causes a "REPLOutput" to be +-- appended to the REPL history, which increments the replIndex, and +-- thus makes the Index greater than the Start even though the +-- player has not input commands directly into the REPL. +-- +-- Therefore, a dedicated boolean is introduced into 'REPLHistory' +-- which simply latches True when the user has input a command. +-- +-- An alternative is described in +-- . +replHasExecutedManualInput :: Lens' REPLHistory Bool + +-- | Create new REPL history (i.e. from loaded history file lines). +newREPLHistory :: [REPLHistItem] -> REPLHistory +newREPLHistory xs = + let s = Seq.fromList xs + in REPLHistory + { _replSeq = s + , _replStart = length s + , _replIndex = length s + , _replHasExecutedManualInput = False + } + +-- | Point the start of REPL history after current last line. See 'replStart'. +restartREPLHistory :: REPLHistory -> REPLHistory +restartREPLHistory h = h & replStart .~ replLength h + +-- | Current number lines of the REPL history - (ab)used as index of input buffer. +replLength :: REPLHistory -> Int +replLength = length . _replSeq + +-- | Add new REPL input - the index must have been pointing one past +-- the last element already, so we increment it to keep it that way. +addREPLItem :: REPLHistItem -> REPLHistory -> REPLHistory +addREPLItem t h = + h + & replSeq %~ (|> t) + & replIndex .~ 1 + replLength h + +-- | Get the latest N items in history, starting with the oldest one. +-- +-- This is used to show previous REPL lines in UI, so we need the items +-- sorted in the order they were entered and will be drawn top to bottom. +getLatestREPLHistoryItems :: Int -> REPLHistory -> [REPLHistItem] +getLatestREPLHistoryItems n h = toList latestN + where + latestN = Seq.drop oldestIndex $ h ^. replSeq + oldestIndex = max (h ^. replStart) $ length (h ^. replSeq) - n + +-- | Get only the items from the REPL history that were entered during +-- the current session. +getSessionREPLHistoryItems :: REPLHistory -> Seq REPLHistItem +getSessionREPLHistoryItems h = Seq.drop (h ^. replStart) (h ^. replSeq) + +data TimeDir = Newer | Older deriving (Eq, Ord, Show) + +moveReplHistIndex :: TimeDir -> Text -> REPLHistory -> REPLHistory +moveReplHistIndex d lastEntered history = history & replIndex .~ newIndex + where + historyLen = replLength history + curText = fromMaybe lastEntered $ getCurrentItemText history + curIndex = history ^. replIndex + entries = history ^. replSeq + -- split repl at index + (olderP, newer) = Seq.splitAt curIndex entries + -- find first different entry in direction + notSameEntry = \case + REPLHistItem (REPLEntry {}) t -> t /= curText + _ -> False + newIndex = case d of + Newer -> maybe historyLen (curIndex +) $ Seq.findIndexL notSameEntry newer + Older -> fromMaybe curIndex $ Seq.findIndexR notSameEntry olderP + +getCurrentItemText :: REPLHistory -> Maybe Text +getCurrentItemText history = replItemText <$> Seq.lookup (history ^. replIndex) (history ^. replSeq) + +replIndexIsAtInput :: REPLHistory -> Bool +replIndexIsAtInput repl = repl ^. replIndex == replLength repl + +-- | Given some text, removes the 'REPLEntry' within 'REPLHistory' which is equal to that. +-- This is used when the user enters search mode and wants to traverse the history. +-- If a command has been used many times, the history will be populated with it causing +-- the effect that search command always finds the same command. +removeEntry :: Text -> REPLHistory -> REPLHistory +removeEntry foundtext hist = hist & replSeq %~ Seq.filter ((/= Just foundtext) . getREPLEntry) + +-- | Get the last 'REPLEntry' in 'REPLHistory' matching the given text +lastEntry :: Text -> REPLHistory -> Maybe Text +lastEntry t h = + case Seq.viewr $ Seq.filter matchEntry $ h ^. replSeq of + Seq.EmptyR -> Nothing + _ Seq.:> a -> Just (replItemText a) + where + matchesText histItem = t `T.isInfixOf` replItemText histItem + matchEntry = liftA2 (&&) matchesText isREPLEntry + +------------------------------------------------------------ +-- REPL +------------------------------------------------------------ + +-- | This data type tells us how to interpret the text typed +-- by the player at the prompt (which is stored in Editor). +data REPLPrompt + = -- | Interpret the prompt text as a regular command. + -- The list is for potential completions, which we can + -- cycle through by hitting Tab repeatedly + CmdPrompt [Text] + | -- | Interpret the prompt text as "search this text in history" + SearchPrompt REPLHistory + +defaultPrompt :: REPLPrompt +defaultPrompt = CmdPrompt [] + +-- | What is being done with user input to the REPL panel? +data ReplControlMode + = -- | The user is typing at the REPL. + Typing + | -- | The user is driving the base using piloting mode. + Piloting + | -- | A custom user key handler is processing user input. + Handling + deriving (Eq, Bounded, Enum) + +data REPLState = REPLState + { _replPromptType :: REPLPrompt + , _replPromptEditor :: Editor Text Name + , _replValid :: Either SrcLoc () + , _replLast :: Text + , _replType :: Maybe Polytype + , _replControlMode :: ReplControlMode + , _replHistory :: REPLHistory + } + +newREPLEditor :: Text -> Editor Text Name +newREPLEditor t = applyEdit gotoEnd $ editorText REPLInput (Just 1) t + where + ls = T.lines t + pos = (length ls - 1, T.length (last ls)) + gotoEnd = if null ls then id else TZ.moveCursor pos + +initREPLState :: REPLHistory -> REPLState +initREPLState hist = + REPLState + { _replPromptType = defaultPrompt + , _replPromptEditor = newREPLEditor "" + , _replValid = Right () + , _replLast = "" + , _replType = Nothing + , _replControlMode = Typing + , _replHistory = hist + } + +makeLensesNoSigs ''REPLState + +-- | The way we interpret text typed by the player in the REPL prompt. +replPromptType :: Lens' REPLState REPLPrompt + +-- | The prompt where the user can type input at the REPL. +replPromptEditor :: Lens' REPLState (Editor Text Name) + +-- | Convenience lens to get text from editor and replace it with new +-- one that has the provided text. +replPromptText :: Lens' REPLState Text +replPromptText = lens g s + where + g r = r ^. replPromptEditor . to getEditContents . to T.concat + s r t = r & replPromptEditor .~ newREPLEditor t + +-- | Whether the prompt text is a valid 'Swarm.Language.Syntax.Term'. +-- If it is invalid, the location of error. ('NoLoc' means the whole +-- text causes the error.) +replValid :: Lens' REPLState (Either SrcLoc ()) + +-- | The type of the current REPL input which should be displayed to +-- the user (if any). +replType :: Lens' REPLState (Maybe Polytype) + +-- | The last thing the user has typed which isn't part of the history. +-- This is used to restore the repl form after the user visited the history. +replLast :: Lens' REPLState Text + +-- | The current REPL control mode, i.e. how user input to the REPL +-- panel is being handled. +replControlMode :: Lens' REPLState ReplControlMode + +-- | History of things the user has typed at the REPL, interleaved +-- with outputs the system has generated. +replHistory :: Lens' REPLState REPLHistory diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Model.StateUpdate ( + initAppState, + initPersistentState, + constructAppState, + initAppStateForScenario, + classicGame0, + startGame, + startGameWithSeed, + restartGame, + attainAchievement, + attainAchievement', + scenarioToAppState, +) where + +import Brick.AttrMap (applyAttrMappings) +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.Effect.Accum +import Control.Effect.Lift +import Control.Effect.Throw +import Control.Lens hiding (from, (<.>)) +import Control.Monad (guard, void) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState, execStateT) +import Data.Bifunctor (first) +import Data.Foldable qualified as F +import Data.List qualified as List +import Data.List.Extra (enumerate) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (fromMaybe, isJust) +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Time (getZonedTime) +import Swarm.Game.Failure (SystemFailure (..)) +import Swarm.Game.Land +import Swarm.Game.Scenario ( + ScenarioInputs (..), + gsiScenarioInputs, + loadScenario, + scenarioAttrs, + scenarioLandscape, + scenarioOperation, + scenarioSolution, + scenarioWorlds, + ) +import Swarm.Game.Scenario.Scoring.Best +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, + normalizeScenarioPath, + scenarioItemByPath, + _SISingle, + ) +import Swarm.Game.State +import Swarm.Game.State.Initialize +import Swarm.Game.State.Landscape +import Swarm.Game.State.Runtime +import Swarm.Game.State.Substate +import Swarm.Game.World.Gen (Seed) +import Swarm.Language.Pretty (prettyText) +import Swarm.Log (LogSource (SystemLog), Severity (..)) +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.KeyBindings +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.Structure +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Attribute.Attr (getWorldAttrName, swarmAttrMap) +import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair) +import Swarm.TUI.View.Structure qualified as SR +import Swarm.Util.Effect (asExceptT, withThrow) +import System.Clock + +-- | Initialize the 'AppState' from scratch. +initAppState :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + AppOpts -> + m AppState +initAppState opts = do + (rs, ui, keyHandling) <- initPersistentState opts + constructAppState rs ui keyHandling opts + +-- | Add some system failures to the list of messages in the +-- 'RuntimeState'. +addWarnings :: RuntimeState -> [SystemFailure] -> RuntimeState +addWarnings = List.foldl' logWarning + where + logWarning rs' w = rs' & eventLog %~ logEvent SystemLog Error "UI Loading" (prettyText w) + +-- | Based on the command line options, should we skip displaying the +-- menu? +skipMenu :: AppOpts -> Bool +skipMenu AppOpts {..} = isJust userScenario || isRunningInitialProgram || isJust userSeed + where + isRunningInitialProgram = isJust scriptToRun || autoPlay + +-- | 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 +-- once and reuse the resulting states for all tests. +initPersistentState :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + AppOpts -> + m (RuntimeState, UIState, KeyEventHandlingState) +initPersistentState opts@(AppOpts {..}) = do + (warnings :: Seq SystemFailure, (initRS, initUI, initKs)) <- runAccum mempty $ do + rs <- initRuntimeState + ui <- initUIState speed (not (skipMenu opts)) cheatMode + ks <- initKeyHandlingState + return (rs, ui, ks) + let initRS' = addWarnings initRS (F.toList warnings) + return (initRS', initUI, initKs) + +-- | 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 -> + AppOpts -> + m AppState +constructAppState rs ui key opts@(AppOpts {..}) = do + let gs = initGameState $ rs ^. stdGameConfigInputs + case skipMenu opts of + False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) key rs + True -> do + let tem = gs ^. landscape . terrainAndEntities + (scenario, path) <- + loadScenario + (fromMaybe "classic" userScenario) + (ScenarioInputs (initWorldMap . gsiScenarioInputs . initState $ rs ^. stdGameConfigInputs) tem) + maybeRunScript <- traverse parseCodeFile scriptToRun + + let maybeAutoplay = do + guard autoPlay + soln <- scenario ^. scenarioOperation . scenarioSolution + 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]) + sendIO $ + execStateT + (startGameWithSeed (scenario, si) $ LaunchParams (pure userSeed) (pure codeToRun)) + (AppState gs ui key newRs) + +-- | 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 + +-- | Re-initialize the game from the stored reference to the current scenario. +-- +-- Note that "restarting" is intended only for "scenarios"; +-- with some scenarios, it may be possible to get stuck so that it is +-- either impossible or very annoying to win, so being offered an +-- option to restart is more user-friendly. +-- +-- Since scenarios are stored as a Maybe in the UI state, we handle the Nothing +-- case upstream so that the Scenario passed to this function definitely exists. +restartGame :: (MonadIO m, MonadState AppState m) => Seed -> ScenarioInfoPair -> m () +restartGame currentSeed siPair = startGameWithSeed siPair $ 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 -> + ValidatedLaunchParams -> + m () +startGameWithSeed siPair@(_scene, si) lp = do + t <- liftIO getZonedTime + ss <- use $ runtimeState . scenarios + p <- liftIO $ normalizeScenarioPath ss (si ^. scenarioPath) + runtimeState + . scenarios + . scenarioItemByPath p + . _SISingle + . _2 + . 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 + where + prevBest t = case si ^. scenarioStatus of + NotStarted -> emptyBest t + Played _ _ b -> b + +-- | Modify the 'AppState' appropriately when starting a new scenario. +scenarioToAppState :: + (MonadIO m, MonadState AppState m) => + ScenarioInfoPair -> + ValidatedLaunchParams -> + m () +scenarioToAppState siPair@(scene, _) lp = do + rs <- use runtimeState + gs <- liftIO $ scenarioToGameState scene lp $ rs ^. stdGameConfigInputs + gameState .= gs + void $ withLensIO uiState $ scenarioToUIState isAutoplaying siPair gs + where + isAutoplaying = case runIdentity (initialCode lp) of + Just (CodeToRun ScenarioSuggested _) -> True + _ -> False + + withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m x + withLensIO l a = do + x <- use l + x' <- liftIO $ a x + l .= x' + return x' + +-- | Modify the UI state appropriately when starting a new scenario. +scenarioToUIState :: + Bool -> + ScenarioInfoPair -> + 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) + where + entityList = EU.getEntitiesForList $ gs ^. landscape . terrainAndEntities . entityMap + + (isEmptyArea, newBounds) = + EU.getEditingBounds $ + NE.head $ + scenario ^. scenarioLandscape . scenarioWorlds + + setNewBounds maybeOldBounds = + if isEmptyArea + then maybeOldBounds + else Just newBounds + +-- | Create an initial app state for a specific scenario. Note that +-- this function is used only for unit tests, integration tests, and +-- benchmarks. +-- +-- In normal play, an 'AppState' already exists and we simply need +-- to update it using 'scenarioToAppState'. +initAppStateForScenario :: String -> Maybe Seed -> Maybe FilePath -> ExceptT Text IO AppState +initAppStateForScenario sceneName userSeed toRun = + asExceptT . withThrow (prettyText @SystemFailure) . initAppState $ + defaultAppOpts + { userScenario = Just sceneName + , userSeed = userSeed + , scriptToRun = toRun + } + +-- | For convenience, the 'AppState' corresponding to the classic game +-- with seed 0. This is used only for benchmarks and unit tests. +classicGame0 :: ExceptT Text IO AppState +classicGame0 = initAppStateForScenario "classic" (Just 0) Nothing diff --git a/src/swarm-tui/Swarm/TUI/Model/Structure.hs b/src/swarm-tui/Swarm/TUI/Model/Structure.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/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.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 new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/UI.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Model.UI ( + UIState (..), + UIGameplay (..), + UITiming (..), + UIInventory (..), + GoalDisplay (..), + uiGameplay, + uiPopups, + uiTiming, + uiInventory, + uiMenu, + uiPlaying, + uiCheatMode, + uiFocusRing, + 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, +) 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 Swarm.TUI.Launch.Model +import Swarm.TUI.Launch.Prep +import Swarm.TUI.Model.Goal +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) + +-- * Toplevel UIState definition + +data UIState = UIState + { _uiMenu :: Menu + , _uiPlaying :: Bool + , _uiCheatMode :: Bool + , _uiLaunchConfig :: LaunchOptions + , _uiAchievements :: Map CategorizedAchievement Attainment + , _uiAttrMap :: AttrMap + , _uiGameplay :: UIGameplay + , _uiPopups :: PopupState + } + +-- * Lenses for UIState + +makeLensesNoSigs ''UIState + +-- | The current menu state. +uiMenu :: Lens' UIState Menu + +-- | Are we currently playing the game? +-- +-- * 'True' = we are playing, and +-- should thus display a world, REPL, etc. +-- * False = we should +-- 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 + +-- | 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. +-- NOTE: Normally, the Tab key might cycle through the members of the +-- focus ring. However, the REPL already uses Tab. So, to is not used +-- at all right now for navigating the toplevel focus ring. +initFocusRing :: FocusRing Name +initFocusRing = focusRing $ map FocusablePanel enumerate + +-- | The initial tick speed. +defaultInitLgTicksPerSecond :: Int +defaultInitLgTicksPerSecond = 4 -- 2^4 = 16 ticks / second + +-- | 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. +initUIState :: + ( Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + Int -> + Bool -> + Bool -> + 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 + 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 diff --git a/src/swarm-tui/Swarm/TUI/Panel.hs b/src/swarm-tui/Swarm/TUI/Panel.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Panel.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A small custom "panel widget" for use in the Swarm TUI. Panels draw +-- a border around some content, with the color of the border +-- depending on whether the panel is currently focused. Panels exist +-- within a 'FocusRing' such that the user can cycle between the +-- panels (using /e.g./ the @Tab@ key). Panels can also have labels +-- at up to 6 locations (top\/bottom, left\/center\/right). +module Swarm.TUI.Panel ( + panel, +) where + +import Brick +import Brick.Focus +import Brick.Widgets.Border +import Control.Lens +import Swarm.TUI.Border + +data Panel n = Panel + {_panelName :: n, _panelLabels :: BorderLabels n, _panelContent :: Widget n} + +makeLenses ''Panel + +instance Named (Panel n) n where + getName = view panelName + +drawPanel :: Eq n => AttrName -> FocusRing n -> Panel n -> Widget n +drawPanel attr fr = withFocusRing fr drawPanel' + where + drawPanel' :: Bool -> Panel n -> Widget n + drawPanel' focused p = + (if focused then overrideAttr borderAttr attr else id) $ + borderWithLabels (p ^. panelLabels) (p ^. panelContent) + +-- | Create a panel. +panel :: + Eq n => + -- | Border attribute to use when the panel is focused. + AttrName -> + -- | Focus ring the panel should be part of. + FocusRing n -> + -- | The name of the panel. Must be unique. + n -> + -- | The labels to use around the border. + BorderLabels n -> + -- | The content of the panel. + Widget n -> + Widget n +panel attr fr nm labs w = drawPanel attr fr (Panel nm labs w) diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -0,0 +1,1628 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Code for drawing the TUI. +module Swarm.TUI.View ( + drawUI, + drawTPS, + + -- * Dialog box + drawDialog, + chooseCursor, + + -- * Key hint menu + drawKeyMenu, + drawModalMenu, + drawKeyCmd, + + -- * World + drawWorldPane, + + -- * Robot panel + drawRobotPanel, + drawItem, + renderDutyCycle, + + -- * Info panel + drawInfoPanel, + explainFocusedItem, + + -- * REPL + drawREPL, +) where + +import Brick hiding (Direction, Location) +import Brick.Focus +import Brick.Forms +import Brick.Widgets.Border ( + hBorder, + hBorderWithLabel, + joinableBorder, + vBorder, + ) +import Brick.Widgets.Center (center, centerLayer, hCenter) +import Brick.Widgets.Dialog +import Brick.Widgets.Edit (getEditContents, renderEditor) +import Brick.Widgets.List qualified as BL +import Brick.Widgets.Table qualified as BT +import Control.Lens 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) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.List.Split (chunksOf) +import Data.Map qualified as M +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.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.Display +import Swarm.Game.Entity as E +import Swarm.Game.Ingredients +import Swarm.Game.Land +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, + scenarioCreative, + scenarioDescription, + scenarioKnown, + scenarioLandscape, + scenarioMetadata, + scenarioName, + scenarioObjectives, + scenarioOperation, + scenarioSeed, + scenarioTerrainAndEntities, + ) +import Swarm.Game.Scenario.Scoring.Best +import Swarm.Game.Scenario.Scoring.CodeSize +import Swarm.Game.Scenario.Scoring.ConcreteMetrics +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 (..), + scenarioItemName, + ) +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.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.TUI.Border +import Swarm.TUI.Controller (ticksPerFrameCap) +import Swarm.TUI.Controller.EventHandlers (allEventHandlers, mainEventHandlers, replEventHandlers, robotEventHandlers, worldEventHandlers) +import Swarm.TUI.Controller.Util (hasDebugCapability) +import Swarm.TUI.Editor.Model +import Swarm.TUI.Editor.View qualified as EV +import Swarm.TUI.Inventory.Sorting (renderSortMethod) +import Swarm.TUI.Launch.Model +import Swarm.TUI.Launch.View +import Swarm.TUI.Model +import Swarm.TUI.Model.Event qualified as SE +import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow) +import Swarm.TUI.Model.KeyBindings (handlerNameKeysDescription) +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI +import Swarm.TUI.Panel +import Swarm.TUI.View.Achievement +import Swarm.TUI.View.Attribute.Attr +import Swarm.TUI.View.CellDisplay +import Swarm.TUI.View.Logo +import Swarm.TUI.View.Objective qualified as GR +import Swarm.TUI.View.Popup +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) + +-- | The main entry point for drawing the entire UI. +drawUI :: AppState -> [Widget Name] +drawUI s = drawPopups s : mainLayers + where + mainLayers + | s ^. uiState . uiPlaying = drawGameUI s + | otherwise = drawMenuUI s + +drawMenuUI :: AppState -> [Widget Name] +drawMenuUI s = case s ^. uiState . uiMenu of + -- We should never reach the NoMenu case if uiPlaying is false; we would have + -- 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 + AchievementsMenu l -> [drawAchievementsMenuUI s l] + MessagesMenu -> [drawMainMessages s] + AboutMenu -> [drawAboutMenuUI (s ^. runtimeState . appData . at "about")] + +drawMainMessages :: AppState -> Widget Name +drawMainMessages s = renderDialog dial . padBottom Max . scrollList $ drawLogs ls + where + ls = reverse $ s ^. runtimeState . eventLog . notificationsContent + dial = dialog (Just $ str "Messages") Nothing maxModalWindowWidth + scrollList = withVScrollBars OnRight . vBox + drawLogs = map (drawLogEntry True) + +drawMainMenuUI :: AppState -> BL.List Name MainMenuEntry -> Widget Name +drawMainMenuUI s l = + vBox . catMaybes $ + [ drawLogo <$> logo + , hCenter . padTopBottom 2 <$> newVersionWidget version + , Just . centerLayer . vLimit 6 . hLimit 20 $ + BL.renderList (const (hCenter . drawMainMenuEntry s)) True l + ] + where + logo = s ^. runtimeState . appData . at "logo" + version = s ^. runtimeState . upstreamRelease + +newVersionWidget :: Either NewReleaseFailure 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 + +-- | 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) -> + LaunchOptions -> + [Widget Name] +drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of + Nothing -> pure mainWidget + Just _ -> drawLaunchConfigPanel launchOptions <> pure mainWidget + where + displayedFor = launchOptions ^. controls . isDisplayedFor + mainWidget = + vBox + [ padLeftRight 20 + . centerLayer + $ hBox + [ vBox + [ withAttr boldAttr . txt $ breadcrumbs ls + , txt " " + , vLimit 20 + . hLimit 35 + . withLeftPaddedVScrollBars + . padLeft (Pad 1) + . padTop (Pad 1) + . BL.renderList (const $ padRight Max . drawScenarioItem) True + $ l + ] + , padLeft (Pad 5) (maybe (txt "") (drawDescription . snd) (BL.listSelectedElement l)) + ] + , launchOptionsMessage + ] + + launchOptionsMessage = case (displayedFor, snd <$> BL.listSelectedElement l) of + (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 (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 " ● " + + 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 = + T.intercalate " > " + . ("Scenarios" :) + . reverse + . mapMaybe (fmap (scenarioItemName . snd) . BL.listSelectedElement) + + drawDescription :: ScenarioItem -> Widget Name + drawDescription (SICollection _ _) = txtWrap " " + drawDescription (SISingle (s, si)) = + vBox + [ drawMarkdown (nonBlank (s ^. scenarioOperation . scenarioDescription)) + , hCenter . padTop (Pad 1) . vLimit 6 $ hLimitPercent 60 worldPeek + , padTop (Pad 1) table + ] + where + vc = determineStaticViewCenter (s ^. scenarioLandscape) worldTuples + + worldTuples = buildWorldTuples $ s ^. scenarioLandscape + theWorlds = + genMultiWorld worldTuples $ + fromMaybe 0 $ + s ^. scenarioLandscape . scenarioSeed + + entIsKnown = + getEntityIsKnown $ + EntityKnowledgeDependencies + { isCreativeMode = s ^. scenarioOperation . scenarioCreative + , globallyKnownEntities = s ^. scenarioLandscape . scenarioKnown + , theFocusedRobot = Nothing + } + + tm = s ^. scenarioLandscape . scenarioTerrainAndEntities . terrainMap + ri = RenderingInput theWorlds entIsKnown tm + + renderCoord = renderDisplay . displayLocRaw (WorldOverdraw False mempty) ri [] + worldPeek = worldWidget renderCoord vc + + firstRow = + ( withAttr dimAttr $ txt "Author:" + , withAttr dimAttr . txt <$> s ^. scenarioMetadata . scenarioAuthor + ) + secondRow = + ( txt "last:" + , Just $ describeStatus $ si ^. scenarioStatus + ) + + padTopLeft = padTop (Pad 1) . padLeft (Pad 1) + + tableRows = + map (map padTopLeft . pairToList) $ + mapMaybe sequenceA $ + firstRow : secondRow : makeBestScoreRows (si ^. scenarioStatus) + table = + BT.renderTable + . BT.surroundingBorder False + . BT.rowBorders False + . BT.columnBorders False + . BT.alignRight 0 + . BT.alignLeft 1 + . BT.table + $ tableRows + + nonBlank "" = " " + nonBlank t = t + +pairToList :: (a, a) -> [a] +pairToList (x, y) = [x, y] + +describeProgress :: ProgressMetric -> Widget n +describeProgress (Metric p (ProgressStats _startedAt (AttemptMetrics (DurationMetrics e t) maybeCodeMetrics))) = case p of + Attempted -> + withAttr yellowAttr . vBox $ + [ txt "in progress" + , txt $ parens $ T.unwords ["played for", formatTimeDiff e] + ] + Completed -> + withAttr greenAttr . vBox $ + [ txt $ T.unwords ["completed in", formatTimeDiff e] + , txt . (" " <>) . parens $ T.unwords [T.pack $ drawTime t True, "ticks"] + ] + <> maybeToList (sizeDisplay <$> maybeCodeMetrics) + where + sizeDisplay (ScenarioCodeMetrics myCharCount myAstSize) = + withAttr greenAttr $ + vBox $ + map + txt + [ T.unwords + [ "Code:" + , T.pack $ show myCharCount + , "chars" + ] + , (" " <>) $ + parens $ + T.unwords + [ T.pack $ show myAstSize + , "AST nodes" + ] + ] + where + formatTimeDiff :: NominalDiffTime -> Text + formatTimeDiff = T.pack . formatTime defaultTimeLocale "%hh %Mm %Ss" + +-- | If there are multiple different games that each are \"best\" +-- by different criteria, display them all separately, labeled +-- by which criteria they were best in. +-- +-- On the other hand, if all of the different \"best\" criteria are for the +-- same game, consolidate them all into one entry and don't bother +-- labelling the criteria. +makeBestScoreRows :: + ScenarioStatus -> + [(Widget n1, Maybe (Widget n2))] +makeBestScoreRows scenarioStat = + maybe [] makeBestRows getBests + where + getBests = case scenarioStat of + NotStarted -> Nothing + Played _initialScript _ best -> Just best + + makeBestRows b = map (makeBestRow hasMultiple) groups + where + groups = getBestGroups b + hasMultiple = length groups > 1 + + makeBestRow hasDistinctByCriteria (b, criteria) = + ( hLimit (maxLeftColumnWidth + 2) $ + vBox $ + [ padLeft Max $ txt "best:" + ] + <> elaboratedCriteria + , Just $ describeProgress b + ) + where + maxLeftColumnWidth = maximum (map (T.length . describeCriteria) enumerate) + mkCriteriaRow = + withAttr dimAttr + . padLeft Max + . txt + . mconcat + . pairToList + . fmap (\x -> T.singleton $ if x == 0 then ',' else ' ') + elaboratedCriteria = + if hasDistinctByCriteria + then + map mkCriteriaRow + . flip zip [(0 :: Int) ..] + . NE.toList + . NE.reverse + . NE.map describeCriteria + $ criteria + else [] + +drawMainMenuEntry :: AppState -> MainMenuEntry -> Widget Name +drawMainMenuEntry s = \case + NewGame -> txt "New game" + Tutorial -> txt "Tutorial" + Achievements -> txt "Achievements" + About -> txt "About" + Messages -> highlightMessages $ txt "Messages" + Quit -> txt "Quit" + where + highlightMessages = + if s ^. runtimeState . eventLog . notificationsCount > 0 + then withAttr notifAttr + else id + +drawAboutMenuUI :: Maybe Text -> Widget Name +drawAboutMenuUI Nothing = centerLayer $ txt "About swarm!" +drawAboutMenuUI (Just t) = centerLayer . vBox . map (hCenter . txt . nonblank) $ T.lines t + where + -- Turn blank lines into a space so they will take up vertical space as widgets + nonblank "" = " " + nonblank s = s + +-- | Draw the main game UI. Generates a list of widgets, where each +-- represents a layer. Right now we just generate two layers: the +-- main layer and a layer for a floating dialog that can be on top. +drawGameUI :: AppState -> [Widget Name] +drawGameUI s = + [ joinBorders $ drawDialog s + , joinBorders $ + hBox + [ hLimitPercent 25 $ + vBox + [ vLimitPercent 50 + $ panel + highlightAttr + fr + (FocusablePanel RobotPanel) + ( plainBorder + & bottomLabels . centerLabel + .~ fmap + (txt . (" Search: " <>) . (<> " ")) + (s ^. uiState . uiGameplay . uiInventory . uiInventorySearch) + ) + $ drawRobotPanel s + , panel + highlightAttr + fr + (FocusablePanel InfoPanel) + plainBorder + $ drawInfoPanel s + , hCenter + . clickable (FocusablePanel WorldEditorPanel) + . EV.drawWorldEditor fr + $ s ^. uiState + ] + , vBox rightPanel + ] + ] + where + 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 + -- 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 + minimizedREPL = case focusGetCurrent fr of + (Just (FocusablePanel REPLPanel)) -> [separateBorders $ clickable (FocusablePanel REPLPanel) (forceAttr highlightAttr hBorder)] + _ -> [separateBorders $ clickable (FocusablePanel REPLPanel) hBorder] + worldPanel = + [ panel + highlightAttr + fr + (FocusablePanel WorldPanel) + ( plainBorder + & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s) + & topLabels . leftLabel ?~ drawModalMenu s + & addCursorPos + & addClock + ) + (drawWorldPane (s ^. uiState . uiGameplay) (s ^. gameState)) + , drawKeyMenu s + ] + replPanel = + [ clickable (FocusablePanel REPLPanel) $ + panel + highlightAttr + fr + (FocusablePanel REPLPanel) + ( plainBorder + & topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiGameplay . uiREPL . replType)) + ) + ( vLimit replHeight + . padBottom Max + . padLeft (Pad 1) + $ drawREPL s + ) + ] + +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 + Just s -> renderDisplay $ displayStatic s + Nothing -> hBox $ tileMemberWidgets ++ [coordsWidget] + where + Cosmic _ coords = cCoords + coordsWidget = str $ renderCoordsString $ fmap coordsToLoc cCoords + + tileMembers = terrain : mapMaybe merge [entity, robot] + tileMemberWidgets = + map (padRight $ Pad 1) + . concat + . reverse + . zipWith f tileMembers + $ ["at", "on", "with"] + where + f cell preposition = [renderDisplay cell, txt preposition] + + ri = + RenderingInput + (g ^. landscape . multiWorld) + (getEntityIsKnown $ mkEntityKnowledge g) + (g ^. landscape . terrainAndEntities . terrainMap) + + terrain = displayTerrainCell worldEditor ri cCoords + entity = displayEntityCell worldEditor ri cCoords + robot = displayRobotCell g cCoords + + merge = fmap sconcat . NE.nonEmpty . filter (not . (^. invisible)) + +-- | Format the clock display to be shown in the upper right of the +-- world panel. +drawClockDisplay :: Int -> GameState -> Widget n +drawClockDisplay lgTPS gs = hBox . intersperse (txt " ") $ catMaybes [clockWidget, pauseWidget] + where + 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. +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 [] + +-- | Return a possible time display, if the currently focused robot +-- has a clock device equipped. The first argument is the number +-- of ticks (e.g. 943 = 0x3af), and the second argument indicates +-- 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) + +-- | Draw info about the current number of ticks per second. +drawTPS :: AppState -> Widget Name +drawTPS s = 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 = + [ txt " (" + , let tpf = s ^. uiState . uiGameplay . uiTiming . uiTPF + in (if tpf >= fromIntegral ticksPerFrameCap then withAttr redAttr else id) + (str (printf "%0.1f" tpf)) + , txt " tpf, " + , str (printf "%0.1f" (s ^. uiState . uiGameplay . uiTiming . uiFPS)) + , txt " fps)" + ] + | otherwise = [] + + l = s ^. uiState . uiGameplay . uiTiming . lgTicksPerSecond + n = 2 ^ abs l + +-- | The height of the REPL box. Perhaps in the future this should be +-- configurable. +replHeight :: Int +replHeight = 10 + +-- | 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 + 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 + +robotsListWidget :: AppState -> Widget Name +robotsListWidget s = hCenter table + 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 + 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 = " " + + locWidget = hBox [worldCell, str $ " " <> locStr] + 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" + + 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 + +helpWidget :: Seed -> Maybe Port -> KeyEventHandlingState -> Widget Name +helpWidget theSeed mport keyState = + padLeftRight 2 . vBox $ padTop (Pad 1) <$> [info, helpKeys, tips] + where + tips = + vBox + [ heading boldAttr "Have questions? Want some tips? Check out:" + , txt " - The Swarm wiki, " <+> hyperlink wikiUrl (txt wikiUrl) + , txt " - The Swarm Discord server at " <+> hyperlink swarmDiscord (txt swarmDiscord) + ] + info = + vBox + [ heading boldAttr "Configuration" + , txt ("Seed: " <> into @Text (show theSeed)) + , txt ("Web server port: " <> maybe "none" (into @Text . show) mport) + ] + helpKeys = + vBox + [ heading boldAttr "Keybindings" + , keySection "Main (always active)" mainEventHandlers + , keySection "REPL panel" replEventHandlers + , keySection "World view panel" worldEventHandlers + , keySection "Robot inventory panel" robotEventHandlers + ] + keySection name handlers = + padBottom (Pad 1) $ + vBox + [ heading italicAttr name + , mkKeyTable handlers + ] + mkKeyTable = + BT.renderTable + . BT.surroundingBorder False + . BT.rowBorders False + . BT.table + . map (toRow . keyHandlerToText) + heading attr = padBottom (Pad 1) . withAttr attr . txt + toRow (n, k, d) = + [ padRight (Pad 1) $ txtFilled maxN n + , padLeftRight 1 $ txtFilled maxK k + , padLeft (Pad 1) $ txtFilled maxD d + ] + keyHandlerToText = handlerNameKeysDescription (keyState ^. keyConfig) + -- Get maximum width of the table columns so it all neatly aligns + txtFilled n t = padRight (Pad $ max 0 (n - textWidth t)) $ txt t + (maxN, maxK, maxD) = map3 (maximum . map textWidth) . unzip3 $ keyHandlerToText <$> allEventHandlers + map3 f (n, k, d) = (f n, f k, f d) + +data NotificationList = RecipeList | MessageList + +availableListWidget :: GameState -> NotificationList -> Widget Name +availableListWidget gs nl = padTop (Pad 1) $ vBox widgetList + where + widgetList = case nl of + RecipeList -> mkAvailableList gs (discovery . availableRecipes) renderRecipe + MessageList -> messagesWidget gs + renderRecipe = padLeftRight 18 . drawRecipe Nothing (fromMaybe E.empty inv) + inv = gs ^? to focusedRobot . _Just . robotInventory + +mkAvailableList :: GameState -> Lens' GameState (Notifications a) -> (a -> Widget Name) -> [Widget Name] +mkAvailableList gs notifLens notifRender = map padRender news <> notifSep <> map padRender knowns + where + padRender = padBottom (Pad 1) . notifRender + count = gs ^. notifLens . notificationsCount + (news, knowns) = splitAt count (gs ^. notifLens . notificationsContent) + notifSep + | count > 0 && not (null knowns) = + [ padBottom (Pad 1) (withAttr redAttr $ hBorderWithLabel (padLeftRight 1 (txt "new↑"))) + ] + | otherwise = [] + +commandsListWidget :: GameState -> Widget Name +commandsListWidget gs = + hCenter $ + vBox + [ table + , padTop (Pad 1) $ txt "For the full list of available commands see the Wiki at:" + , txt wikiCheatSheet + ] + where + commands = gs ^. discovery . availableCommands . notificationsContent + table = + BT.renderTable + . BT.surroundingBorder False + . BT.columnBorders False + . BT.rowBorders False + . BT.setDefaultColAlignment BT.AlignLeft + . BT.alignRight 0 + . BT.table + $ headers : commandsTable + headers = + withAttr robotAttr + <$> [ txt "command name" + , txt " : type" + , txt "Enabled by" + ] + + commandsTable = mkCmdRow <$> commands + mkCmdRow cmd = + map + (padTop $ Pad 1) + [ txt $ syntax $ constInfo cmd + , padRight (Pad 2) . withAttr magentaAttr . txt $ " : " <> prettyTextLine (inferConst cmd) + , listDevices cmd + ] + + base = gs ^? baseRobot + entsByCap = case base of + Just r -> + M.map NE.toList $ + entitiesByCapability $ + (r ^. equippedDevices) `union` (r ^. robotInventory) + Nothing -> mempty + + listDevices cmd = vBox $ map drawLabelledEntityName providerDevices + where + providerDevices = + concatMap (flip (M.findWithDefault []) entsByCap) $ + maybeToList $ + 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) + +-- | 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 + drawLogEntry' e = + withAttr (colorLogs e) $ + hBox + [ fromMaybe (txt "") $ maybeDrawTime (e ^. leTime) True gs + , padLeft (Pad 2) . txt $ brackets $ e ^. leName + , padLeft (Pad 1) . txt2 $ e ^. leText + ] + txt2 = txtWrapWith indent2 + +colorLogs :: LogEntry -> AttrName +colorLogs e = case e ^. leSource of + SystemLog -> colorSeverity (e ^. leSeverity) + RobotLog rls rid _loc -> case rls of + Said -> robotColor rid + Logged -> notifAttr + RobotError -> colorSeverity (e ^. leSeverity) + CmdStatus -> notifAttr + where + -- color each robot message with different color of the world + robotColor = indexWrapNonEmpty messageAttributeNames + +colorSeverity :: Severity -> AttrName +colorSeverity = \case + Info -> infoAttr + Debug -> dimAttr + Warning -> yellowAttr + Error -> redAttr + 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 + where + notificationKey :: Getter GameState (Notifications a) -> SE.MainEvent -> Text -> Maybe (KeyHighlight, Text, Text) + notificationKey notifLens key name + | null (s ^. gameState . notifLens . notificationsContent) = Nothing + | otherwise = + let highlight + | s ^. gameState . notifLens . notificationsCount > 0 = Alert + | otherwise = NoHighlight + in Just (highlight, keyM key, name) + + -- Hides this key if the recognizable structure list is empty + structuresKey = + if null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions + then Nothing + else Just (NoHighlight, keyM SE.ViewStructuresEvent, "Structures") + + globalKeyCmds = + catMaybes + [ Just (NoHighlight, keyM SE.ViewHelpEvent, "Help") + , Just (NoHighlight, keyM SE.ViewRobotsEvent, "Robots") + , notificationKey (discovery . availableRecipes) SE.ViewRecipesEvent "Recipes" + , notificationKey (discovery . availableCommands) SE.ViewCommandsEvent "Commands" + , notificationKey messageNotifications SE.ViewMessagesEvent "Messages" + , structuresKey + ] + keyM = VU.bindingText s . SE.Main + +-- | Draw a menu explaining what key commands are available for the +-- current panel. This menu is displayed as one or two lines in +-- between the world panel and the REPL. +-- +-- This excludes the F-key modals that are shown elsewhere. +drawKeyMenu :: AppState -> Widget Name +drawKeyMenu s = + vLimit 2 $ + hBox + [ padBottom Max $ + vBox + [ mkCmdRow globalKeyCmds + , padLeft (Pad 2) contextCmds + ] + , gameModeWidget + ] + where + mkCmdRow = hBox . map drawPaddedCmd + drawPaddedCmd = padLeftRight 1 . drawKeyCmd + contextCmds + | ctrlMode == Handling = txt $ fromMaybe "" (s ^? gameState . gameControls . inputHandler . _Just . _1) + | otherwise = mkCmdRow focusedPanelCmds + focusedPanelCmds = + map highlightKeyCmds + . keyCmdsFor + . focusGetCurrent + . view (uiState . uiGameplay . uiFocusRing) + $ s + + 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) + + renderPilotModeSwitch :: ReplControlMode -> T.Text + renderPilotModeSwitch = \case + Piloting -> "REPL" + _ -> "pilot" + + renderHandlerModeSwitch :: ReplControlMode -> T.Text + renderHandlerModeSwitch = \case + Handling -> "REPL" + _ -> "key handler" + + gameModeWidget = + padLeft Max + . padLeftRight 1 + . txt + . (<> " mode") + $ case creative of + False -> "Classic" + True -> "Creative" + 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 + (isPaused && hasDebug) + ( if s ^. uiState . uiGameplay . uiShowDebug then Alert else NoHighlight + , keyM SE.ShowCESKDebugEvent + , "debug" + ) + , Just (NoHighlight, keyM SE.IncreaseTpsEvent <> "/" <> keyM SE.DecreaseTpsEvent, "speed") + , Just + ( NoHighlight + , keyM SE.ToggleREPLVisibilityEvent + , if s ^. uiState . uiGameplay . uiShowREPL then "hide REPL" else "show REPL" + ) + , Just + ( if s ^. uiState . uiGameplay . uiShowRobots then NoHighlight else Alert + , keyM SE.HideRobotsEvent + , "hide robots" + ) + ] + may b = if b then Just else const Nothing + + highlightKeyCmds (k, n) = (PanelSpecific, k, n) + + keyCmdsFor (Just (FocusablePanel WorldEditorPanel)) = + [("^s", "save map")] + keyCmdsFor (Just (FocusablePanel REPLPanel)) = + [ ("↓↑", "history") + ] + ++ [("Enter", "execute") | not isReplWorking] + ++ [(keyR SE.CancelRunningProgramEvent, "cancel") | isReplWorking] + ++ [(keyR SE.TogglePilotingModeEvent, renderPilotModeSwitch ctrlMode) | creative] + ++ [(keyR SE.ToggleCustomKeyHandlingEvent, renderHandlerModeSwitch ctrlMode) | handlerInstalled] + ++ [("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 + then [("Esc", "exit search")] + else + [ (keyE SE.MakeEntityEvent, "make") + , (keyE SE.ShowZeroInventoryEntitiesEvent, (if showZero then "hide" else "show") <> " 0") + , + ( keyE SE.SwitchInventorySortDirection <> "/" <> keyE SE.CycleInventorySortEvent + , T.unwords ["Sort:", renderSortMethod inventorySort] + ) + , (keyE SE.SearchInventoryEvent, "search") + ] + keyCmdsFor (Just (FocusablePanel InfoPanel)) = [] + keyCmdsFor _ = [] + keyM = VU.bindingText s . SE.Main + keyR = VU.bindingText s . SE.REPL + keyE = VU.bindingText s . SE.Robot + keyW = VU.bindingText s . 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 + ] + where + attr = case h of + NoHighlight -> defAttr + Alert -> notifAttr + PanelSpecific -> highlightAttr + +------------------------------------------------------------ +-- World panel +------------------------------------------------------------ + +-- | Compare to: 'Swarm.Util.Content.getMapRectangle' +worldWidget :: + (Cosmic Coords -> Widget n) -> + -- | view center + Cosmic Location -> + Widget n +worldWidget renderCoord gameViewCenter = Widget Fixed Fixed $ + do + ctx <- getContext + let w = ctx ^. availWidthL + h = ctx ^. availHeightL + vr = viewingRegion gameViewCenter (fromIntegral w, fromIntegral h) + ixs = range $ vr ^. planar + render . vBox . map hBox . chunksOf w . map (renderCoord . Cosmic (vr ^. subworld)) $ ixs + +-- | Draw the current world view. +drawWorldPane :: UIGameplay -> GameState -> Widget Name +drawWorldPane ui g = + center + . cached WorldCache + . reportExtent WorldExtent + -- Set the clickable request after the extent to play nice with the cache + . clickable (FocusablePanel WorldPanel) + $ worldWidget renderCoord (g ^. robotInfo . viewCenter) + where + renderCoord = drawLoc ui g + +------------------------------------------------------------ +-- Robot inventory panel +------------------------------------------------------------ + +-- | 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 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 = + let drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb + row = + [ txt (r ^. robotName) + , padLeft (Pad 2) . str . renderCoordsString $ r ^. robotLocation + , padLeft (Pad 2) $ renderDisplay (r ^. robotDisplay) + ] + in padBottom Max $ + vBox + [ hCenter $ hBox row + , withLeftPaddedVScrollBars . padLeft (Pad 1) . padTop (Pad 1) $ + BL.renderListWithIndex drawClickableItem True lst + ] + | otherwise = blank + +blank :: Widget Name +blank = padRight Max . padBottom Max $ str " " + +-- | Draw an inventory entry. +drawItem :: + -- | The index of the currently selected inventory entry + Maybe Int -> + -- | The index of the entry we are drawing + Int -> + -- | Whether this entry is selected; we can ignore this + -- because it will automatically have a special attribute + -- applied to it. + Bool -> + -- | The entry to draw. + InventoryListEntry -> + Widget Name +drawItem sel i _ (Separator l) = + -- Make sure a separator right before the focused element is + -- visible. Otherwise, when a separator occurs as the very first + -- 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) +drawItem _ _ _ (InventoryEntry n e) = drawLabelledEntityName e <+> showCount n + where + showCount = padLeft Max . str . show +drawItem _ _ _ (EquippedEntry e) = drawLabelledEntityName e <+> padLeft Max (str " ") + +------------------------------------------------------------ +-- Info panel +------------------------------------------------------------ + +-- | Draw the info panel in the bottom-left corner, which shows info +-- about the currently focused inventory item. +drawInfoPanel :: AppState -> Widget Name +drawInfoPanel s + | Just Far <- s ^. gameState . to focusedRange = blank + | otherwise = + withVScrollBars OnRight + . viewport InfoViewport Vertical + . padLeftRight 1 + $ explainFocusedItem s + +-- | Display info about the currently focused inventory entity, +-- such as its description and relevant recipes. +explainFocusedItem :: AppState -> Widget Name +explainFocusedItem s = case focusedItem s of + Just (InventoryEntry _ e) -> explainEntry s e + Just (EquippedEntry e) -> explainEntry s e + _ -> txt " " + +explainEntry :: AppState -> Entity -> Widget Name +explainEntry s e = + vBox $ + [ displayProperties $ Set.toList (e ^. entityProperties) + , drawMarkdown (e ^. entityDescription) + , explainCapabilities (s ^. gameState) e + , explainRecipes s e + ] + <> [drawRobotMachine s False | CDebug `M.member` getMap (e ^. entityCapabilities)] + <> [drawRobotLog s | CLog `M.member` getMap (e ^. entityCapabilities)] + +displayProperties :: [EntityProperty] -> Widget Name +displayProperties = displayList . mapMaybe showProperty + where + showProperty Growable = Just "growing" + showProperty Pushable = Just "pushable" + showProperty Combustible = Just "combustible" + showProperty Infinite = Just "infinite" + showProperty Liquid = Just "liquid" + showProperty Unwalkable = Just "blocking" + showProperty Opaque = Just "opaque" + -- 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 + + displayList [] = emptyWidget + displayList ps = + vBox + [ hBox . L.intersperse (txt ", ") . map (withAttr robotAttr . txt) $ ps + , txt " " + ] + +-- | This widget can have potentially multiple "headings" +-- (one per capability), each with multiple commands underneath. +-- Directly below each heading there will be a "exercise cost" +-- description, unless the capability is free-to-exercise. +explainCapabilities :: GameState -> Entity -> Widget Name +explainCapabilities gs e + | null capabilitiesAndCommands = emptyWidget + | otherwise = + padBottom (Pad 1) $ + vBox + [ hBorderWithLabel (txt "Enabled commands") + , hCenter + . vBox + . L.intersperse (txt " ") -- Inserts an extra blank line between major "Cost" sections + $ map drawSingleCapabilityWidget capabilitiesAndCommands + ] + where + eLookup = lookupEntityE $ entitiesByName $ gs ^. landscape . terrainAndEntities . entityMap + 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 + ] + + drawSingleCapabilityWidget cmdsAndCost = + vBox + [ costWidget cmdsAndCost + , padLeft (Pad 1) . vBox . map renderCmdInfo . NE.toList $ enabledCommands cmdsAndCost + ] + + renderCmdInfo c = + Widget Fixed Fixed $ do + ctx <- getContext + let w = ctx ^. availWidthL + constType = inferConst c + info = constInfo c + requiredWidthForTypes = textWidth (syntax info <> " : " <> prettyTextLine constType) + render + . padTop (Pad 1) + $ vBox + [ hBox + [ padRight (Pad 1) (txt $ syntax info) + , padRight (Pad 1) (txt ":") + , if requiredWidthForTypes <= w + then withAttr magentaAttr . txt $ prettyTextLine constType + else emptyWidget + ] + , hBox $ + if requiredWidthForTypes > w + then + [ padRight (Pad 1) (txt " ") + , withAttr magentaAttr . txt $ prettyTextWidth constType (w - 2) + ] + else [emptyWidget] + , padTop (Pad 1) . padLeft (Pad 1) . txtWrap . briefDoc $ constDoc info + ] + + costWidget cmdsAndCost = + if null ings + then emptyWidget + else padTop (Pad 1) $ vBox $ withAttr boldAttr (txt "Cost:") : map drawCost ings + where + ings = ingredients $ commandCost cmdsAndCost + + drawCost (n, ingr) = + padRight (Pad 1) (str (show n)) <+> eName + where + eName = applyEntityNameAttr Nothing missing ingr $ txt $ ingr ^. entityName + missing = E.lookup ingr robotInv < n + + robotInv = fromMaybe E.empty $ gs ^? to focusedRobot . _Just . robotInventory + +explainRecipes :: AppState -> Entity -> Widget Name +explainRecipes s e + | null recipes = emptyWidget + | otherwise = + vBox + [ padBottom (Pad 1) (hBorderWithLabel (txt "Recipes")) + , padLeftRight 2 + . hCenter + . vBox + $ map (hLimit widthLimit . padBottom (Pad 1) . drawRecipe (Just e) inv) recipes + ] + where + recipes = recipesWith s e + + inv = fromMaybe E.empty $ s ^? gameState . to focusedRobot . _Just . robotInventory + + width (n, ingr) = + length (show n) + 1 + maximum0 (map T.length . T.words $ ingr ^. entityName) + + maxInputWidth = + fromMaybe 0 $ + maximumOf (traverse . recipeInputs . traverse . to width) recipes + maxOutputWidth = + fromMaybe 0 $ + maximumOf (traverse . recipeOutputs . traverse . to width) recipes + 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 + 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 + -- first since the first thing you will want to know when you + -- obtain a new entity is what you can do with it. + -- + -- 2. Recipes where it serves as a catalyst --- for the same reason. + -- + -- 3. Recipes where it is an output --- these should go last, + -- since if you have it, you probably already figured out how + -- to make it. + L.nub $ + concat + [ getRecipes recipesIn + , getRecipes recipesCat + , getRecipes recipesOut + ] + +-- | Draw an ASCII art representation of a recipe. For now, the +-- weight is not shown. +drawRecipe :: Maybe Entity -> Inventory -> Recipe Entity -> Widget Name +drawRecipe me inv (Recipe ins outs reqs time _weight) = + vBox + -- any requirements (e.g. furnace) go on top. + [ hCenter $ drawReqs reqs + , -- then we draw inputs, a connector, and outputs. + hBox + [ vBox (zipWith drawIn [0 ..] (ins <> times)) + , connector + , vBox (zipWith drawOut [0 ..] outs) + ] + ] + where + -- The connector is either just a horizontal line ───── + -- or, if there are requirements, a horizontal line with + -- a vertical piece coming out of the center, ──┴── . + connector + | null reqs = hLimit 5 hBorder + | otherwise = + hBox + [ hLimit 2 hBorder + , joinableBorder (Edges True False True True) + , hLimit 2 hBorder + ] + inLen = length ins + length times + outLen = length outs + times = [(fromIntegral time, timeE) | time /= 1] + + -- Draw inputs and outputs. + drawIn, drawOut :: Int -> (Count, Entity) -> Widget Name + drawIn i (n, ingr) = + hBox + [ padRight (Pad 1) $ str (show n) -- how many? + , fmtEntityName missing ingr -- name of the input + , padLeft (Pad 1) $ -- a connecting line: ─────┬ + hBorder + <+> ( joinableBorder (Edges (i /= 0) (i /= inLen - 1) True False) -- ...maybe plus vert ext: │ + <=> if i /= inLen - 1 + then vLimit (subtract 1 . length . T.words $ ingr ^. entityName) vBorder + else emptyWidget + ) + ] + where + missing = E.lookup ingr inv < n + + drawOut i (n, ingr) = + hBox + [ padRight (Pad 1) $ + ( joinableBorder (Edges (i /= 0) (i /= outLen - 1) False True) + <=> if i /= outLen - 1 + then vLimit (subtract 1 . length . T.words $ ingr ^. entityName) vBorder + else emptyWidget + ) + <+> hBorder + , fmtEntityName False ingr + , padLeft (Pad 1) $ str (show n) + ] + + -- If it's the focused entity, draw it highlighted. + -- If the robot doesn't have any, draw it in red. + fmtEntityName :: Bool -> Entity -> Widget n + fmtEntityName missing ingr = + applyEntityNameAttr me missing ingr $ txtLines nm + where + -- Split up multi-word names, one line per word + nm = ingr ^. entityName + txtLines = vBox . map txt . T.words + +applyEntityNameAttr :: Maybe Entity -> Bool -> Entity -> (Widget n -> Widget n) +applyEntityNameAttr me missing ingr + | Just ingr == me = withAttr highlightAttr + | ingr == timeE = withAttr yellowAttr + | missing = withAttr invalidFormInputAttr + | otherwise = id + +-- | Ad-hoc entity to represent time - only used in recipe drawing +timeE :: Entity +timeE = mkEntity (defaultEntityDisplay '.') "ticks" mempty [] mempty + +drawReqs :: IngredientList Entity -> Widget Name +drawReqs = vBox . map (hCenter . drawReq) + where + drawReq (1, e) = txt $ e ^. entityName + drawReq (n, e) = str (show n) <+> txt " " <+> txt (e ^. entityName) + +indent2 :: WrapSettings +indent2 = defaultWrapSettings {fillStrategy = FillIndent 2} + +-- | Only show the most recent entry, and any entries which were +-- produced by "say" or "log" commands. Other entries (i.e. errors +-- 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 + where + logEntries = s ^. gameState . to focusedRobot . _Just . robotLog + n = Seq.length logEntries + + shouldShow i le = + (i == n - 1) || case le ^. leSource of + RobotLog src _ _ -> src `elem` [Said, Logged] + SystemLog -> False + +drawRobotLog :: AppState -> Widget Name +drawRobotLog s = + vBox + [ padBottom (Pad 1) (hBorderWithLabel (txt "Log")) + , vBox . F.toList . imap drawEntry $ logEntriesToShow + ] + where + logEntriesToShow = getLogEntriesToShow s + n = length logEntriesToShow + drawEntry i e = + (if i == n - 1 && s ^. uiState . uiGameplay . uiScrollToEnd then visible else id) $ + drawLogEntry (not allMe) e + + rid = s ^? gameState . to focusedRobot . _Just . robotID + + allMe = all me logEntriesToShow + me le = case le ^. leSource of + RobotLog _ i _ -> Just i == rid + _ -> 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 + Nothing -> machineLine "no selected robot" + Just r -> + vBox + [ machineLine $ r ^. robotName <> "#" <> r ^. robotID . to tshow + , txt $ r ^. machine . to prettyText + ] + where + tshow = T.pack . show + hLine t = padBottom (Pad 1) (hBorderWithLabel (txt t)) + machineLine r = hLine $ if showName then "Machine [" <> r <> "]" else "Machine" + +-- | Draw one log entry with an optional robot name first. +drawLogEntry :: Bool -> LogEntry -> Widget a +drawLogEntry addName e = + withAttr (colorLogs e) . txtWrapWith indent2 $ + if addName then name else t + where + t = e ^. leText + name = + "[" + <> view leName e + <> "] " + <> case e ^. leSource of + RobotLog Said _ _ -> "said " <> quote t + _ -> t + +------------------------------------------------------------ +-- REPL panel +------------------------------------------------------------ + +-- | Turn the repl prompt into a decorator for the form +replPromptAsWidget :: Text -> REPLPrompt -> Widget Name +replPromptAsWidget _ (CmdPrompt _) = txt "> " +replPromptAsWidget t (SearchPrompt rh) = + case lastEntry t rh of + Nothing -> txt "[nothing found] " + Just lastentry + | T.null t -> txt "[find] " + | otherwise -> txt $ "[found: \"" <> lastentry <> "\"] " + +renderREPLPrompt :: FocusRing Name -> REPLState -> Widget Name +renderREPLPrompt focus theRepl = ps1 <+> replE + where + prompt = theRepl ^. replPromptType + replEditor = theRepl ^. replPromptEditor + color t = + case theRepl ^. replValid of + Right () -> txt t + Left NoLoc -> withAttr redAttr (txt t) + Left (SrcLoc s e) | s == e || s >= T.length t -> withAttr redAttr (txt t) + Left (SrcLoc s e) -> + let (validL, (invalid, validR)) = T.splitAt (e - s) <$> T.splitAt s t + in hBox [txt validL, withAttr redAttr (txt invalid), txt validR] + ps1 = replPromptAsWidget (T.concat $ getEditContents replEditor) prompt + replE = + renderEditor + (vBox . map color) + (focusGetCurrent focus `elem` [Nothing, Just (FocusablePanel REPLPanel), Just REPLInput]) + replEditor + +-- | Draw the REPL. +drawREPL :: AppState -> Widget Name +drawREPL s = + vBox + [ withLeftPaddedVScrollBars + . viewport REPLViewport Vertical + . vBox + $ [cached REPLHistoryCache (vBox history), currentPrompt] + , vBox mayDebug + ] + where + -- 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 + _running -> padRight Max $ txt "..." + theRepl = s ^. uiState . uiGameplay . 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 + + fmt (REPLHistItem itemType t) = case itemType of + REPLEntry {} -> txt $ "> " <> t + REPLOutput -> txt t + REPLError -> txtWrapWith indent2 {preserveIndentation = True} t + mayDebug = [drawRobotMachine s True | s ^. uiState . uiGameplay . uiShowDebug] + +------------------------------------------------------------ +-- Utility +------------------------------------------------------------ + +-- See https://github.com/jtdaugherty/brick/discussions/484 +withLeftPaddedVScrollBars :: Widget n -> Widget n +withLeftPaddedVScrollBars = + withVScrollBarRenderer (addLeftSpacing verticalScrollbarRenderer) + . withVScrollBars OnRight + where + addLeftSpacing :: VScrollbarRenderer n -> VScrollbarRenderer n + addLeftSpacing r = + r + { scrollbarWidthAllocation = 2 + , renderVScrollbar = hLimit 1 $ renderVScrollbar r + , renderVScrollbarTrough = hLimit 1 $ renderVScrollbarTrough r + } diff --git a/src/swarm-tui/Swarm/TUI/View/Achievement.hs b/src/swarm-tui/Swarm/TUI/View/Achievement.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Achievement.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.View.Achievement where + +import Brick +import Brick.Widgets.Border (borderWithLabel) +import Brick.Widgets.Center (hCenter) +import Brick.Widgets.List qualified as BL +import Control.Lens ((^.)) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Time.Format (defaultTimeLocale, formatTime) +import Swarm.Game.Achievement.Attainment +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 + +padAllEvenly :: Int -> Widget Name -> Widget Name +padAllEvenly x w = padTopBottom x $ padLeftRight (2 * x) w + +getCompletionIcon :: Bool -> Widget Name +getCompletionIcon = \case + False -> txt " ○ " + True -> withAttr greenAttr $ txt " ● " + +drawAchievementsMenuUI :: AppState -> BL.List Name CategorizedAchievement -> Widget Name +drawAchievementsMenuUI s l = + vBox + [ hCenter $ padTopBottom 1 $ str "🏆 Achievements 🏆 " + , hCenter $ + hBox + [ hLimitPercent 30 + . padAll 2 + $ BL.renderList (const $ drawAchievementListItem attainedMap) True l + , hLimitPercent 50 + . maybe emptyWidget (singleAchievementDetails attainedMap . snd) + $ BL.listSelectedElement l + ] + ] + where + attainedMap = s ^. uiState . uiAchievements + +drawAchievementListItem :: + Map CategorizedAchievement Attainment -> + CategorizedAchievement -> + Widget Name +drawAchievementListItem attainedMap x = + getCompletionIcon wasAttained <+> titleWidget + where + wasAttained = M.member x attainedMap + titleWidget = txtWrap $ title details + details = describe x + +singleAchievementDetails :: + Map CategorizedAchievement Attainment -> + CategorizedAchievement -> + Widget Name +singleAchievementDetails attainedMap x = + padRight (Pad 1) . borderWithLabel titleWidget . padRight Max . padAllEvenly 1 $ innerContent + where + wasAttained = M.member x attainedMap + + renderFlavorTextWidget :: FlavorText -> Widget Name + renderFlavorTextWidget (Freeform t) = drawMarkdown t + renderFlavorTextWidget (FTQuotation (Quotation author quoteContent)) = + vBox + [ txtWrap quoteContent + , padLeft Max + . padRight (Pad 2) + . txtWrapWith (defaultWrapSettings {fillStrategy = FillIndent 2}) + $ "--" <> author + ] + + innerContent = + vBox + [ maybe emptyWidget (padAllEvenly 2 . renderFlavorTextWidget) $ humorousElaboration details + , if wasAttained || not (isObfuscated details) + then drawMarkdown $ attainmentProcess details + else txt "???" + , case M.lookup x attainedMap of + Nothing -> emptyWidget + Just attainment -> + padTop (Pad 1) $ + vBox + [ hBox + [ txt "Obtained: " + , withAttr cyanAttr + . str + . formatTime defaultTimeLocale "%l:%M%P on %b %e, %Y" + $ attainment ^. obtainedAt + ] + , flip (maybe emptyWidget) (attainment ^. maybeScenarioPath) $ \s -> + hBox + [ txt "Scenario: " + , withAttr cyanAttr $ + str s + ] + ] + , padTop (Pad 1) $ + hBox + [ txt "Effort: " + , withAttr boldAttr . str . show $ effort details + ] + ] + + titleWidget = padLeftRight 1 $ txt $ title details + details = describe x diff --git a/src/swarm-tui/Swarm/TUI/View/Attribute/Attr.hs b/src/swarm-tui/Swarm/TUI/View/Attribute/Attr.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Attribute/Attr.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Rendering attributes (/i.e./ foreground and background colors, +-- styles, /etc./) used by the Swarm TUI. +-- +-- We export constants only for those we use in the Haskell code +-- and not those used in the world map, to avoid abusing attributes. +-- For example using the robot attribute to highlight some text. +-- +-- The few attributes that we use for drawing the logo are an exception. +module Swarm.TUI.View.Attribute.Attr ( + swarmAttrMap, + worldAttributes, + worldPrefix, + meterAttributeNames, + messageAttributeNames, + toAttrName, + getWorldAttrName, + mkBrickColor, + + -- ** Common attributes + entityAttr, + robotAttr, + + -- ** Swarm TUI Attributes + highlightAttr, + notifAttr, + infoAttr, + boldAttr, + italicAttr, + dimAttr, + magentaAttr, + cyanAttr, + lightCyanAttr, + yellowAttr, + blueAttr, + greenAttr, + redAttr, + grayAttr, + defAttr, + customEditFocusedAttr, +) where + +import Brick +import Brick.Forms (focusedFormInputAttr, invalidFormInputAttr) +import Brick.Widgets.Dialog +import Brick.Widgets.Edit qualified as E +import Brick.Widgets.List (listSelectedFocusedAttr) +import Control.Arrow ((***)) +import Data.Colour.Palette.BrewerSet +import Data.Colour.SRGB (RGB (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Text (unpack) +import Graphics.Vty qualified as V +import Swarm.Game.Display (Attribute (..)) +import Swarm.Game.Entity.Cosmetic +import Swarm.Game.Entity.Cosmetic.Assignment +import Swarm.TUI.View.Attribute.Util + +toAttrName :: Attribute -> AttrName +toAttrName = \case + ARobot -> robotAttr + AEntity -> entityAttr + AWorld n -> worldPrefix <> attrName (unpack n) + ADefault -> defAttr + +toVtyAttr :: PreservableColor -> V.Attr +toVtyAttr hifi = case fmap mkBrickColor hifi of + FgOnly c -> fg c + BgOnly c -> bg c + FgAndBg foreground background -> foreground `on` background + +mkBrickColor :: TrueColor -> V.Color +mkBrickColor = \case + Triple (RGB r g b) -> V.linearColor r g b + AnsiColor x -> case x of + White -> V.white + BrightRed -> V.brightRed + Red -> V.red + Green -> V.green + Blue -> V.blue + BrightYellow -> V.brightYellow + Yellow -> V.yellow + +-- | A mapping from the defined attribute names to TUI attributes. +swarmAttrMap :: AttrMap +swarmAttrMap = + attrMap + V.defAttr + $ NE.toList activityMeterAttributes + <> NE.toList robotMessageAttributes + <> map (getWorldAttrName *** toVtyAttr) (M.toList worldAttributes) + <> [ -- Robot attribute + (robotAttr, fg V.white `V.withStyle` V.bold) + , -- UI rendering attributes + (highlightAttr, fg V.cyan) + , (invalidFormInputAttr, fg V.red) + , (focusedFormInputAttr, V.defAttr) + , (customEditFocusedAttr, V.black `on` V.yellow) + , (listSelectedFocusedAttr, bg V.blue) + , (infoAttr, fg (V.rgbColor @Int 100 100 100)) + , (buttonSelectedAttr, bg V.blue) + , (notifAttr, fg V.yellow `V.withStyle` V.bold) + , (dimAttr, V.defAttr `V.withStyle` V.dim) + , (boldAttr, V.defAttr `V.withStyle` V.bold) + , (italicAttr, V.defAttr `V.withStyle` V.italic) + , -- Basic colors + (redAttr, fg V.red) + , (greenAttr, fg V.green) + , (blueAttr, fg V.blue) + , (yellowAttr, fg V.yellow) + , (cyanAttr, fg V.cyan) + , (lightCyanAttr, fg (V.rgbColor @Int 200 255 255)) + , (magentaAttr, fg V.magenta) + , (grayAttr, fg (V.rgbColor @Int 128 128 128)) + , -- Default attribute + (defAttr, V.defAttr) + ] + +worldPrefix :: AttrName +worldPrefix = attrName "world" + +getWorldAttrName :: WorldAttr -> AttrName +getWorldAttrName (WorldAttr n) = worldPrefix <> attrName n + +entityAttr :: AttrName +entityAttr = getWorldAttrName $ fst entity + +robotMessagePrefix :: AttrName +robotMessagePrefix = attrName "robotMessage" + +robotMessageAttributes :: NonEmpty (AttrName, V.Attr) +robotMessageAttributes = + NE.zip indices $ fromMaybe (pure $ fg V.white) $ NE.nonEmpty brewers + where + indices = NE.map ((robotMessagePrefix <>) . attrName . show) $ (0 :: Int) :| [1 ..] + brewers = map (fg . kolorToAttrColor) $ brewerSet Set3 12 + +messageAttributeNames :: NonEmpty AttrName +messageAttributeNames = NE.map fst robotMessageAttributes + +activityMeterPrefix :: AttrName +activityMeterPrefix = attrName "activityMeter" + +activityMeterAttributes :: NonEmpty (AttrName, V.Attr) +activityMeterAttributes = + NE.zip indices $ fromMaybe (pure $ bg V.black) $ NE.nonEmpty brewers + where + indices = NE.map ((activityMeterPrefix <>) . attrName . show) $ (0 :: Int) :| [1 ..] + brewers = map bgWithAutoForeground $ reverse $ brewerSet RdYlGn 7 + +meterAttributeNames :: NonEmpty AttrName +meterAttributeNames = NE.map fst activityMeterAttributes + +-- | The default robot attribute. +robotAttr :: AttrName +robotAttr = attrName "robot" + +-- | Some defined attribute names used in the Swarm TUI. +highlightAttr + , notifAttr + , infoAttr + , boldAttr + , italicAttr + , dimAttr + , defAttr :: + AttrName +highlightAttr = attrName "highlight" +notifAttr = attrName "notif" +infoAttr = attrName "info" +boldAttr = attrName "bold" +italicAttr = attrName "italics" +dimAttr = attrName "dim" +defAttr = attrName "def" + +customEditFocusedAttr :: AttrName +customEditFocusedAttr = attrName "custom" <> E.editFocusedAttr + +-- | Some basic colors used in TUI. +redAttr, greenAttr, blueAttr, yellowAttr, cyanAttr, lightCyanAttr, magentaAttr, grayAttr :: AttrName +redAttr = attrName "red" +greenAttr = attrName "green" +blueAttr = attrName "blue" +yellowAttr = attrName "yellow" +cyanAttr = attrName "cyan" +lightCyanAttr = attrName "lightCyan" +magentaAttr = attrName "magenta" +grayAttr = attrName "gray" diff --git a/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs b/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs @@ -0,0 +1,36 @@ +-- | +-- 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 +import Swarm.TUI.View.Attribute.Util + +toStyle :: StyleFlag -> Style +toStyle = \case + Standout -> standout + Italic -> italic + Strikethrough -> strikethrough + Underline -> underline + ReverseVideo -> reverseVideo + Blink -> blink + Dim -> dim + Bold -> bold + +hexToAttrColor :: HexColor -> Color +hexToAttrColor (HexColor colorText) = + kolorToAttrColor c + where + c = sRGB24read $ T.unpack colorText + +toAttrPair :: CustomAttr -> (WorldAttr, Attr) +toAttrPair ca = + (WorldAttr (name ca), addStyle $ addFg $ addBg defAttr) + where + addFg = maybe id (flip withForeColor . hexToAttrColor) $ fg ca + addBg = maybe id (flip withBackColor . hexToAttrColor) $ bg ca + addStyle = maybe id (flip withStyle . sum . map toStyle . toList) $ style ca diff --git a/src/swarm-tui/Swarm/TUI/View/Attribute/Util.hs b/src/swarm-tui/Swarm/TUI/View/Attribute/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Attribute/Util.hs @@ -0,0 +1,28 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.View.Attribute.Util where + +import Brick.Util (on) +import Data.Colour.CIE (luminance) +import Data.Colour.Palette.BrewerSet (Kolor) +import Data.Colour.SRGB (RGB (..), toSRGB24) +import Graphics.Vty qualified as V +import Graphics.Vty.Attributes (Attr, Color (RGBColor)) + +kolorToAttrColor :: Kolor -> Color +kolorToAttrColor c = + RGBColor r g b + where + RGB r g b = toSRGB24 c + +-- | Automatically selects black or white for the foreground +-- based on the luminance of the supplied background. +bgWithAutoForeground :: Kolor -> Attr +bgWithAutoForeground c = fgColor `on` kolorToAttrColor c + where + fgColor = + -- "white" is actually gray-ish, so we nudge the threshold + -- below 0.5. + if luminance c > 0.4 + then V.black + else V.white diff --git a/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs b/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Rendering of cells in the map view +-- +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.View.CellDisplay where + +import Brick +import Control.Lens (to, view, (&), (.~), (^.)) +import Data.ByteString (ByteString) +import Data.Hash.Murmur +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (maybeToList) +import Data.Semigroup (sconcat) +import Data.Set (Set) +import Data.Set qualified as S +import Data.Tagged (unTagged) +import Data.Word (Word32) +import Graphics.Vty qualified as V +import Linear.Affine ((.-.)) +import Swarm.Game.Display ( + Attribute (AEntity), + Display, + defaultEntityDisplay, + displayAttr, + displayChar, + displayPriority, + hidden, + ) +import Swarm.Game.Entity +import Swarm.Game.Land +import Swarm.Game.Robot +import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByLocation) +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Terrain +import Swarm.Game.Tick (TickNumber (..)) +import Swarm.Game.Universe +import Swarm.Game.World qualified as W +import Swarm.Game.World.Coords +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.View.Attribute.Attr +import Swarm.Util (applyWhen) +import Witch (from) +import Witch.Encoding qualified as Encoding + +-- | Render a display as a UI widget. +renderDisplay :: Display -> Widget n +renderDisplay disp = withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp] + +-- | Render the 'Display' for a specific location. +drawLoc :: UIGameplay -> GameState -> Cosmic Coords -> Widget Name +drawLoc ui g cCoords@(Cosmic _ coords) = + if shouldHideWorldCell ui coords + then str " " + else boldStructure drawCell + where + showRobots = ui ^. uiShowRobots + we = ui ^. uiWorldEditor . worldOverdraw + drawCell = renderDisplay $ displayLoc showRobots we g cCoords + + boldStructure = applyWhen isStructure $ modifyDefAttr (`V.withStyle` V.bold) + where + sMap = foundByLocation $ g ^. discovery . structureRecognition . foundStructures + isStructure = M.member (coordsToLoc <$> cCoords) sMap + +-- | Subset of the game state needed to render the world +data RenderingInput = RenderingInput + { multiworldInfo :: W.MultiWorld Int Entity + , isKnownFunc :: EntityPaint -> Bool + , terrMap :: TerrainMap + } + +displayTerrainCell :: + WorldOverdraw -> + RenderingInput -> + Cosmic Coords -> + Display +displayTerrainCell worldEditor ri coords = + maybe mempty terrainDisplay $ M.lookup t tm + where + tm = terrainByName $ terrMap ri + t = EU.getEditorTerrainAt (terrMap ri) worldEditor (multiworldInfo ri) coords + +displayRobotCell :: + GameState -> + Cosmic Coords -> + [Display] +displayRobotCell g coords = + map (view robotDisplay) $ + robotsAtLocation (fmap coordsToLoc coords) g + +-- | Extract the relevant subset of information from the 'GameState' to be able +-- to compute whether an entity is "known". +mkEntityKnowledge :: GameState -> EntityKnowledgeDependencies +mkEntityKnowledge gs = + EntityKnowledgeDependencies + { isCreativeMode = gs ^. creativeMode + , globallyKnownEntities = gs ^. discovery . knownEntities + , theFocusedRobot = focusedRobot gs + } + +-- | The subset of information required to compute whether +-- an entity is "known", and therefore should be rendered +-- normally vs as a question mark. +data EntityKnowledgeDependencies = EntityKnowledgeDependencies + { isCreativeMode :: Bool + , globallyKnownEntities :: Set EntityName + , theFocusedRobot :: Maybe Robot + } + +-- | Determines whether an entity should be rendered +-- normally vs as a question mark. +getEntityIsKnown :: EntityKnowledgeDependencies -> EntityPaint -> Bool +getEntityIsKnown knowledge ep = case ep of + Facade (EntityFacade _ _) -> True + Ref e -> or reasonsToShow + where + reasonsToShow = + [ isCreativeMode knowledge + , e `hasProperty` Known + , (e ^. entityName) `S.member` globallyKnownEntities knowledge + , showBasedOnRobotKnowledge + ] + showBasedOnRobotKnowledge = maybe False (`robotKnows` e) $ theFocusedRobot knowledge + +displayEntityCell :: + WorldOverdraw -> + RenderingInput -> + Cosmic Coords -> + [Display] +displayEntityCell worldEditor ri coords = + maybeToList $ displayForEntity <$> maybeEntity + where + (_, maybeEntity) = EU.getEditorContentAt (terrMap ri) worldEditor (multiworldInfo ri) coords + + displayForEntity :: EntityPaint -> Display + displayForEntity e = (if isKnownFunc ri e then id else 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 +-- taking into account "static" based on the distance to the robot +-- being @view@ed. +displayLoc :: Bool -> WorldOverdraw -> GameState -> Cosmic Coords -> Display +displayLoc showRobots we g cCoords@(Cosmic _ coords) = + staticDisplay g coords + <> displayLocRaw we ri robots cCoords + where + ri = + RenderingInput + (g ^. landscape . multiWorld) + (getEntityIsKnown $ mkEntityKnowledge g) + (g ^. landscape . terrainAndEntities . terrainMap) + + robots = + if showRobots + then displayRobotCell g cCoords + else [] + +-- | Get the 'Display' for a specific location, by combining the +-- 'Display's for the terrain, entity, and robots at the location. +displayLocRaw :: + WorldOverdraw -> + RenderingInput -> + -- | Robot displays + [Display] -> + Cosmic Coords -> + Display +displayLocRaw worldEditor ri robotDisplays coords = + sconcat $ terrain NE.:| entity <> robotDisplays + where + terrain = displayTerrainCell worldEditor ri coords + entity = displayEntityCell worldEditor ri coords + +-- | Random "static" based on the distance to the robot being +-- @view@ed. +staticDisplay :: GameState -> Coords -> Display +staticDisplay g coords = maybe mempty displayStatic (getStatic g coords) + +-- | Draw static given a number from 0-15 representing the state of +-- the four quarter-pixels in a cell +displayStatic :: Word32 -> Display +displayStatic s = + defaultEntityDisplay (staticChar s) + & displayPriority .~ maxBound -- Static has higher priority than anything else + & displayAttr .~ AEntity + +-- | Given a value from 0--15, considered as 4 bits, pick the +-- character with the corresponding quarter pixels turned on. +staticChar :: Word32 -> Char +staticChar = \case + 0 -> ' ' + 1 -> '▖' + 2 -> '▗' + 3 -> '▄' + 4 -> '▘' + 5 -> '▌' + 6 -> '▚' + 7 -> '▙' + 8 -> '▝' + 9 -> '▞' + 10 -> '▐' + 11 -> '▟' + 12 -> '▀' + 13 -> '▛' + 14 -> '▜' + 15 -> '█' + _ -> ' ' + +-- | Random "static" based on the distance to the robot being +-- @view@ed. A cell can either be static-free (represented by +-- @Nothing@) or can have one of sixteen values (representing the +-- state of the four quarter-pixels in one cell). +getStatic :: GameState -> Coords -> Maybe Word32 +getStatic g coords + | isStatic = Just (h `mod` 16) + | otherwise = Nothing + where + -- Offset from the location of the view center to the location under + -- consideration for display. + offset = coordsToLoc coords .-. (g ^. robotInfo . viewCenter . planar) + + -- Hash. + h = + murmur3 1 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ + -- include the current tick count / 16 in the hash, so the pattern of static + -- changes once every 16 ticks + (offset, getTickNumber (g ^. temporal . ticks) `div` 16) + + -- Hashed probability, i.e. convert the hash into a floating-point number between 0 and 1 + hp :: Double + hp = fromIntegral h / fromIntegral (maxBound :: Word32) + + isStatic = case focusedRange g of + -- If we're not viewing a robot, display static. This + -- can happen if e.g. the robot we were viewing drowned. + -- This is overridden by creative mode, e.g. when no robots + -- have been defined for the scenario. + Nothing -> not $ g ^. creativeMode + -- Don't display static if the robot is close, or when we're in + -- creative mode or the player is allowed to scroll the world. + Just Close -> False + -- At medium distances, replace cell with static with a + -- probability that increases with distance. + Just (MidRange s) -> hp < 1 - cos (s * (pi / 2)) + -- Far away, everything is static. + Just Far -> True diff --git a/src/swarm-tui/Swarm/TUI/View/Logo.hs b/src/swarm-tui/Swarm/TUI/View/Logo.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Logo.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Code for drawing the Swarm logo. +module Swarm.TUI.View.Logo where + +import Brick +import Brick.Widgets.Center (centerLayer) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Game.Entity.Cosmetic.Assignment +import Swarm.TUI.Model.Name +import Swarm.TUI.View.Attribute.Attr + +drawLogo :: Text -> Widget Name +drawLogo = centerLayer . vBox . map (hBox . T.foldr (\c ws -> drawThing c : ws) []) . T.lines + where + drawThing :: Char -> Widget Name + drawThing c = withAttr (attrFor c) $ str [c] + + attrFor :: Char -> AttrName + attrFor c + | c `elem` ("<>v^" :: String) = robotAttr + attrFor 'T' = plantAttr + attrFor '@' = rockAttr + attrFor '~' = waterAttr + attrFor '▒' = dirtAttr + attrFor _ = defAttr + + waterAttr :: AttrName + waterAttr = getWorldAttrName $ fst water + + rockAttr :: AttrName + rockAttr = getWorldAttrName $ fst rock + + plantAttr :: AttrName + plantAttr = getWorldAttrName $ fst plant + + dirtAttr :: AttrName + dirtAttr = getWorldAttrName $ fst dirt diff --git a/src/swarm-tui/Swarm/TUI/View/Objective.hs b/src/swarm-tui/Swarm/TUI/View/Objective.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Objective.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Display logic for Objectives. +module Swarm.TUI.View.Objective where + +import Brick hiding (Direction, Location) +import Brick.Focus +import Brick.Widgets.Center +import Brick.Widgets.List qualified as BL +import Control.Applicative ((<|>)) +import Control.Lens hiding (Const, from) +import Data.List (intercalate) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as M +import Data.Vector qualified as V +import Swarm.Game.Scenario.Objective +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.Name +import Swarm.TUI.View.Attribute.Attr +import Swarm.TUI.View.Util +import Swarm.Util (applyWhen) + +makeListWidget :: GoalTracking -> BL.List Name GoalEntry +makeListWidget (GoalTracking _announcements categorizedObjs) = + BL.listMoveTo 1 $ BL.list (GoalWidgets ObjectivesList) (V.fromList objList) 1 + where + objList = intercalate [Spacer] $ map f $ M.toList categorizedObjs + f (h, xs) = Header h : map (Goal h) (NE.toList xs) + +renderGoalsDisplay :: GoalDisplay -> Maybe (Document Syntax) -> Widget Name +renderGoalsDisplay gd desc = + vBox + [ maybe emptyWidget (hCenter . padTop (Pad 1) . withAttr boldAttr . drawMarkdown) desc + , goalsWidget + ] + where + goalsWidget + | hasMultiple = + vBox + [ hBox + [ leftSide + , padLeft (Pad 2) goalElaboration + ] + , footer + ] + | otherwise = goalElaboration + + footer = hCenter $ withAttr italicAttr $ txt "NOTE: [Tab] toggles focus between panes" + hasMultiple = hasMultipleGoals $ gd ^. goalsContent + lw = _listWidget gd + fr = _focus gd + leftSide = + hLimitPercent 30 $ + padAll 1 $ + vBox + [ hCenter $ str "Goals" + , padAll 1 $ + vLimit 10 $ + withFocusRing fr (BL.renderList drawGoalListItem) lw + ] + + -- Adds very subtle coloring to indicate focus switch + highlightIfFocused = case (hasMultiple, focusGetCurrent fr) of + (True, Just (GoalWidgets GoalSummary)) -> withAttr lightCyanAttr + _ -> id + + -- Note: An extra "padRight" is inserted to account for the vertical scrollbar, + -- whether or not it appears. + goalElaboration = + clickable (GoalWidgets GoalSummary) + . maybeScroll ModalViewport + . maybe emptyWidget (padAll 1 . padRight (Pad 1) . highlightIfFocused . singleGoalDetails . snd) + $ BL.listSelectedElement lw + +getCompletionIcon :: Objective -> GoalStatus -> Widget Name +getCompletionIcon obj = \case + Upcoming -> withAttr yellowAttr $ txt " ○ " + Active -> withAttr cyanAttr $ txt " ○ " + Failed -> withAttr redAttr $ txt " ● " + Completed -> withAttr colorAttr $ txt " ● " + where + colorAttr = + if obj ^. objectiveHidden + then magentaAttr + else greenAttr + +drawGoalListItem :: + Bool -> + GoalEntry -> + Widget Name +drawGoalListItem _isSelected e = case e of + Spacer -> str " " + Header gs -> withAttr boldAttr $ str $ show gs + Goal gs obj -> getCompletionIcon obj gs <+> titleWidget + where + textSource = obj ^. objectiveTeaser <|> obj ^. objectiveId <|> Just (Markdown.docToText $ obj ^. objectiveGoal) + titleWidget = maybe (txt "?") (titleColor . withEllipsis End) textSource + titleColor = applyWhen (obj ^. objectiveOptional) $ withAttr grayAttr + +singleGoalDetails :: GoalEntry -> Widget Name +singleGoalDetails = \case + Goal _gs obj -> + vBox + [ optionalIndicator + , drawMarkdown $ obj ^. objectiveGoal + ] + where + optionalIndicator = + if obj ^. objectiveOptional + then withAttr grayAttr $ txt "[Optional]" + else emptyWidget + -- Only Goal entries are selectable, so we should never see this: + _ -> emptyWidget diff --git a/src/swarm-tui/Swarm/TUI/View/Popup.hs b/src/swarm-tui/Swarm/TUI/View/Popup.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Popup.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Rendering (& animating) notification popups. +module Swarm.TUI.View.Popup where + +import Brick (Widget (..), cropTopTo, padLeftRight, txt, vBox) +import Brick.Widgets.Border (border) +import Brick.Widgets.Center (hCenterLayer) +import Brick.Widgets.Core (emptyWidget, hBox, withAttr) +import Control.Lens ((^.)) +import Swarm.Game.Achievement.Definitions (title) +import Swarm.Game.Achievement.Description (describe) +import Swarm.Language.Syntax (constInfo, syntax) +import Swarm.TUI.Model (AppState, Name, uiState) +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.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 + +-- | 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 + +drawPopup :: AppState -> Popup -> Widget Name +drawPopup s = \case + AchievementPopup ach -> + hBox + [ withAttr notifAttr (txt "Achievement unlocked: ") + , txt (title (describe ach)) + ] + RecipesPopup -> + hBox + [ withAttr notifAttr (txt "New recipes unlocked! ") + , txt $ bindingText s (SE.Main SE.ViewRecipesEvent) <> " to view." + ] + CommandsPopup cmds -> + vBox + [ hBox + [ 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." + ] + +-- | Compute the number of rows of the notification popup we should be +-- showing, based on the number of 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 diff --git a/src/swarm-tui/Swarm/TUI/View/Structure.hs b/src/swarm-tui/Swarm/TUI/View/Structure.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Structure.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Display logic for Structures. +module Swarm.TUI.View.Structure ( + renderStructuresDisplay, + makeListWidget, +) where + +import Brick hiding (Direction, Location, getName) +import Brick.Focus +import Brick.Widgets.Center (hCenter) +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (Const, from) +import Data.Map.NonEmpty qualified as NEM +import Data.Map.Strict qualified as M +import Data.Set qualified as Set +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.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.Type +import Swarm.Game.State +import Swarm.Game.State.Substate (structureRecognition) +import Swarm.Language.Syntax.Direction (directionJsonModifier) +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.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 gs s = + vBox + [ hBox + [ headerItem "Name" theName + , padLeft (Pad 2) + . headerItem "Size" + . T.pack + . renderRectDimensions + . getAreaDimensions + $ entityProcessedGrid s + , occurrenceCountSuffix + ] + , reorientabilityWidget + , maybeDescriptionWidget + , padTop (Pad 1) $ + hBox + [ structureIllustration + , padLeft (Pad 4) ingredientsBox + ] + ] + where + headerItem h content = + hBox + [ padRight (Pad 1) $ txt $ h <> ":" + , withAttr boldAttr $ txt content + ] + + annotatedStructureGrid = annotatedGrid s + + supportedOrientations = Set.toList . Structure.recognize . namedGrid $ annotatedStructureGrid + + renderSymmetry = \case + NoSymmetry -> "no" + TwoFold -> "2-fold" + FourFold -> "4-fold" + + reorientabilityWidget = + txt $ + T.unwords + [ "Orientable:" + , commaList $ map (T.pack . directionJsonModifier . show) supportedOrientations + , "with" + , renderSymmetry $ symmetry annotatedStructureGrid + , "rotational symmetry." + ] + + maybeDescriptionWidget = + maybe emptyWidget (padTop (Pad 1) . withAttr italicAttr . txtWrap) $ + Structure.description . namedGrid . annotatedGrid $ + s + + registry = gs ^. discovery . structureRecognition . foundStructures + occurrenceCountSuffix = case M.lookup theName $ foundByName registry of + Nothing -> emptyWidget + 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 + [ padBottom (Pad 1) $ withAttr boldAttr $ txt "Materials:" + , ingredientLines + ] + ingredientLines = vBox . map showCount . M.toList $ entityCounts s + + showCount (e, c) = + hBox + [ drawLabelledEntityName e + , txt $ + T.unwords + [ ":" + , T.pack $ show c + ] + ] + + theName = getStructureName $ Structure.name d + cells = getEntityGrid d + renderOneCell = maybe (txt " ") (renderDisplay . view entityDisplay) + +makeListWidget :: [StructureInfo StructureCells Entity] -> BL.List Name (StructureInfo StructureCells Entity) +makeListWidget structureDefinitions = + BL.listMoveTo 0 $ BL.list (StructureWidgets StructuresList) (V.fromList structureDefinitions) 1 + +renderStructuresDisplay :: GameState -> StructureDisplay -> Widget Name +renderStructuresDisplay gs structureDisplay = + vBox + [ hBox + [ leftSide + , padLeft (Pad 2) structureElaboration + ] + , footer + ] + where + footer = hCenter $ withAttr italicAttr $ txt "NOTE: [Tab] toggles focus between panes" + lw = _structurePanelListWidget structureDisplay + fr = _structurePanelFocus structureDisplay + leftSide = + hLimitPercent 25 $ + padAll 1 $ + vBox + [ hCenter $ withAttr boldAttr $ txt "Candidates" + , padAll 1 $ + vLimit 10 $ + withFocusRing fr (BL.renderList drawSidebarListItem) lw + ] + + -- Adds very subtle coloring to indicate focus switch + highlightIfFocused = case focusGetCurrent fr of + Just (StructureWidgets StructureSummary) -> withAttr lightCyanAttr + _ -> id + + -- Note: An extra "padRight" is inserted to account for the vertical scrollbar, + -- whether or not it appears. + structureElaboration = + clickable (StructureWidgets StructureSummary) + . maybeScroll ModalViewport + . maybe emptyWidget (padAll 1 . padRight (Pad 1) . highlightIfFocused . structureWidget gs . snd) + $ BL.listSelectedElement lw + +drawSidebarListItem :: + Bool -> + StructureInfo StructureCells Entity -> + Widget Name +drawSidebarListItem _isSelected (StructureInfo annotated _ _) = + txt . getStructureName . Structure.name $ namedGrid annotated diff --git a/src/swarm-tui/Swarm/TUI/View/Util.hs b/src/swarm-tui/Swarm/TUI/View/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/View/Util.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.View.Util where + +import Brick hiding (Direction, Location) +import Brick.Keybindings (Binding (..), 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.Map.Strict qualified as M +import Data.Maybe (catMaybes, fromMaybe) +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.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.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent) +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Attribute.Attr +import Swarm.TUI.View.CellDisplay +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)) + where + currentScenario = s ^. uiState . uiGameplay . scenarioRef + currentSeed = s ^. gameState . randomness . seed + haltingMessage = case s ^. uiState . uiMenu of + NoMenu -> Just "Quit" + _ -> Nothing + descriptionWidth = 100 + (title, buttons, requiredWidth) = + case mt of + HelpModal -> (" Help ", Nothing, descriptionWidth) + RobotsModal -> ("Robots", Nothing, descriptionWidth) + RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) + 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 + 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) + w = wordLength + 6 + EntityPaletteModal -> ("Entity", Nothing, 30) + +-- | Render the type of the current REPL input to be shown to the user. +drawType :: Polytype -> Widget Name +drawType ty = Widget Fixed Fixed $ do + ctx <- getContext + let w = ctx ^. availWidthL + renderedTy = prettyTextLine ty + displayedTy + | T.length renderedTy <= w `div` 2 - 2 = renderedTy + | otherwise = T.take (w `div` 2 - 2 - 3) renderedTy <> "..." + render . withAttr infoAttr . padLeftRight 1 . txt $ displayedTy + +-- | Draw markdown document with simple code/bold/italic attributes. +-- +-- TODO: #574 Code blocks should probably be handled separately. +drawMarkdown :: Markdown.Document Syntax -> Widget Name +drawMarkdown d = do + Widget Greedy Fixed $ do + ctx <- getContext + let w = ctx ^. availWidthL + let docLines = Markdown.chunksOf w . Markdown.toStream <$> Markdown.paragraphs d + render . layoutParagraphs $ vBox . map (hBox . map mTxt) <$> docLines + where + mTxt = \case + Markdown.TextNode as t -> foldr applyAttr (txt t) as + Markdown.CodeNode t -> withAttr highlightAttr $ txt t + Markdown.RawNode f t -> withAttr (rawAttr f) $ txt t + applyAttr a = withAttr $ case a of + Markdown.Strong -> boldAttr + Markdown.Emphasis -> italicAttr + rawAttr = \case + "entity" -> greenAttr + "structure" -> redAttr + "tag" -> yellowAttr + "type" -> magentaAttr + _snippet -> highlightAttr -- same as plain code + +drawLabeledTerrainSwatch :: TerrainMap -> TerrainType -> Widget Name +drawLabeledTerrainSwatch tm a = + tile <+> str materialName + where + tile = + padRight (Pad 1) + . renderDisplay + . maybe mempty terrainDisplay + $ M.lookup a (terrainByName tm) + + materialName = init $ show a + +descriptionTitle :: Entity -> String +descriptionTitle e = " " ++ from @Text (e ^. entityName) ++ " " + +-- | Width cap for modal and error message windows +maxModalWindowWidth :: Int +maxModalWindowWidth = 500 + +-- | Get the name of the current New Game menu. +curMenuName :: AppState -> Maybe Text +curMenuName s = case s ^. uiState . uiMenu of + NewGameMenu (_ :| (parentMenu : _)) -> + Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName) + NewGameMenu _ -> Just "Scenarios" + _ -> Nothing + +quitMsg :: Menu -> Text +quitMsg m = "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] + +-- | Display a list of text-wrapped paragraphs with one blank line after each. +displayParagraphs :: [Text] -> Widget Name +displayParagraphs = layoutParagraphs . map txtWrap + +-- | Display a list of paragraphs with one blank line after each. +-- +-- For the common case of `[Text]` use 'displayParagraphs'. +layoutParagraphs :: [Widget Name] -> Widget Name +layoutParagraphs ps = vBox $ padBottom (Pad 1) <$> ps + +data EllipsisSide = Beginning | End + +withEllipsis :: EllipsisSide -> Text -> Widget Name +withEllipsis side t = + Widget Greedy Fixed $ do + ctx <- getContext + let w = ctx ^. availWidthL + ellipsis = T.replicate 3 $ T.singleton '.' + tLength = T.length t + newText = + if tLength > w + then case side of + Beginning -> ellipsis <> T.drop (w - T.length ellipsis) t + End -> T.take (w - T.length ellipsis) t <> ellipsis + else t + render $ txt newText + +-- | Make a widget scrolling if it is bigger than the available +-- vertical space. Thanks to jtdaugherty for this code. +maybeScroll :: (Ord n, Show n) => n -> Widget n -> Widget n +maybeScroll vpName contents = + Widget Greedy Greedy $ do + ctx <- getContext + result <- withReaderT (availHeightL .~ 10000) (render contents) + if V.imageHeight (result ^. imageL) <= ctx ^. availHeightL + then return result + else + render + . withVScrollBars OnRight + . viewport vpName Vertical + . Widget Fixed Fixed + $ return result + +-- | Draw the name of an entity, labelled with its visual +-- representation as a cell in the world. +drawLabelledEntityName :: Entity -> Widget n +drawLabelledEntityName e = + hBox + [ padRight (Pad 2) (renderDisplay (e ^. entityDisplay)) + , txt (e ^. entityName) + ] + +-- | Render the keybinding bound to a specific event. +bindingText :: AppState -> SwarmEvent -> Text +bindingText s e = maybe "" ppBindingShort b + where + conf = s ^. keyEventHandling . keyConfig + b = firstActiveBinding conf e + ppBindingShort = \case + Binding V.KUp m | null m -> "↑" + Binding V.KDown m | null m -> "↓" + Binding V.KLeft m | null m -> "←" + Binding V.KRight m | null m -> "→" + bi -> ppBinding bi diff --git a/src/swarm-util/Control/Carrier/Accum/FixedStrict.hs b/src/swarm-util/Control/Carrier/Accum/FixedStrict.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Control/Carrier/Accum/FixedStrict.hs @@ -0,0 +1,139 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/swarm-util/Data/BoolExpr/Simplify.hs @@ -0,0 +1,60 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Simplification logic for boolean expressions that is not +-- provided in the 'boolexpr' package. +module Data.BoolExpr.Simplify ( + cannotBeTrue, + replace, +) where + +import Data.BoolExpr +import Data.List qualified as L +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set qualified as S + +-- | Used only by "hasContradiction". +-- Note that the Booleans returned in this tuple are not actually used +-- as conditions, and therefore their semantic convention (e.g. associating +-- True = Positive and False = Negative) is irrelevant. +-- Rather, they are collected into sets +-- to determine whether both True and False exist for a key. +extractConstFromSigned :: Signed a -> (a, Bool) +extractConstFromSigned v = case v of + Negative x -> (x, False) + Positive x -> (x, True) + +hasContradiction :: Ord a => Conj (Signed a) -> Bool +hasContradiction (Conj items) = + not + . M.null + . M.filter ((> 1) . S.size) + . M.fromListWith (<>) + $ fmap (fmap S.singleton . extractConstFromSigned) items + +simplifyDNF :: Ord a => DNF a -> DNF a +simplifyDNF (DNF (Disj disjunctions)) = + DNF $ Disj $ L.filter (not . hasContradiction) disjunctions + +isAlwaysFalse :: Ord a => DNF a -> Bool +isAlwaysFalse (DNF (Disj disjunctions)) = L.null disjunctions + +cannotBeTrue :: Ord a => BoolExpr a -> Bool +cannotBeTrue = isAlwaysFalse . simplifyDNF . boolTreeToDNF + +replace :: Ord a => Map a Bool -> BoolExpr a -> BoolExpr a +replace f (BAnd a b) = BAnd (replace f a) (replace f b) +replace f (BOr a b) = BOr (replace f a) (replace f b) +replace f (BNot t) = BNot (replace f t) +replace _ BTrue = BTrue +replace _ BFalse = BFalse +replace m c@(BConst x) = case M.lookup varname m of + Nothing -> c + Just val -> + if txform val + then BTrue + else BFalse + where + (varname, isPositive) = extractConstFromSigned x + txform = if isPositive then id else not diff --git a/src/swarm-util/Swarm/Language/Syntax/Direction.hs b/src/swarm-util/Swarm/Language/Syntax/Direction.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Language/Syntax/Direction.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types and helper functions for working with directions +module Swarm.Language.Syntax.Direction ( + -- * Directions + Direction (..), + AbsoluteDir (..), + RelativeDir (..), + PlanarRelativeDir (..), + directionSyntax, + isCardinal, + allDirs, + directionJsonModifier, + getCoordinateOrientation, +) where + +import Data.Aeson.Types hiding (Key) +import Data.Char qualified as C (toLower) +import Data.Data (Data) +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 qualified as T +import GHC.Generics (Generic) +import Swarm.Util.JSON (optionsMinimize) + +------------------------------------------------------------ +-- Directions +------------------------------------------------------------ + +-- | An absolute direction is one which is defined with respect to an +-- external frame of reference; robots need a compass in order to +-- use them. +-- +-- NOTE: These values are ordered by increasing angle according to +-- the standard mathematical convention. +-- That is, the right-pointing direction, East, is considered +-- the "reference angle" and the order proceeds counter-clockwise. +-- See https://en.wikipedia.org/wiki/Polar_coordinate_system#Conventions +-- +-- Do not alter this ordering, as there exist functions that depend on it +-- (e.g. 'Swarm.Game.Location.nearestDirection' and 'Swarm.Game.Location.relativeTo'). +data AbsoluteDir = DEast | DNorth | DWest | DSouth + deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, Enum, Bounded) + +directionJsonModifier :: String -> String +directionJsonModifier = map C.toLower . L.drop 1 + +data CoordinateOrientation + = Latitudinal + | Longitudinal + deriving (Show, Eq, Ord) + +getCoordinateOrientation :: AbsoluteDir -> CoordinateOrientation +getCoordinateOrientation = \case + DEast -> Longitudinal + DWest -> Longitudinal + DNorth -> Latitudinal + DSouth -> Latitudinal + +directionJsonOptions :: Options +directionJsonOptions = + defaultOptions + { constructorTagModifier = directionJsonModifier + } + +instance FromJSON AbsoluteDir where + parseJSON = genericParseJSON directionJsonOptions + +instance ToJSON AbsoluteDir where + toJSON = genericToJSON directionJsonOptions + +cardinalDirectionKeyOptions :: JSONKeyOptions +cardinalDirectionKeyOptions = + defaultJSONKeyOptions + { keyModifier = directionJsonModifier + } + +instance ToJSONKey AbsoluteDir where + toJSONKey = genericToJSONKey cardinalDirectionKeyOptions + +instance FromJSONKey AbsoluteDir where + fromJSONKey = genericFromJSONKey cardinalDirectionKeyOptions + +-- | A relative direction is one which is defined with respect to the +-- robot's frame of reference; no special capability is needed to +-- use them. +data RelativeDir = DPlanar PlanarRelativeDir | DDown + deriving (Eq, Ord, Show, Read, Generic, Data, Hashable) + +instance ToJSON RelativeDir where + toJSON = genericToJSON optionsMinimize + +instance FromJSON RelativeDir where + parseJSON = genericParseJSON optionsMinimize + +-- | Caution: Do not alter this ordering, as there exist functions that depend on it +-- (e.g. 'Swarm.Game.Location.nearestDirection' and 'Swarm.Game.Location.relativeTo'). +data PlanarRelativeDir = DForward | DLeft | DBack | DRight + deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, Enum, Bounded) + +instance FromJSON PlanarRelativeDir where + parseJSON = genericParseJSON directionJsonOptions + +instance ToJSON PlanarRelativeDir where + toJSON = genericToJSON directionJsonOptions + +-- | The type of directions. Used /e.g./ to indicate which way a robot +-- will turn. +data Direction = DAbsolute AbsoluteDir | DRelative RelativeDir + deriving (Eq, Ord, Show, Read, Generic, Data, Hashable) + +instance FromJSON Direction where + parseJSON = genericParseJSON optionsMinimize + +instance ToJSON Direction where + toJSON = genericToJSON optionsMinimize + +-- | Direction name is generated from the deepest nested data constructor +-- e.g. 'DLeft' becomes "left" +directionSyntax :: Direction -> Text +directionSyntax d = T.pack $ directionJsonModifier $ case d of + DAbsolute x -> show x + DRelative x -> case x of + DPlanar y -> show y + _ -> show x + +-- | Check if the direction is absolute (e.g. 'Swarm.Game.Location.north' or 'Swarm.Game.Location.south'). +isCardinal :: Direction -> Bool +isCardinal = \case + DAbsolute _ -> True + _ -> False + +allDirs :: [Direction] +allDirs = map DAbsolute enumerate <> map DRelative (DDown : map DPlanar enumerate) diff --git a/src/swarm-util/Swarm/Util.hs b/src/swarm-util/Swarm/Util.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util.hs @@ -0,0 +1,602 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A random collection of small, useful functions that are (or could +-- be) used throughout the code base. +module Swarm.Util ( + -- * Miscellaneous utilities + (?), + sortPair, + maxOn, + maximum0, + enumeratedMap, + cycleEnum, + enumerateNonEmpty, + showEnum, + indexWrapNonEmpty, + uniq, + binTuples, + histogram, + findDup, + both, + allEqual, + surfaceEmpty, + tails1, + prependList, + deleteKeys, + applyWhen, + hoistMaybe, + unsnocNE, + + -- * Directory utilities + readFileMay, + readFileMayT, + findAllWithExt, + acquireAllWithExt, + + -- * Text utilities + isIdentChar, + replaceLast, + failT, + showT, + showLowT, + + -- * English language utilities + reflow, + quote, + squote, + bquote, + parens, + brackets, + commaList, + indefinite, + indefiniteQ, + singularSubjectVerb, + plural, + number, + + -- * Validation utilities + holdsOr, + isJustOr, + isRightOr, + isSuccessOr, + + -- * Template Haskell utilities + liftText, + + -- * Lens utilities + (%%=), + (<%=), + (<+=), + (<<.=), + (<>=), + _NonEmpty, + + -- * Set utilities + removeSupersets, + 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.Trans.Maybe (MaybeT (..)) +import Data.Bifunctor (Bifunctor (bimap), first) +import Data.Char (isAlphaNum, toLower) +import Data.Either.Validation +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 qualified as List +import Data.List.Extra (enumerate) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text, toUpper) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Tuple (swap) +import Data.Yaml +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift) +import NLP.Minimorph.English qualified as MM +import NLP.Minimorph.Util ((<+>)) +import System.Clock (TimeSpec) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (takeExtension, ()) +import System.IO.Error (catchIOError) +import Witch (from) + +infixr 1 ? +infix 4 %%=, <+=, <%=, <<.=, <>= + +-- | A convenient infix flipped version of 'fromMaybe': @Just a ? b = +-- a@, and @Nothing ? b = b@. It can also be chained, as in @x ? y ? +-- z ? def@, which takes the value inside the first @Just@, +-- defaulting to @def@ as a last resort. +(?) :: Maybe a -> a -> a +(?) = flip fromMaybe + +-- | Ensure the smaller value in a pair is the first element. +sortPair :: Ord b => (b, b) -> (b, b) +sortPair (x, y) = if x <= y then (x, y) else (y, x) + +-- | Find the maximum of two values, comparing them according to a +-- custom projection function. +maxOn :: Ord b => (a -> b) -> a -> a -> a +maxOn f x y + | f x > f y = x + | otherwise = y + +-- | Find the maximum of a list of numbers, defaulting to 0 if the +-- list is empty. +maximum0 :: (Num a, Ord a) => [a] -> a +maximum0 [] = 0 +maximum0 xs = maximum xs + +enumeratedMap :: Int -> [a] -> IntMap a +enumeratedMap startIdx = IM.fromList . zip [startIdx ..] + +-- | Take the successor of an 'Enum' type, wrapping around when it +-- reaches the end. +cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e +cycleEnum e + | e == maxBound = minBound + | otherwise = succ e + +-- | See +-- https://hackage.haskell.org/package/relude-1.2.1.0/docs/Relude-Enum.html#v:universeNonEmpty +enumerateNonEmpty :: (Enum e, Bounded e) => NonEmpty e +enumerateNonEmpty = minBound :| drop 1 enumerate + +-- | We know by the syntax rules of Haskell that constructor +-- names must consist of one or more symbols! +showEnum :: (Show e, Enum e) => e -> NonEmpty Char +showEnum = NE.fromList . show + +-- | Guaranteed to yield an element of the list. +-- +-- This is true even if the supplied @index@ is negative, +-- since 'mod' always satisfies @0 <= a `mod` b < b@ +-- when @b@ is positive +-- (see ). +indexWrapNonEmpty :: + Integral b => + NonEmpty a -> + -- | index + b -> + a +indexWrapNonEmpty list idx = + NE.toList list !! fromIntegral wrappedIdx + where + wrappedIdx = idx `mod` fromIntegral (NE.length list) + +-- | Drop repeated elements that are adjacent to each other. +-- +-- >>> uniq [] +-- [] +-- >>> uniq [1..5] +-- [1,2,3,4,5] +-- >>> uniq (replicate 10 'a') +-- "a" +-- >>> uniq "abbbccd" +-- "abcd" +uniq :: Eq a => [a] -> [a] +uniq = \case + [] -> [] + (x : xs) -> x : uniq (dropWhile (== x) xs) + +-- | Place the second element of the tuples into bins by +-- the value of the first element. +binTuples :: + (Foldable t, Ord a) => + t (a, b) -> + Map a (NE.NonEmpty b) +binTuples = foldr f mempty + where + f = uncurry (M.insertWith (<>)) . fmap pure + +-- | Count occurrences of a value +histogram :: + (Foldable t, Ord a) => + t a -> + Map a Int +histogram = foldl' (\m k -> M.insertWith (+) k 1 m) M.empty + +-- | Find a duplicate element within the list, if any exists. +findDup :: Ord a => [a] -> Maybe a +findDup = go S.empty + where + go _ [] = Nothing + go seen (a : as) + | a `S.member` seen = Just a + | otherwise = go (S.insert a seen) as + +both :: Bifunctor p => (a -> d) -> p a a -> p d d +both f = bimap f f + +allEqual :: (Ord a) => [a] -> Bool +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 + +------------------------------------------------------------ +-- Backported functions + +-- | The 'tails1' function takes a 'NonEmpty' stream @xs@ and returns all the +-- non-empty suffixes of @xs@, starting with the longest. +-- +-- > tails1 (1 :| [2,3]) == (1 :| [2,3]) :| [2 :| [3], 3 :| []] +-- > tails1 (1 :| []) == (1 :| []) :| [] +-- +-- @since 4.18 +tails1 :: NonEmpty a -> NonEmpty (NonEmpty a) +tails1 = + -- fromList is an unsafe function, but this usage should be safe, since: + -- \* `tails xs = [xs, tail xs, tail (tail xs), ..., []]` + -- \* If `xs` is nonempty, it follows that `tails xs` contains at least one nonempty + -- list, since `head (tails xs) = xs`. + -- \* The only empty element of `tails xs` is the last one (by the definition of `tails`) + -- \* Therefore, if we take all but the last element of `tails xs` i.e. + -- `init (tails xs)`, we have a nonempty list of nonempty lists + NE.fromList . Prelude.map NE.fromList . List.init . List.tails . Foldable.toList + +-- | Attach a list at the beginning of a 'NonEmpty'. +-- @since 4.16 +prependList :: [a] -> NonEmpty a -> NonEmpty a +prependList ls ne = case ls of + [] -> ne + (x : xs) -> x :| xs <> NE.toList ne + +-- Note, once we upgrade to an LTS version that includes +-- base-compat-0.13, we should switch to using 'applyWhen' from there. +applyWhen :: Bool -> (a -> a) -> a -> a +applyWhen True f x = f x +applyWhen False _ x = x + +-- | Convert a 'Maybe' computation to 'MaybeT'. +-- +-- TODO (#1151): Use implementation from "transformers" package v0.6.0.0 +hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b +hoistMaybe = MaybeT . pure + +-- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' +-- +-- Taken from Cabal-syntax Distribution.Utils.Generic. +-- +-- Example: +-- >>> import Data.List.NonEmpty (NonEmpty ((:|))) +-- >>> unsnocNE (1 :| [2, 3]) +-- ([1,2],3) +-- +-- >>> unsnocNE (1 :| []) +-- ([],1) +unsnocNE :: NonEmpty a -> ([a], a) +unsnocNE (x :| xs) = go x xs + where + go y [] = ([], y) + go y (z : zs) = let ~(ws, w) = go z zs in (y : ws, w) + +------------------------------------------------------------ +-- Directory stuff + +-- | Safely attempt to read a file. +readFileMay :: FilePath -> IO (Maybe String) +readFileMay = catchIO . readFile + +-- | Safely attempt to (efficiently) read a file. +readFileMayT :: FilePath -> IO (Maybe Text) +readFileMayT = catchIO . T.readFile + +-- | Recursively acquire all files in the given directory with the +-- given extension, but does not read or open the file like 'acquireAllWithExt'. +findAllWithExt :: FilePath -> String -> IO [FilePath] +findAllWithExt dir ext = do + paths <- listDirectory dir <&> map (dir ) + filePaths <- filterM (\path -> doesFileExist path <&> (&&) (hasExt path)) paths + -- recurse + sub <- filterM doesDirectoryExist paths + transChildren <- concat <$> mapM (`findAllWithExt` ext) sub + return $ filePaths <> transChildren + where + hasExt path = takeExtension path == ("." ++ ext) + +-- | Recursively acquire all files in the given directory with the +-- given extension, and their contents. +acquireAllWithExt :: FilePath -> String -> IO [(FilePath, String)] +acquireAllWithExt dir ext = findAllWithExt dir ext >>= mapM addContent + where + addContent :: FilePath -> IO (FilePath, String) + addContent path = (,) path <$> readFile path + +-- | Turns any IO error into Nothing. +catchIO :: IO a -> IO (Maybe a) +catchIO act = (Just <$> act) `catchIOError` (\_ -> return Nothing) + +------------------------------------------------------------ +-- Some Text-y stuff + +-- | Predicate to test for characters which can be part of a valid +-- identifier: alphanumeric, underscore, or single quote. +-- +-- >>> isIdentChar 'A' && isIdentChar 'b' && isIdentChar '9' +-- True +-- >>> isIdentChar '_' && isIdentChar '\'' +-- True +-- >>> isIdentChar '$' || isIdentChar '.' || isIdentChar ' ' +-- False +isIdentChar :: Char -> Bool +isIdentChar c = isAlphaNum c || c == '_' || c == '\'' + +-- | @replaceLast r t@ replaces the last word of @t@ with @r@. +-- +-- >>> :set -XOverloadedStrings +-- >>> replaceLast "foo" "bar baz quux" +-- "bar baz foo" +-- >>> replaceLast "move" "(make" +-- "(move" +replaceLast :: Text -> Text -> Text +replaceLast r t = T.append (T.dropWhileEnd isIdentChar t) r + +-- | Fail with a Text-based message, made out of phrases to be joined +-- by spaces. +failT :: MonadFail m => [Text] -> m a +failT = fail . from @Text . T.unwords + +-- | Show a value, but as Text. +showT :: Show a => a -> Text +showT = from @String . show + +-- | Show a value in all lowercase, but as Text. +showLowT :: Show a => a -> Text +showLowT = from @String . map toLower . show + +------------------------------------------------------------ +-- Some language-y stuff + +-- | Reflow text by removing newlines and condensing whitespace. +reflow :: Text -> Text +reflow = T.unwords . T.words + +-- | Prepend a noun with the proper indefinite article (\"a\" or \"an\"). +indefinite :: Text -> Text +indefinite w = MM.indefiniteDet w <+> w + +-- | Prepend a noun with the proper indefinite article, and surround +-- the noun in single quotes. +indefiniteQ :: Text -> Text +indefiniteQ w = MM.indefiniteDet w <+> squote w + +-- | Combine the subject word with the simple present tense of the verb. +-- +-- Only some irregular verbs are handled, but it should be enough +-- to scrap some error message boilerplate and have fun! +-- +-- >>> :set -XOverloadedStrings +-- >>> singularSubjectVerb "I" "be" +-- "I am" +-- >>> singularSubjectVerb "he" "can" +-- "he can" +-- >>> singularSubjectVerb "The target robot" "do" +-- "The target robot does" +singularSubjectVerb :: Text -> Text -> Text +singularSubjectVerb sub verb + | verb == "be" = case toUpper sub of + "I" -> "I am" + "YOU" -> sub <+> "are" + _ -> sub <+> "is" + | otherwise = sub <+> (if is3rdPerson then verb3rd else verb) + where + is3rdPerson = toUpper sub `notElem` ["I", "YOU"] + verb3rd + | verb == "have" = "has" + | verb == "can" = "can" + | otherwise = fst $ MM.defaultVerbStuff verb + +-- | Pluralize a noun. +plural :: Text -> Text +plural = MM.defaultNounPlural + +-- For now, it is just MM.defaultNounPlural, which only uses heuristics; +-- in the future, if we discover specific nouns that it gets wrong, +-- we can add a lookup table. + +-- | Either pluralize a noun or not, depending on the value of the +-- number. +number :: Int -> Text -> Text +number 1 = id +number _ = plural + +-- | Surround some text in single quotes. +squote :: Text -> Text +squote t = T.concat ["'", t, "'"] + +-- | Surround some text in double quotes. +quote :: Text -> Text +quote t = T.concat ["\"", t, "\""] + +-- | Surround some text in backticks. +bquote :: Text -> Text +bquote t = T.concat ["`", t, "`"] + +-- | Surround some text in parentheses. +parens :: Text -> Text +parens t = T.concat ["(", t, ")"] + +-- | Surround some text in square brackets. +brackets :: Text -> Text +brackets t = T.concat ["[", t, "]"] + +-- | Make a list of things with commas and the word "and". +commaList :: [Text] -> Text +commaList [] = "" +commaList [t] = t +commaList [s, t] = T.unwords [s, "and", t] +commaList ts = T.unwords $ map (`T.append` ",") (init ts) ++ ["and", last ts] + +------------------------------------------------------------ +-- Some orphan instances + +deriving instance FromJSON TimeSpec +deriving instance ToJSON TimeSpec + +------------------------------------------------------------ +-- Validation utilities + +-- | Require that a Boolean value is @True@, or throw an exception. +holdsOr :: Has (Throw e) sig m => Bool -> e -> m () +holdsOr b e = unless b $ throwError e + +-- | Require that a 'Maybe' value is 'Just', or throw an exception. +isJustOr :: Has (Throw e) sig m => Maybe a -> e -> m a +Just a `isJustOr` _ = return a +Nothing `isJustOr` e = throwError e + +-- | Require that an 'Either' value is 'Right', or throw an exception +-- based on the value in the 'Left'. +isRightOr :: Has (Throw e) sig m => Either b a -> (b -> e) -> m a +Right a `isRightOr` _ = return a +Left b `isRightOr` f = throwError (f b) + +-- | Require that a 'Validation' value is 'Success', or throw an exception +-- based on the value in the 'Failure'. +isSuccessOr :: Has (Throw e) sig m => Validation b a -> (b -> e) -> m a +Success a `isSuccessOr` _ = return a +Failure b `isSuccessOr` f = throwError (f b) + +------------------------------------------------------------ +-- Template Haskell utilities + +-- See https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable +liftText :: T.Text -> Q Exp +liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt) + +------------------------------------------------------------ +-- Fused-Effects Lens utilities + +(<+=) :: (Has (State s) sig m, Num a) => LensLike' ((,) a) s a -> a -> m a +l <+= a = l <%= (+ a) +{-# INLINE (<+=) #-} + +(<%=) :: (Has (State s) sig m) => LensLike' ((,) a) s a -> (a -> a) -> m a +l <%= f = l %%= (\b -> (b, b)) . f +{-# INLINE (<%=) #-} + +(%%=) :: (Has (State s) sig m) => Over p ((,) r) s s a b -> p a (r, b) -> m r +l %%= f = state (swap . l f) +{-# INLINE (%%=) #-} + +(<<.=) :: (Has (State s) sig m) => LensLike ((,) a) s s a b -> b -> m a +l <<.= b = l %%= (,b) +{-# INLINE (<<.=) #-} + +(<>=) :: (Has (State s) sig m, Semigroup a) => ASetter' s a -> a -> m () +l <>= a = modify (l <>~ a) +{-# INLINE (<>=) #-} + +------------------------------------------------------------ +-- Other lens utilities + +_NonEmpty :: Lens' (NonEmpty a) (a, [a]) +_NonEmpty = lens (\(x :| xs) -> (x, xs)) (const (uncurry (:|))) + +------------------------------------------------------------ +-- Some set utilities + +-- | 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. +-- +-- >>> import qualified Data.Set as S +-- >>> rss = map S.toList . S.toList . removeSupersets . S.fromList . map S.fromList +-- +-- >>> rss [[1,2,3], [1]] +-- [[1]] +-- +-- >>> rss [[1,2,3], [2,4], [2,3]] +-- [[2,3],[2,4]] +-- +-- >>> rss [[], [1], [2,3]] +-- [[]] +-- +-- >>> rss [[1,2], [1,3], [2,3]] +-- [[1,2],[1,3],[2,3]] +removeSupersets :: Ord a => Set (Set a) -> Set (Set a) +removeSupersets ss = S.filter (not . isSuperset) ss + where + isSuperset s = any (`S.isSubsetOf` s) (S.delete s ss) + +-- | Given a list of /nonempty/ sets, find a hitting set, that is, a +-- set which has at least one element in common with each set in the +-- list. It is not guaranteed to be the /smallest possible/ such +-- set, because that is NP-hard. Instead, we use a greedy algorithm +-- that will give us a reasonably small hitting set: first, choose +-- all elements in singleton sets, since those must necessarily be +-- chosen. Now take any sets which are still not hit, and find an +-- element which occurs in the largest possible number of remaining +-- sets. Add this element to the set of chosen elements, and filter +-- out all the sets it hits. Repeat, choosing a new element to hit +-- the largest number of unhit sets at each step, until all sets are +-- hit. This algorithm produces a hitting set which might be larger +-- than optimal by a factor of lg(m), where m is the number of sets +-- in the input. +-- +-- >>> import qualified Data.Set as S +-- >>> shs = smallHittingSet . map S.fromList +-- +-- >>> shs ["a"] +-- fromList "a" +-- +-- >>> shs ["ab", "b"] +-- fromList "b" +-- +-- >>> shs ["ab", "bc"] +-- fromList "b" +-- +-- >>> shs ["acd", "c", "aef", "a"] +-- fromList "ac" +-- +-- >>> shs ["abc", "abd", "acd", "bcd"] +-- fromList "cd" +-- +-- Here is an example of an input for which @smallHittingSet@ does +-- /not/ produce a minimal hitting set. "bc" is also a hitting set and +-- is smaller. b, c, and d all occur in exactly two sets, but d is +-- unluckily chosen first, leaving "be" and "ac" unhit and +-- necessitating choosing one more element from each. +-- +-- >>> shs ["bd", "be", "ac", "cd"] +-- fromList "cde" +smallHittingSet :: Ord a => [Set a] -> Set a +smallHittingSet ss = go fixed (filter (S.null . S.intersection fixed) choices) + where + (fixed, choices) = first S.unions . partition ((== 1) . S.size) . filter (not . S.null) $ ss + + go !soFar [] = soFar + go !soFar cs = go (S.insert best soFar) (filter (not . (best `S.member`)) cs) + where + best = mostCommon cs + + -- Given a nonempty collection of sets, find an element which is shared among + -- as many of them as possible. + mostCommon :: Ord a => [Set a] -> a + mostCommon = fst . maximumBy (comparing snd) . M.assocs . histogram . concatMap S.toList diff --git a/src/swarm-util/Swarm/Util/Effect.hs b/src/swarm-util/Swarm/Util/Effect.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/Effect.hs @@ -0,0 +1,76 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- fused-effect utilities for Swarm. +module Swarm.Util.Effect where + +import Control.Algebra +import Control.Carrier.Accum.FixedStrict +import Control.Carrier.Error.Either (ErrorC (..)) +import Control.Carrier.Throw.Either (ThrowC (..), runThrow) +import Control.Effect.Throw +import Control.Monad ((>=>)) +import Control.Monad.Trans.Except (ExceptT) +import Data.Either.Extra (eitherToMaybe) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Witherable + +-- | Transform a @Throw e1@ constraint into a @Throw e2@ constraint, +-- by supplying an adapter function of type @(e1 -> e2)@. +withThrow :: (Has (Throw e2) sig m) => (e1 -> e2) -> ThrowC e1 m a -> m a +withThrow f = runThrow >=> either (throwError . f) return + +-- | Transform a @Throw e@ constrint into a concrete @Maybe@, +-- discarding the error. +throwToMaybe :: forall e m a. Functor m => ThrowC e m a -> m (Maybe a) +throwToMaybe = fmap eitherToMaybe . runThrow + +-- | Transform a @Throw e@ constrint into a concrete @Maybe@, +-- logging any error as a warning. +throwToWarning :: (Has (Accum (Seq e)) sig m) => ThrowC e m a -> m (Maybe a) +throwToWarning m = do + res <- runThrow m + case res of + Left err -> warn err >> return Nothing + Right a -> return (Just a) + +-- | Run a computation with an @Accum@ effect (typically accumulating +-- a list of warnings), ignoring the accumulated value. +ignoreWarnings :: forall e m a. (Monoid e, Functor m) => AccumC e m a -> m a +ignoreWarnings = evalAccum mempty + +-- | Convert a fused-effects style computation using a @Throw e@ +-- constraint into an @ExceptT@ computation. This is mostly a stub +-- to convert from one style to the other while we are in the middle +-- of incrementally converting. Eventually this should not be needed. +asExceptT :: ThrowC e m a -> ExceptT e m a +asExceptT (ThrowC (ErrorC m)) = m + +-- | Log a single failure as a warning. +warn :: Has (Accum (Seq w)) sig m => w -> m () +warn = add . Seq.singleton + +-- | A version of 'traverse'/'mapM' that also accumulates warnings. +-- +-- Note that we can't generalize this to work over any 'Traversable' +-- because it also needs to have a notion of "filtering". +-- 'Witherable' provides exactly the right abstraction. +traverseW :: + (Has (Accum (Seq w)) sig m, Witherable t) => + (a -> m (Either w b)) -> + t a -> + m (t b) +traverseW f = do + wither $ + f >=> \case + Left e -> warn e >> return Nothing + Right e -> return $ Just e + +-- | Flipped version of 'traverseW' for convenience. +forMW :: + (Has (Accum (Seq w)) sig m, Witherable t) => + t a -> + (a -> m (Either w b)) -> + m (t b) +forMW = flip traverseW diff --git a/src/swarm-util/Swarm/Util/Erasable.hs b/src/swarm-util/Swarm/Util/Erasable.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/Erasable.hs @@ -0,0 +1,46 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Custom extension of 'Semigroup' to 'Monoid' that adds identity + +-- annihilator elements. +module Swarm.Util.Erasable where + +-- | Extend a semigroup to a monoid by adding an identity ('ENothing') /and/ an +-- annihilator ('EErase'). That is, +-- +-- * @ENothing <> e = e <> ENothing = e@ +-- * @EErase <> e = e <> EErase = EErase@ +-- +-- This allows us to "erase" previous values by combining with +-- 'EErase'. The 'erasableToMaybe' function turns an 'Erasable' +-- into a 'Maybe' by collapsing 'ENothing' and 'EErase' both back +-- into 'Nothing'. +data Erasable e = ENothing | EErase | EJust e + deriving (Show, Eq, Ord, Functor) + +instance Semigroup e => Semigroup (Erasable e) where + ENothing <> e = e + e <> ENothing = e + EErase <> _ = EErase + _ <> EErase = EErase + EJust e1 <> EJust e2 = EJust (e1 <> e2) + +instance Semigroup e => Monoid (Erasable e) where + mempty = ENothing + +-- | Generic eliminator for 'Erasable' values. +erasable :: a -> a -> (e -> a) -> Erasable e -> a +erasable x y z = \case + ENothing -> x + EErase -> y + EJust e -> z e + +-- | Convert an 'Erasable' value to 'Maybe', turning both 'ENothing' +-- and 'EErase' into 'Nothing'. +erasableToMaybe :: Erasable e -> Maybe e +erasableToMaybe = erasable Nothing Nothing Just + +-- | Inject a 'Maybe' value into 'Erasable' using 'ENothing' and +-- 'EJust'. +maybeToErasable :: Maybe e -> Erasable e +maybeToErasable = maybe ENothing EJust diff --git a/src/swarm-util/Swarm/Util/JSON.hs b/src/swarm-util/Swarm/Util/JSON.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/JSON.hs @@ -0,0 +1,25 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utilities for JSON de/serialization. +module Swarm.Util.JSON where + +import Data.Aeson + +-- | @aeson@ options specifying to unwrap unary records so they are +-- encoded as a simple value instead of as a JSON object. +optionsUnwrapUnary :: Options +optionsUnwrapUnary = defaultOptions {unwrapUnaryRecords = True} + +-- | @aeson@ options to try to minimize the size of the generated +-- JSON. +optionsMinimize :: Options +optionsMinimize = + defaultOptions + { sumEncoding = ObjectWithSingleField + , omitNothingFields = True + , allowOmittedFields = True + } + +optionsUntagged :: Options +optionsUntagged = defaultOptions {sumEncoding = UntaggedValue} diff --git a/src/swarm-util/Swarm/Util/Lens.hs b/src/swarm-util/Swarm/Util/Lens.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/Lens.hs @@ -0,0 +1,58 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Lens generation utilities. +module Swarm.Util.Lens ( + makeLensesNoSigs, + makeLensesExcluding, + inherit, + concatFold, +) where + +import Control.Lens ( + Fold, + Lens', + folding, + generateSignatures, + lensField, + lensRules, + makeLensesWith, + mapped, + (%~), + (&), + (.~), + (^.), + (^..), + ) +import Language.Haskell.TH (DecsQ) +import Language.Haskell.TH.Syntax (Name) + +-- | Generate lenses but with no type signatures, so we can explicitly +-- give type signatures and attach custom Haddock documentation to +-- them. +makeLensesNoSigs :: Name -> DecsQ +makeLensesNoSigs = makeLensesWith (lensRules & generateSignatures .~ False) + +-- | Generate lenses for the fields of a record type (with no type +-- signatures), except for a given list of excluded fields. +-- +-- Especially useful in conjunction with the design pattern +-- described in +-- https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ +makeLensesExcluding :: [Name] -> Name -> DecsQ +makeLensesExcluding exclude = + makeLensesWith + ( lensRules + & generateSignatures .~ False + & lensField . mapped . mapped %~ \fn n -> + if n `elem` exclude then [] else fn n + ) + +-- | Copy a given field from one record to another. +inherit :: Lens' s a -> s -> (s -> s) +inherit field parent child = child & field .~ (parent ^. field) + +-- | Concatenate two folds into a single fold which encompasses all +-- elements from both. +concatFold :: Fold s a -> Fold s a -> Fold s a +concatFold f1 f2 = folding (\s -> (s ^.. f1) ++ (s ^.. f2)) diff --git a/src/swarm-util/Swarm/Util/OccurrenceEncoder.hs b/src/swarm-util/Swarm/Util/OccurrenceEncoder.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/OccurrenceEncoder.hs @@ -0,0 +1,58 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Compress representation of traversable +-- +-- Useful for compressing the representation of a +-- structure that has many repeating elements +-- for transmission (e.g. over the network). +module Swarm.Util.OccurrenceEncoder ( + runEncoder, +) where + +import Control.Monad.Trans.State +import Data.List (sortOn) +import Data.Map (Map) +import Data.Map qualified as M + +type OccurrenceEncoder a = State (Encoder a) + +newtype Encoder a = Encoder (Map a Int) + +-- | +-- Given a data structure that may have many repeating "complex" elements, +-- will store the "complex" element representation +-- in an array so that the structure's elements can be replaced +-- with simple indices into that array. +-- +-- The first encountered element is assigned index 0, and the next +-- novel element encountered gets index 1, and so on. +runEncoder :: + (Traversable t, Ord b) => + t b -> + (t Int, [b]) +runEncoder structure = + getIndices <$> runState (mapM encodeOccurrence structure) emptyEncoder + +emptyEncoder :: Ord a => Encoder a +emptyEncoder = Encoder mempty + +-- | Map indices are guaranteed to be contiguous +-- from @[0..N]@, so we may convert to a list +-- with no loss of information. +getIndices :: Encoder a -> [a] +getIndices (Encoder m) = map fst $ sortOn snd $ M.toList m + +-- | Translate each the first occurrence in the structure +-- to a new integer as it is encountered. +-- Subsequent encounters re-use the allocated integer. +encodeOccurrence :: Ord a => a -> OccurrenceEncoder a Int +encodeOccurrence c = do + Encoder currentMap <- get + maybe (cacheNewIndex currentMap) return $ + M.lookup c currentMap + where + cacheNewIndex currentMap = do + put $ Encoder $ M.insert c newIdx currentMap + return newIdx + where + newIdx = M.size currentMap diff --git a/src/swarm-util/Swarm/Util/ReadableIORef.hs b/src/swarm-util/Swarm/Util/ReadableIORef.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/ReadableIORef.hs @@ -0,0 +1,17 @@ +-- | +-- 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/RingBuffer.hs b/src/swarm-util/Swarm/Util/RingBuffer.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/RingBuffer.hs @@ -0,0 +1,47 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A rolling window of items for the purpose of maintaining +-- a bounded-size debugging log of recent events. +module Swarm.Util.RingBuffer ( + RingBuffer, + BufferSize (..), + getValues, + insert, + mkRingBuffer, +) where + +import Data.Aeson +import Data.Sequence as S +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD + +-- | Isomorphic to the 'Maybe' type +data BufferSize = Infinite | Finite Int + +mkRingBuffer :: BufferSize -> RingBuffer a +mkRingBuffer = RingBuffer mempty + +data RingBuffer a = RingBuffer (Seq a) BufferSize + +instance (ToJSON a) => ToJSON (RingBuffer a) where + toJSON (RingBuffer xs _) = toJSON xs + +instance ToSample (RingBuffer a) where + toSamples _ = SD.noSamples + +getValues :: RingBuffer a -> Seq a +getValues (RingBuffer xs _) = xs + +insert :: a -> RingBuffer a -> RingBuffer a +insert x (RingBuffer xs lim) = RingBuffer inserted lim + where + inserted = popped :|> x + popped = case lim of + Infinite -> xs + Finite maxSize -> case xs of + Empty -> xs + _ :<| back -> + if S.length xs < maxSize + then xs + else back diff --git a/src/swarm-util/Swarm/Util/UnitInterval.hs b/src/swarm-util/Swarm/Util/UnitInterval.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/UnitInterval.hs @@ -0,0 +1,38 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Creation and utilities for the unit interval +module Swarm.Util.UnitInterval ( + UnitInterval, + getValue, + mkInterval, + safeIndex, +) where + +import Data.List.NonEmpty (NonEmpty, (!!)) +import Prelude hiding ((!!)) + +newtype UnitInterval a = UnitInterval + { getValue :: a + } + +-- | Guarantees that the stored value falls within the closed interval +-- @[0, 1]@. It is up to clients to ensure that the promotion +-- to this type is lossless. +mkInterval :: (Ord a, Num a) => a -> UnitInterval a +mkInterval = UnitInterval . max 0 . min 1 + +-- | Since '(!!)' is partial, here is "proof" that it is safe: +-- If "alpha" is its maximum value of @1@, then the maximum value +-- of the computed index shall be one less than the length of the +-- list (i.e., a valid index). +-- +-- See also: 'Swarm.Util.indexWrapNonEmpty'. +safeIndex :: + RealFrac a => + -- | alpha + UnitInterval a -> + NonEmpty b -> + b +safeIndex (UnitInterval alpha) xs = + xs !! floor (alpha * fromIntegral (length xs - 1)) diff --git a/src/swarm-util/Swarm/Util/WindowedCounter.hs b/src/swarm-util/Swarm/Util/WindowedCounter.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/WindowedCounter.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sliding window for activity monitoring. +module Swarm.Util.WindowedCounter ( + WindowedCounter, + Offsettable (..), + + -- * Construction + mkWindow, + + -- * Querying + getOccupancy, + + -- * Maintenance + insert, + discardGarbage, +) where + +import Data.Aeson +import Data.Set (Set) +import Data.Set qualified as Set +import Swarm.Util.UnitInterval +import Prelude hiding (length) + +-- | Values that can be offset by an integral amount +class Offsettable a where + offsetBy :: Int -> a -> a + +-- | A "sliding window" of a designated span that supports insertion +-- of tick "timestamps" that represent some state of interest during that tick. +-- This data structure supports efficient querying of the ratio of +-- {ticks for which that state existed} +-- to the +-- {total number of ticks spanned by the window}. +-- +-- The primary use case is in displaying the "activity level" of a robot. +-- +-- == Efficiency considerations +-- +-- The data retention of the window shall be maintained externally by +-- invoking the 'discardGarbage' function. However, we should not +-- unconditionally invoke this function upon each game tick. +-- +-- For efficiency, we do not want to iterate over every robot +-- upon every tick; we only want to "visit" a robot if it is actually +-- doing work that tick. +-- Because of this, there may be some ticks in which the oldest element +-- that is still stored falls outside of the nominal retention window +-- while a robot is inactive. +-- +-- One might think we could perform garbage collection whenever we execute queries. +-- However, in the context in which the view powered by the query is generated, we +-- are not permitted to mutate the "state" of the game +-- (the type signature of the rendering function is @AppState -> Widget Name@). +-- +-- Therefore, when we perform "queries" on the window, we must apply some +-- filtering to exclude the "stragglers"; data members that have already fallen outside +-- the window but have not yet been "garbage collected". +-- We use a 'Set' to allow this filtering to be performed in @O(log n)@ time. +-- +-- In the worst case, the entire dataset may "age out" without being garbage collected, +-- so that an @O(log n)@ filtering operation might be performed upon every "frame refresh" +-- of the UI view. +-- However, we also store the largest element of the window separately from the 'Set' so that +-- we can compare against it for a @O(1)@ short-circuited path once every member ages out. +-- +-- The maximum number of elements ever stored in the 'Set' will be the width of the nominal +-- span, even after some protracted failure to "garbage collect". +data WindowedCounter a = WindowedCounter + { _members :: Set a + , _lastLargest :: Maybe a + -- ^ NOTE: It is possible that '_lastLargest' may not exist in the 'Set'. + , _nominalSpan :: Int + -- ^ Data retention window. This value is guaranteed positive by the smart constructor. + } + deriving (Eq, Show) + +-- | Automatically deriving 'FromJSON' circumvents the protection offered by "smart constructors", +-- and the 'ToJSON' instance may expose internal details. +-- Therefore, we write our own custom implementations. +-- +-- This 'ToJSON' instance is strictly for diagnostic purposes, and we can reveal +-- a bit more information than is used for parsing. +instance (ToJSON a) => ToJSON (WindowedCounter a) where + toJSON (WindowedCounter membersSet _lastLargest nominalSpan) = + object + [ "members" .= toJSON membersSet + , "span" .= nominalSpan + ] + +-- | We discard any "internal state" revealed by the 'ToJSON' instance and +-- just use the "span" so that we can rely on any guarantees offered by the +-- smart constructor, no matter the origin of the JSON. +-- +-- Discarding the internal state is OK, because it is not integral to gameplay; +-- it is merely informational as a live indicator in the UI. +instance FromJSON (WindowedCounter a) where + parseJSON = withObject "WindowedCounter" $ \v -> do + s <- v .: "span" + return $ mkWindow s + +-- | NOTE: We take the absolute value of the "window span" argument +-- so that we can make guarantees about the output of 'getOccupancy'. +mkWindow :: + -- | window span + Int -> + WindowedCounter a +mkWindow = WindowedCounter Set.empty Nothing . abs + +-- | Return the ratio of {members in the window} to the {integral span +-- represented by the window}. +-- +-- The "current time" should be at least as large as the largest +-- element of the window. +-- +-- A fully-contiguous collection of ticks would have an occupancy ratio of @1@. +-- +-- == Unit interval guarantee +-- The returned ratio is /guaranteed/ to lie on the unit interval, because: +-- +-- * Both the numerator and denominator of the ratio are guaranteed positive, and +-- * 'discardGarbage' guarantees that the set size is less than or equal to +-- the nominal span. +getOccupancy :: + (Ord a, Offsettable a) => + -- | current time + a -> + WindowedCounter a -> + UnitInterval Double +getOccupancy currentTime wc@(WindowedCounter s lastLargest nominalSpan) = + mkInterval $ + if Set.null s || maybe False (< referenceTick) lastLargest + then 0 + else fromIntegral (Set.size culledSet) / fromIntegral nominalSpan + where + referenceTick = offsetBy (negate nominalSpan) currentTime + -- Cull the window according to the current time + WindowedCounter culledSet _ _ = discardGarbage currentTime wc + +-- | Invocations of this function shall be guarded externally +-- by the conditions meant to be tracked in the window. +-- +-- Proper usage dictates that the value inserted should always +-- be at least as large as the current largest element of the set. +-- +-- The 'discardGarbage' function is called from inside this function +-- so that maintenance of the data structure is simplified. +insert :: + (Ord a, Offsettable a) => + -- | current time + a -> + WindowedCounter a -> + WindowedCounter a +insert x (WindowedCounter s lastLargest nominalSpan) = + discardGarbage x $ WindowedCounter (Set.insert x s) newLargest nominalSpan + where + newLargest = Just $ maybe x (max x) lastLargest + +-- | Drop the leading elements that are not larger than the cutoff. +-- +-- This function is already called by the 'insert' function, so clients +-- do not necessarily ever have to call this directly. +-- However, there may +-- be opportunity to call this even more often, i.e. in code paths where the +-- robot is visited but the condition for insertion is not met. +-- +-- == Invariant +-- If the largest member of the set is the current time, +-- then after calling this function, the difference between smallest and largest +-- value in the set is strictly less than the "nominal span", and the size of the +-- set is less than or equal to the nominal span. +-- +-- For example, if the nominal span is @3@, the current time is @7@, and the +-- set entails a contiguous sequence @{2, 3, 4, 5, 6, 7}@, then the pivot for 'Set.split' will be +-- @7 - 3 = 4@. The set becomes @{5, 6, 7}@, with cardinality equal to the nominal span. +discardGarbage :: + (Ord a, Offsettable a) => + -- | current time + a -> + WindowedCounter a -> + WindowedCounter a +discardGarbage currentTime (WindowedCounter s lastLargest nominalSpan) = + WindowedCounter larger lastLargest nominalSpan + where + -- NOTE: Neither output set of 'split' includes the "pivot" value. + (_smaller, larger) = Set.split (offsetBy (negate nominalSpan) currentTime) s diff --git a/src/swarm-util/Swarm/Util/Yaml.hs b/src/swarm-util/Swarm/Util/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/swarm-util/Swarm/Util/Yaml.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Various utilities related to parsing YAML files. +module Swarm.Util.Yaml ( + With (..), + ParserE, + liftE, + localE, + withE, + getE, + FromJSONE (..), + decodeFileEitherE, + (..:), + (..:?), + (..!=), + withTextE, + withObjectE, + withArrayE, +) where + +import Control.Applicative (Alternative) +import Control.Monad.Reader +import Data.Aeson.Key (fromText) +import Data.Aeson.Types (explicitParseField, explicitParseFieldMaybe) +import Data.Bifunctor (first) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Vector qualified as V +import Data.Yaml as Y +import Swarm.Util (failT, showT) + +------------------------------------------------------------ +-- WithEntities wrapper +------------------------------------------------------------ + +-- | A generic wrapper for computations which also depend on knowing a +-- value of type @e@. +newtype With e f a = E {runE :: e -> f a} + deriving (Functor) + deriving (Applicative, Monad, MonadFail, Alternative) via (ReaderT e f) + +-- | A 'ParserE' is a YAML 'Parser' that can also depend on knowing an +-- value of type @e@. The @E@ used to stand for @EntityMap@, but now +-- that it is generalized, it stands for Environment. +type ParserE e = With e Parser + +-- | Lift a computation that does not care about the environment +-- value. +liftE :: Functor f => f a -> With e f a +liftE = E . const + +-- | Locally modify an environment. +localE :: (e' -> e) -> With e f a -> With e' f a +localE g (E f) = E (f . g) + +-- | Locally merge an environment with the current one for given action. +withE :: Semigroup e => e -> With e f a -> With e f a +withE e = localE (<> e) + +-- | Get the current environment. +getE :: (Monad f) => With e f e +getE = E return + +------------------------------------------------------------ +-- FromJSONE +------------------------------------------------------------ + +-- | 'FromJSONE' governs values that can be parsed from a YAML (or +-- JSON) file, but which also have access to an extra, read-only +-- environment value. +-- +-- For things that don't care about the environment, the default +-- implementation of 'parseJSONE' simply calls 'parseJSON' from a +-- 'FromJSON' instance. +class FromJSONE e a where + parseJSONE :: Value -> ParserE e a + default parseJSONE :: FromJSON a => Value -> ParserE e a + parseJSONE = liftE . parseJSON + + parseJSONE' :: e -> Value -> Parser a + parseJSONE' e = ($ e) . runE . parseJSONE + +instance FromJSONE e Int + +instance FromJSONE e a => FromJSONE e [a] where + parseJSONE = withArrayE "[]" (traverse parseJSONE . V.toList) + +instance (FromJSONE e a, FromJSONE e b) => FromJSONE e (a, b) where + parseJSONE = withArrayE "(a, b)" $ \t -> + let n = V.length t + in if n == 2 + then + (,) + <$> parseJSONE (V.unsafeIndex t 0) + <*> parseJSONE (V.unsafeIndex t 1) + else failT ["cannot unpack array of length", showT n, "into a tuple of length 2"] + +------------------------------------------------------------ +-- Decoding +------------------------------------------------------------ + +-- | Read a value from a YAML file, providing the needed extra +-- environment. +decodeFileEitherE :: FromJSONE e a => e -> FilePath -> IO (Either ParseException a) +decodeFileEitherE e file = do + res <- decodeFileEither file :: IO (Either ParseException Value) + return $ case res of + Left err -> Left err + Right v -> first AesonException $ parseEither (parseJSONE' e) v + +------------------------------------------------------------ +-- Accessors +------------------------------------------------------------ + +-- | A variant of '.:' for 'ParserE': project out a field of an +-- 'Object', passing along the extra environment. +(..:) :: FromJSONE e a => Object -> Text -> ParserE e a +v ..: x = E $ \e -> explicitParseField (parseJSONE' e) v (fromText x) + +-- | A variant of '.:?' for 'ParserE': project out an optional field of an +-- 'Object', passing along the extra environment. +(..:?) :: FromJSONE e a => Object -> Text -> ParserE e (Maybe a) +v ..:? x = E $ \e -> explicitParseFieldMaybe (parseJSONE' e) v (fromText x) + +-- | A variant of '.!=' for any functor. +(..!=) :: Functor f => f (Maybe a) -> a -> f a +p ..!= a = fromMaybe a <$> p + +------------------------------------------------------------ +-- Helpers +------------------------------------------------------------ + +withThingE :: + (forall b. String -> (thing -> Parser b) -> Value -> Parser b) -> + (String -> (thing -> ParserE e a) -> Value -> ParserE e a) +withThingE withThing name f = E . (\v es -> withThing name (($ es) . runE . f) v) + +-- | @'withTextE' name f value@ applies @f@ to the 'Text' when @value@ is +-- a @String@ and fails otherwise. +withTextE :: String -> (Text -> ParserE e a) -> Value -> ParserE e a +withTextE = withThingE withText + +-- | @'withObjectE' name f value@ applies @f@ to the 'Object' when @value@ is +-- an 'Object' and fails otherwise. +withObjectE :: String -> (Object -> ParserE e a) -> Value -> ParserE e a +withObjectE = withThingE withObject + +-- | @'withArrayE' name f value@ applies @f@ to the 'Array' when @value@ is +-- an 'Array' and fails otherwise. +withArrayE :: String -> (Y.Array -> ParserE e a) -> Value -> ParserE e a +withArrayE = withThingE withArray diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs new file mode 100644 --- /dev/null +++ b/src/swarm-web/Swarm/Web.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A web service for Swarm. +-- +-- The service can be started using the `--port 5357` command line argument, +-- or through the REPL by calling `Swarm.App.demoWeb`. +-- +-- See 'SwarmAPI' for the available endpoints. You can also see them in your +-- browser on the top level endpoint: +-- @lynx localhost:5357 -dump@ +-- or you can output the markdown documentation to your terminal: +-- @cabal run swarm -O0 -- generate endpoints@ +-- +-- Missing endpoints: +-- +-- * TODO: #625 run endpoint to load definitions +-- * TODO: #493 export the whole game state +module Swarm.Web ( + startWebThread, + defaultPort, + + -- ** Docs + SwarmAPI, + swarmApiHtml, + swarmApiMarkdown, + + -- ** Development + webMain, +) where + +import Brick.BChan +import Commonmark qualified as Mark (commonmark, renderHtml) +import Control.Arrow (left) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Control.Exception (Exception (displayException), IOException, catch, throwIO) +import Control.Lens +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString.Lazy (ByteString) +import Data.Foldable (toList) +import Data.IntMap qualified as IM +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Map.NonEmpty qualified as NEM +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Tree (Tree (Node), drawTree) +import Network.HTTP.Types (ok200) +import Network.Wai (responseLBS) +import Network.Wai qualified +import Network.Wai.Application.Static (defaultFileServerSettings, ssIndices) +import Network.Wai.Handler.Warp qualified as Warp +import Servant +import Servant.Docs (ToCapture) +import Servant.Docs qualified as SD +import Servant.Docs.Internal qualified as SD (renderCurlBasePath) +import Swarm.Doc.Command +import Swarm.Game.Entity (EntityName, entityName) +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.Topography.Area (AreaDimensions (..)) +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.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Step.Path.Type +import Swarm.Language.Pipeline (processTermEither) +import Swarm.Language.Pretty (prettyTextLine) +import Swarm.TUI.Model 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.Util.RingBuffer +import Swarm.Web.Worldview +import System.Timeout (timeout) +import Text.Read (readEither) +import WaiAppStatic.Types (unsafeToPiece) +import Witch (into) + +-- ------------------------------------------------------------------ +-- Docs +-- ------------------------------------------------------------------ + +newtype RobotID = RobotID Int + +type SwarmAPI = + "robots" :> Get '[JSON] [Robot] + :<|> "robot" :> Capture "id" RobotID :> Get '[JSON] (Maybe Robot) + :<|> "goals" :> "prereqs" :> Get '[JSON] [PrereqSatisfaction] + :<|> "goals" :> "active" :> Get '[JSON] [Objective] + :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo) + :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking + :<|> "goals" :> Get '[JSON] WinCondition + :<|> "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 + :<|> "paths" :> "log" :> Get '[JSON] (RingBuffer CacheLogEntry) + :<|> "commands" :> Get '[JSON] CommandCatalog + :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem] + :<|> "map" :> Capture "size" AreaDimensions :> Get '[JSON] GridResponse + +swarmApi :: Proxy SwarmAPI +swarmApi = Proxy + +type ToplevelAPI = + SwarmAPI + :<|> "api" :> Raw + :<|> Raw + +api :: Proxy ToplevelAPI +api = Proxy + +swarmApiHtml :: ByteString +swarmApiHtml = + encodeUtf8 + . either (error . show) (Mark.renderHtml @()) + . Mark.commonmark "" + $ T.pack swarmApiMarkdown + +swarmApiMarkdown :: String +swarmApiMarkdown = + SD.markdownWith + ( SD.defRenderingOptions + & SD.requestExamples .~ SD.FirstContentType + & SD.responseExamples .~ SD.FirstContentType + & SD.renderCurlBasePath ?~ "http://localhost:" <> show defaultPort + ) + $ SD.docsWithIntros [intro] swarmApi + where + intro = SD.DocIntro "Swarm Web API" ["All of the valid endpoints are documented below."] + +-- ------------------------------------------------------------------ +-- Handlers +-- ------------------------------------------------------------------ + +mkApp :: + ReadableIORef AppState -> + -- | Writable channel to send events to the game + BChan AppEvent -> + Servant.Server SwarmAPI +mkApp state events = + robotsHandler state + :<|> robotHandler state + :<|> prereqsHandler state + :<|> activeGoalsHandler state + :<|> goalsGraphHandler state + :<|> uiGoalHandler state + :<|> goalsHandler state + :<|> recogLogHandler state + :<|> recogFoundHandler state + :<|> codeRenderHandler + :<|> codeRunHandler events + :<|> pathsLogHandler state + :<|> cmdMatrixHandler state + :<|> replHistHandler state + :<|> mapViewHandler state + +robotsHandler :: ReadableIORef AppState -> Handler [Robot] +robotsHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + pure $ IM.elems $ appState ^. gameState . robotInfo . robotMap + +robotHandler :: ReadableIORef AppState -> RobotID -> Handler (Maybe Robot) +robotHandler appStateRef (RobotID rid) = do + appState <- liftIO (readIORef appStateRef) + pure $ IM.lookup rid (appState ^. gameState . robotInfo . robotMap) + +prereqsHandler :: ReadableIORef AppState -> Handler [PrereqSatisfaction] +prereqsHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + case appState ^. gameState . winCondition of + WinConditions _winState oc -> return $ getSatisfaction oc + _ -> return [] + +activeGoalsHandler :: ReadableIORef AppState -> Handler [Objective] +activeGoalsHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + case appState ^. gameState . winCondition of + WinConditions _winState oc -> return $ getActiveObjectives oc + _ -> return [] + +goalsGraphHandler :: ReadableIORef AppState -> Handler (Maybe GraphInfo) +goalsGraphHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + return $ case appState ^. gameState . winCondition of + WinConditions _winState oc -> Just $ makeGraphInfo oc + _ -> Nothing + +uiGoalHandler :: ReadableIORef AppState -> Handler GoalTracking +uiGoalHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + return $ appState ^. uiState . uiGameplay . uiGoal . goalsContent + +goalsHandler :: ReadableIORef AppState -> Handler WinCondition +goalsHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + return $ appState ^. gameState . winCondition + +recogLogHandler :: ReadableIORef AppState -> Handler [SearchLog EntityName] +recogLogHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + return $ + map (fmap (view entityName)) $ + appState ^. gameState . discovery . structureRecognition . recognitionLog + +recogFoundHandler :: ReadableIORef AppState -> Handler [StructureLocation] +recogFoundHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + let registry = appState ^. gameState . discovery . structureRecognition . foundStructures + return + . map (uncurry StructureLocation) + . concatMap (\(x, ys) -> map (x,) $ NE.toList ys) + . M.toList + . M.map NEM.keys + $ foundByName registry + +codeRenderHandler :: Text -> Handler Text +codeRenderHandler contents = do + return $ case processTermEither contents of + Right t -> + into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ t + Left x -> x + +codeRunHandler :: BChan AppEvent -> Text -> Handler Text +codeRunHandler chan contents = do + liftIO . writeBChan chan . Web $ RunWebCode contents + return $ T.pack "Sent\n" + +pathsLogHandler :: ReadableIORef AppState -> Handler (RingBuffer CacheLogEntry) +pathsLogHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + pure $ appState ^. gameState . pathCaching . pathCachingLog + +cmdMatrixHandler :: ReadableIORef AppState -> Handler CommandCatalog +cmdMatrixHandler _ = pure getCatalog + +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 + +mapViewHandler :: ReadableIORef AppState -> AreaDimensions -> Handler GridResponse +mapViewHandler appStateRef areaSize = do + appState <- liftIO (readIORef appStateRef) + let maybeScenario = fst <$> appState ^. uiState . uiGameplay . scenarioRef + pure $ case maybeScenario of + Just s -> + GridResponse True + . Just + . getCellGrid s (appState ^. gameState) + $ areaSize + Nothing -> GridResponse False Nothing + +-- ------------------------------------------------------------------ +-- Main app (used by service and for development) +-- ------------------------------------------------------------------ + +-- | Simple result type to report errors from forked startup thread. +data WebStartResult = WebStarted | WebStartError String + +webMain :: + Maybe (MVar WebStartResult) -> + Warp.Port -> + -- | Read-only reference to the application state. + ReadableIORef AppState -> + -- | Writable channel to send events to the game + BChan AppEvent -> + 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 + + server :: Server ToplevelAPI + server = + mkApp appStateRef chan + :<|> Tagged serveDocs + :<|> serveDirectoryWith (defaultFileServerSettings "web") {ssIndices = [unsafeToPiece "index.html"]} + where + serveDocs _ resp = + resp $ responseLBS ok200 [plain] swarmApiHtml + plain = ("Content-Type", "text/html") + + app :: Network.Wai.Application + app = Servant.serve api server + + handleErr :: IOException -> IO () + handleErr e = case baton of + Just mv -> putMVar mv (WebStartError $ displayException e) + Nothing -> throwIO e + +-- ------------------------------------------------------------------ +-- Web service +-- ------------------------------------------------------------------ + +defaultPort :: Warp.Port +defaultPort = 5357 + +-- | Attempt to start a web thread on the requested port, or a default +-- one if none is requested (or don't start a web thread if the +-- requested port is 0). If an explicit port was requested, fail if +-- startup doesn't work. Otherwise, ignore the failure. In any +-- case, return a @Maybe Port@ value representing whether a web +-- server is actually running, and if so, what port it is on. +startWebThread :: + Maybe Warp.Port -> + -- | Read-only reference to the application state. + ReadableIORef AppState -> + -- | Writable channel to send events to the game + BChan AppEvent -> + 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." +startWebThread userPort appStateRef chan = do + baton <- newEmptyMVar + let port = fromMaybe defaultPort userPort + failMsg = "Failed to start the web API on :" <> show port + void $ forkIO $ webMain (Just baton) port appStateRef chan + res <- timeout 500_000 (takeMVar baton) + case res of + Just WebStarted -> return (Right port) + Just (WebStartError e) -> return . Left $ failMsg <> " - " <> e + -- If user explicitly specified port exit, otherwise just report timeout + Nothing -> case userPort of + Just _p -> fail failMsg + Nothing -> return . Left $ failMsg <> " (timeout)" + +-- ------------------------------------------------------------------ +-- Necessary instances +-- ------------------------------------------------------------------ + +instance SD.ToSample T.Text where + toSamples _ = SD.noSamples + +instance FromHttpApiData RobotID where + parseUrlPiece = fmap RobotID . left T.pack . readEither . T.unpack + +instance SD.ToSample RobotID where + toSamples _ = SD.samples [RobotID 0, RobotID 1] + +instance ToCapture (Capture "id" RobotID) where + toCapture _ = + SD.DocCapture + "id" -- name + "(integer) robot ID" -- description + +instance FromHttpApiData AreaDimensions where + parseUrlPiece x = left T.pack $ do + pieces <- mapM (readEither . T.unpack) $ T.splitOn "x" x + case pieces of + [w, h] -> return $ AreaDimensions w h + _ -> Left "Need two dimensions" + +instance SD.ToSample AreaDimensions where + toSamples _ = SD.samples [AreaDimensions 20 30] + +instance ToCapture (Capture "size" AreaDimensions) where + toCapture _ = + SD.DocCapture + "size" -- name + "(integer, integer) dimensions of area" -- description diff --git a/src/swarm-web/Swarm/Web/Worldview.hs b/src/swarm-web/Swarm/Web/Worldview.hs new file mode 100644 --- /dev/null +++ b/src/swarm-web/Swarm/Web/Worldview.hs @@ -0,0 +1,59 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Render game world for web display +module Swarm.Web.Worldview where + +import Control.Lens ((^.)) +import Data.Aeson (ToJSON) +import Data.Colour.Palette.BrewerSet (Kolor) +import Data.Colour.SRGB (RGB (..), sRGB24, sRGB24show) +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.Scenario (Scenario, scenarioCosmetics, scenarioLandscape) +import Swarm.Game.Scenario.Style +import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..)) +import Swarm.Game.Scenario.Topography.Grid (Grid) +import Swarm.Game.State (GameState, landscape, robotInfo) +import Swarm.Game.State.Robot (viewCenter) +import Swarm.Game.Universe (planar) +import Swarm.Game.World.Render +import Swarm.Util.Content (getTerrainEntityColor) +import Swarm.Util.OccurrenceEncoder + +data GridResponse = GridResponse + { isPlaying :: Bool + , grid :: Maybe CellGrid + } + deriving (Generic, ToJSON) + +getCellGrid :: + Scenario -> + GameState -> + AreaDimensions -> + CellGrid +getCellGrid myScenario gs requestedSize = + CellGrid indexGrid encoding + where + vc = gs ^. robotInfo . viewCenter + sLandscape = myScenario ^. scenarioLandscape + dg = getDisplayGrid (vc ^. planar) sLandscape (gs ^. landscape) (Just requestedSize) + aMap = sLandscape ^. scenarioCosmetics + + asColour :: RGBColor -> Kolor + asColour (RGB r g b) = sRGB24 r g b + asHex = HexColor . T.pack . sRGB24show . asColour + + f = asHex . maybe (RGB 0 0 0) (flattenBg . fromHiFi) . getTerrainEntityColor aMap + (indexGrid, encoding) = runEncoder $ f <$> dg + +data CellGrid = CellGrid + { coords :: Grid IM.Key + , colors :: [HexColor] + } + deriving (Generic, ToJSON) + +instance SD.ToSample GridResponse where + toSamples _ = SD.noSamples diff --git a/swarm.cabal b/swarm.cabal --- a/swarm.cabal +++ b/swarm.cabal @@ -1,412 +1,1013 @@ -cabal-version: 2.4 -name: swarm -version: 0.5.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 - roughly the following layers, from inner to outer: - . - * utilities - * swarm language - * swarm game - * swarm TUI - * swarm app - . - To maintain this separation, inner layers should avoid introducing - dependencies on layers above them. - -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 ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5 || ==9.6.2 -extra-source-files: CHANGELOG.md - example/*.sw - editors/emacs/*.el - editors/vscode/syntaxes/*.json - editors/vim/*.vim - editors/vim/*.lua -data-dir: data/ -data-files: *.yaml, worlds/*.world, scenarios/**/*.yaml, scenarios/**/*.txt, scenarios/**/*.sw, *.txt, test/language-snippets/**/*.sw - -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 - if impl(ghc >= 8.4) - ghc-options: -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 - default-extensions: - BangPatterns - DeriveAnyClass - DeriveDataTypeable - DeriveFunctor - DeriveGeneric - DeriveTraversable - ExplicitForAll - FlexibleContexts - FlexibleInstances - GADTSyntax - MultiParamTypeClasses - NumericUnderscores - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeOperators - -- Note we warn on prequalified - ImportQualifiedPost - -- Not GHC2021, but until we get \cases we use \case a lot - LambdaCase - -library - import: stan-config, common, ghc2021-extensions - exposed-modules: Control.Carrier.Accum.FixedStrict - Data.BoolExpr.Simplify - Swarm.App - Swarm.Constant - Swarm.Doc.Gen - 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.Game.Failure - Swarm.Game.Achievement.Attainment - Swarm.Game.Achievement.Definitions - Swarm.Game.Achievement.Description - Swarm.Game.Achievement.Persistence - Swarm.Game.CESK - Swarm.Game.Display - Swarm.Game.Entity - Swarm.Game.Exception - Swarm.Game.Location - Swarm.Game.Recipe - Swarm.Game.ResourceLoading - Swarm.Game.Robot - Swarm.Game.Scenario - Swarm.Game.Scenario.Topography.Cell - Swarm.Game.Universe - Swarm.Log - Swarm.TUI.Launch.Controller - Swarm.TUI.Launch.Model - Swarm.TUI.Launch.Prep - Swarm.TUI.Launch.View - Swarm.Game.Scenario.Objective - Swarm.Game.Scenario.Objective.Graph - Swarm.Game.Scenario.Objective.Logic - Swarm.Game.Scenario.Objective.Validation - Swarm.Game.Scenario.Objective.WinCheck - Swarm.Game.Scenario.RobotLookup - 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.Style - Swarm.Game.Scenario.Topography.EntityFacade - Swarm.Game.Scenario.Topography.Navigation.Portal - Swarm.Game.Scenario.Topography.Navigation.Util - Swarm.Game.Scenario.Topography.Navigation.Waypoint - Swarm.Game.Scenario.Topography.Placement - Swarm.Game.Scenario.Topography.Structure - Swarm.Game.Scenario.Topography.WorldDescription - Swarm.Game.Scenario.Topography.WorldPalette - Swarm.Game.ScenarioInfo - Swarm.Game.State - Swarm.Game.Step - Swarm.Game.Step.Combustion - Swarm.Game.Step.Pathfinding - Swarm.Game.Step.Util - Swarm.Game.Terrain - Swarm.Game.Value - Swarm.Game.World - Swarm.Game.World.Abstract - Swarm.Game.World.Compile - Swarm.Game.World.Coords - 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.Language.Capability - Swarm.Language.Context - Swarm.Language.Direction - Swarm.Language.Elaborate - Swarm.Language.Key - Swarm.Language.LSP - Swarm.Language.LSP.Hover - Swarm.Language.LSP.VarUsage - Swarm.Language.Module - Swarm.Language.Parse - Swarm.Language.Parse.QQ - Swarm.Language.Pipeline - Swarm.Language.Pipeline.QQ - Swarm.Language.Pretty - Swarm.Language.Requirement - Swarm.Language.Syntax - Swarm.Language.Text.Markdown - Swarm.Language.Typecheck - Swarm.Language.Typecheck.Unify - Swarm.Language.Typed - Swarm.Language.Types - Swarm.Language.Value - Swarm.ReadableIORef - Swarm.TUI.View.Attribute.CustomStyling - Swarm.TUI.View.Attribute.Attr - Swarm.TUI.View.Attribute.Util - Swarm.TUI.Border - Swarm.Game.Scenario.Topography.Area - 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.Controller - Swarm.TUI.Controller.Util - Swarm.TUI.Inventory.Sorting - Swarm.TUI.List - Swarm.TUI.Model - Swarm.TUI.Model.Goal - Swarm.TUI.Model.Menu - Swarm.TUI.Model.Name - Swarm.TUI.Model.Repl - Swarm.TUI.Model.StateUpdate - Swarm.TUI.Model.UI - Swarm.TUI.Panel - Swarm.TUI.View - Swarm.TUI.View.Achievement - Swarm.TUI.View.CellDisplay - Swarm.TUI.View.Objective - Swarm.TUI.View.Util - Swarm.Util - Swarm.Util.Effect - Swarm.Util.Erasable - Swarm.Util.Lens - Swarm.Util.Parse - Swarm.Util.UnitInterval - Swarm.Util.WindowedCounter - Swarm.Util.Yaml - Swarm.Version - Swarm.Web - other-modules: Paths_swarm - autogen-modules: Paths_swarm - - build-depends: base >= 4.14 && < 4.19, - brick-list-skip >= 0.1.1.2 && < 0.2, - aeson >= 2 && < 2.2, - array >= 0.5.4 && < 0.6, - astar >= 0.3 && < 0.3.1, - blaze-html >= 0.9.1 && < 0.9.2, - boolexpr >= 0.2 && < 0.3, - brick >= 1.10 && < 1.11, - bytestring >= 0.10 && < 0.12, - clock >= 0.8.2 && < 0.9, - colour >= 2.3.6 && < 2.4, - commonmark >= 0.2 && < 0.3, - commonmark-extensions >= 0.2 && < 0.3, - containers >= 0.6.2 && < 0.7, - directory >= 1.3 && < 1.4, - dotgen >= 0.4 && < 0.5, - either >= 5.0 && < 5.1, - 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, - fuzzy >= 0.1 && < 0.2, - githash >= 0.1.6 && < 0.2, - hashable >= 1.3.4 && < 1.5, - hsnoise >= 0.0.3 && < 0.1, - http-client >= 0.7 && < 0.8, - http-client-tls >= 0.3 && < 0.4, - http-types >= 0.12 && < 0.13, - lens >= 4.19 && < 5.3, - linear >= 1.21.6 && < 1.23, - lsp >= 1.6 && < 1.7, - megaparsec >= 9.0 && < 9.6, - minimorph >= 0.3 && < 0.4, - transformers >= 0.5 && < 0.7, - mtl >= 2.2.2 && < 2.4, - pandoc >= 3.0 && < 3.2, - pandoc-types >= 1.23 && < 1.24, - murmur3 >= 1.0.4 && < 1.1, - natural-sort >= 0.1.2 && < 0.2, - palette >= 0.3 && < 0.4, - parser-combinators >= 1.2 && < 1.4, - prettyprinter >= 1.7.0 && < 1.8, - random >= 1.2.0 && < 1.3, - scientific >= 0.3.6 && < 0.3.8, - servant >= 0.19 && < 0.21, - servant-docs >= 0.12 && < 0.14, - servant-server >= 0.19 && < 0.21, - SHA >= 1.6.4 && < 1.6.5, - simple-enumeration >= 0.2 && < 0.3, - split >= 0.2.3 && < 0.3, - stm >= 2.5.0 && < 2.6, - syb >= 0.7 && < 0.8, - tagged >= 0.8 && < 0.9, - template-haskell >= 2.16 && < 2.21, - text >= 1.2.4 && < 2.1, - text-rope >= 0.2 && < 0.3, - text-zipper >= 0.10 && < 0.14, - time >= 1.9 && < 1.14, - transformers >= 0.5.6.2 && < 0.6.2.0, - unification-fd >= 0.11 && < 0.12, - unordered-containers >= 0.2.14 && < 0.3, - vector >= 0.12 && < 0.14, - vty >= 5.33 && < 5.39, - wai >= 3.2 && < 3.3, - warp >= 3.2 && < 3.4, - witch >= 1.1.1.0 && < 1.3, - witherable >= 0.4 && < 0.5, - word-wrap >= 0.5 && < 0.6, - yaml >= 0.11 && < 0.11.12.0, - hs-source-dirs: src - 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 - build-depends: optparse-applicative >= 0.16 && < 0.19, - githash >= 0.1.6 && < 0.2, - terminal-size >= 0.3 && < 1.0, - -- Imports shared with the library don't need bounds - base, - text, - prettyprinter, - swarm - hs-source-dirs: app - 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: TestEval - TestInventory - TestModel - TestPedagogy - TestNotification - TestLanguagePipeline - TestPretty - TestBoolExpr - TestCommand - TestLSP - TestScoring - TestUtil - - build-depends: tasty >= 0.10 && < 1.6, - tasty-hunit >= 0.10 && < 0.11, - tasty-quickcheck >= 0.10 && < 0.11, - QuickCheck >= 2.14 && < 2.15, - -- Imports shared with the library don't need bounds - aeson, - base, - boolexpr, - containers, - filepath, - hashable, - lens, - linear, - mtl, - swarm, - text, - time, - witch, - vty - 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 - type: exitcode-stdio-1.0 - - build-depends: tasty >= 0.10 && < 1.6, - tasty-hunit >= 0.10 && < 0.11, - tasty-expected-failure >= 0.12 && < 0.13, - -- Imports shared with the library don't need bounds - base, - containers, - directory, - filepath, - fused-effects, - lens, - linear, - mtl, - swarm, - text, - transformers, - witch, - yaml - hs-source-dirs: test/integration - 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: tasty-bench >= 0.3.1 && < 0.4, - base, - lens, - linear, - mtl, - random, - swarm, - text, - containers, - default-language: Haskell2010 - ghc-options: -threaded +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: + swarm:swarm-engine, + swarm:swarm-lang, + swarm:swarm-scenario, + swarm:swarm-topography, + swarm:swarm-util, + + default-language: Haskell2010 + ghc-options: + -threaded + -with-rtsopts=-A32m + -fproc-alignment=64 diff --git a/test/bench/Benchmark.hs b/test/bench/Benchmark.hs --- a/test/bench/Benchmark.hs +++ b/test/bench/Benchmark.hs @@ -5,43 +5,51 @@ -- SPDX-License-Identifier: BSD-3-Clause module Main where -import Control.Lens ((&), (.~), (^.)) +import Control.Carrier.Accum.FixedStrict (runAccum) +import Control.Lens (view, (&), (.~)) import Control.Monad (replicateM_) -import Control.Monad.Except (runExceptT) import Control.Monad.State (evalStateT, execStateT) import Data.Map qualified as M -import Swarm.Game.CESK (emptyStore, initMachine) +import Data.Sequence (Seq) +import Data.Text qualified as T +import Data.Tuple.Extra (dupe) +import Swarm.Effect (runTimeIO) +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.State (GameState, addTRobot, creativeMode, landscape, multiWorld) +import Swarm.Game.Robot.Walk (emptyExceptions) +import Swarm.Game.Scenario (loadStandaloneScenario) +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.Step (gameTick) -import Swarm.Game.Terrain (TerrainType (DirtT)) +import Swarm.Game.Terrain (blankTerrainIndex) import Swarm.Game.Universe (Cosmic (..), SubworldName (DefaultRootSubworld)) import Swarm.Game.World (WorldFun (..), newWorld) -import Swarm.Language.Context qualified as Context -import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Language.Pipeline.QQ (tmQ) import Swarm.Language.Syntax -import Swarm.TUI.Model (gameState) -import Swarm.TUI.Model.StateUpdate (classicGame0) +import Swarm.Util (parens, showT) import Swarm.Util.Erasable import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, whnfAppIO) -- | The program of a robot that does nothing. -idleProgram :: ProcessedTerm +idleProgram :: TSyntax idleProgram = [tmQ| {} |] -- | The program of a robot which waits a random number of ticks, changes its -- appearance, then waits another random number of ticks, places a tree, and -- then self-destructs. -treeProgram :: ProcessedTerm +treeProgram :: TSyntax treeProgram = [tmQ| { r <- random 100; wait (r + 300); - appear "|"; + appear "|" (inl ()); r <- random 100; wait (r + 300); place "tree"; @@ -50,18 +58,18 @@ |] -- | The program of a robot that moves forward forever. -moverProgram :: ProcessedTerm +moverProgram :: TSyntax moverProgram = [tmQ| - let forever : cmd unit -> cmd unit = \c. c; forever c + let forever : Cmd Unit -> Cmd Unit = \c. c; forever c in forever move |] -- | The program of a robot that moves in circles forever. -circlerProgram :: ProcessedTerm +circlerProgram :: TSyntax circlerProgram = [tmQ| - let forever : cmd unit -> cmd unit = \c. c; forever c + let forever : Cmd Unit -> Cmd Unit = \c. c; forever c in forever ( move; turn right; @@ -82,7 +90,7 @@ -- This is used to compare the performance degradation caused -- by using definitions and chains of ifs. Ideally there should -- not be cost if the code is inlined and simplified. TODO: #1557 -waveProgram :: Bool -> ProcessedTerm +waveProgram :: Bool -> TSyntax waveProgram manualInline = let inlineDef = if manualInline then (1 :: Integer) else 0 in [tmQ| @@ -109,60 +117,98 @@ |] -- | Initializes a robot with program prog at location loc facing north. -initRobot :: ProcessedTerm -> Location -> TRobot -initRobot prog loc = mkRobot () Nothing "" mempty (Just $ Cosmic DefaultRootSubworld loc) north defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False False mempty 0 +initRobot :: TSyntax -> Location -> TRobot +initRobot prog loc = + mkRobot + Nothing + "" + mempty + (Just $ Cosmic DefaultRootSubworld loc) + north + defaultRobotDisplay + (Just prog) + [] + [] + False + False + emptyExceptions + 0 -- | Creates a GameState with numRobot copies of robot on a blank map, aligned -- in a row starting at (0,0) and spreading east. -mkGameState :: (Location -> TRobot) -> Int -> IO GameState -mkGameState robotMaker numRobots = do +mkGameState :: TSyntax -> (Location -> TRobot) -> Int -> IO GameState +mkGameState prog robotMaker numRobots = do let robots = [robotMaker (Location (fromIntegral x) 0) | x <- [0 .. numRobots - 1]] - Right initAppState <- runExceptT classicGame0 + + -- 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 + execStateT - (mapM addTRobot robots) - ( (initAppState ^. gameState) + (zoomRobots $ mapM_ (addTRobot $ initMachine prog) robots) + ( gs & creativeMode .~ True - & landscape . multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (fromEnum DirtT, ENothing))) + & landscape . multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (blankTerrainIndex, ENothing))) ) -- | Runs numGameTicks ticks of the game. runGame :: Int -> GameState -> IO () -runGame numGameTicks = evalStateT (replicateM_ numGameTicks gameTick) +runGame numGameTicks = evalStateT (replicateM_ numGameTicks $ runTimeIO gameTick) main :: IO () main = do - idlers <- mkGameStates idleProgram - trees <- mkGameStates treeProgram - circlers <- mkGameStates circlerProgram - movers <- mkGameStates moverProgram - wavesInlined <- mkGameStates (waveProgram True) - wavesWithDef <- mkGameStates (waveProgram False) + idlers <- mkGameStates largeRobotNumbers idleProgram + trees <- mkGameStates robotNumbers treeProgram + circlers <- mkGameStates robotNumbers circlerProgram + movers <- mkGameStates robotNumbers moverProgram + wavesInlined <- mkGameStates robotNumbers $ waveProgram True + wavesWithDef <- mkGameStates robotNumbers $ waveProgram False -- In theory we should force the evaluation of these game states to normal -- form before running the benchmarks. In practice, the first of the many -- criterion runs for each of these benchmarks doesn't look like an outlier. defaultMain [ bgroup "run 1000 game ticks" - [ bgroup "idlers" (toBenchmarks idlers) - , bgroup "trees" (toBenchmarks trees) - , bgroup "circlers" (toBenchmarks circlers) - , bgroup "movers" (toBenchmarks movers) - , bgroup "wavesInlined" (toBenchmarks wavesInlined) + [ bgroupTicks "idlers" 10000 idlers + , bgroupTicks "trees" 1000 trees + , bgroupTicks "circlers" 1000 circlers + , bgroupTicks "movers" 1000 movers , bgroup - "wavesWithDef" - ( zipWith (\i -> bcompare ("wavesInlined." <> show i)) robotNumbers $ - toBenchmarks wavesWithDef - ) + "waves comparison" + [ bgroup "wavesInlined" (toBenchmarks 1000 wavesInlined) + , bgroup + "wavesWithDef" + ( zipWith (\i -> bcompare ("wavesInlined." <> show i)) robotNumbers $ + toBenchmarks 1000 wavesWithDef + ) + ] ] ] where + bgroupTicks label ticks bots = + bgroup newLabel $ toBenchmarks ticks bots + where + newLabel = + unwords + [ label + , T.unpack $ + parens $ + T.unwords + [ showT ticks + , "ticks" + ] + ] + robotNumbers = [10, 20 .. 40] + largeRobotNumbers = take 4 $ iterate (* 2) 100 - mkGameStates :: ProcessedTerm -> IO [(Int, GameState)] - mkGameStates prog = zip robotNumbers <$> mapM (mkGameState (initRobot prog)) robotNumbers + mkGameStates :: [Int] -> TSyntax -> IO [(Int, GameState)] + mkGameStates botCounts prog = mapM (traverse (mkGameState prog $ initRobot prog) . dupe) botCounts - toBenchmarks :: [(Int, GameState)] -> [Benchmark] - toBenchmarks gameStates = - [ bench (show n) $ whnfAppIO (runGame 1000) gs + toBenchmarks :: Int -> [(Int, GameState)] -> [Benchmark] + toBenchmarks tickCount gameStates = + [ bench (show n) $ whnfAppIO (runGame tickCount) gs | (n, gs) <- gameStates ] diff --git a/test/integration/Main.hs b/test/integration/Main.hs --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -11,9 +11,9 @@ import Control.Carrier.Lift (runM) import Control.Carrier.Throw.Either (runThrow) -import Control.Lens (Ixed (ix), at, to, use, view, (&), (.~), (<>~), (^.), (^..), (^?), (^?!)) +import Control.Lens (Ixed (ix), at, to, view, (&), (.~), (^.), (^..), (^?), (^?!)) import Control.Monad (forM_, unless, when) -import Control.Monad.State (StateT (runStateT), gets) +import Control.Monad.State (execStateT) import Data.Char (isSpace) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (Foldable (toList), find) @@ -21,87 +21,99 @@ import Data.List (partition) import Data.Map qualified as M import Data.Maybe (isJust) -import Data.Sequence (Seq) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Yaml (ParseException, prettyPrintParseException) -import Swarm.Doc.Gen (EditorType (..)) -import Swarm.Doc.Gen qualified as DocGen +import Swarm.Doc.Keyword (EditorType (..)) +import Swarm.Doc.Keyword qualified as Keyword import Swarm.Game.Achievement.Definitions (GameplayAchievement (..)) -import Swarm.Game.CESK (emptyStore, getTickNumber, initMachine) -import Swarm.Game.Entity (EntityMap, lookupByName) +import Swarm.Game.CESK (initMachine) +import Swarm.Game.Entity (lookupByName) import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.Robot (activityCounts, commandsHistogram, defReqs, equippedDevices, lifetimeStepCount, machine, robotContext, robotLog, systemRobot, tangibleCommandCount, waitingUntil) -import Swarm.Game.Scenario (Scenario) +import Swarm.Game.Robot (equippedDevices, 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.State ( GameState, - WinCondition (WinConditions), - WinStatus (Won), - activeRobots, baseRobot, discovery, - gameAchievements, messageInfo, + pathCaching, + robotInfo, + temporal, + winSolution, + ) +import Swarm.Game.State.Robot ( + activeRobots, + robotMap, + waitingRobots, + ) +import Swarm.Game.State.Runtime ( + RuntimeState, + eventLog, + stdGameConfigInputs, + ) +import Swarm.Game.State.Substate ( + gameAchievements, + initState, messageQueue, notificationsContent, - robotMap, - temporal, ticks, - waitingRobots, - winCondition, - winSolution, ) -import Swarm.Game.Step (gameTick) -import Swarm.Game.World.Typecheck (WorldMap) -import Swarm.Language.Context qualified as Ctx -import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) +import Swarm.Game.Step.Path.Type +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.TUI.Model ( - RuntimeState, + KeyEventHandlingState, defaultAppOpts, - eventLog, gameState, runtimeState, - stdEntityMap, userScenario, - worlds, ) import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState) import Swarm.TUI.Model.UI (UIState) -import Swarm.Util (acquireAllWithExt) +import Swarm.Util (findAllWithExt) +import Swarm.Util.RingBuffer qualified as RB import Swarm.Util.Yaml (decodeFileEitherE) -import System.FilePath.Posix (splitDirectories) +import System.FilePath (splitDirectories) import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) +import TestRecipeCoverage import Witch (into) -isUnparseableTest :: (FilePath, String) -> Bool -isUnparseableTest (fp, _) = "_Validation" `elem` splitDirectories fp +isUnparseableTest :: FilePath -> Bool +isUnparseableTest fp = "_Validation" `elem` splitDirectories fp main :: IO () main = do - examplePaths <- acquireAllWithExt "example" "sw" - scenarioPaths <- acquireAllWithExt "data/scenarios" "yaml" + examplePaths <- findAllWithExt "example" "sw" + scenarioPaths <- findAllWithExt "data/scenarios" "yaml" let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths - scenarioPrograms <- acquireAllWithExt "data/scenarios" "sw" - (rs, ui) <- do + scenarioPrograms <- findAllWithExt "data/scenarios" "sw" + (rs, ui, key) <- do out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts either (assertFailure . prettyString) return out - let em = rs ^. stdEntityMap - let rs' = rs & eventLog .~ mempty + let scenarioInputs = gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs + rs' = rs & eventLog .~ mempty + recipeTests <- testRecipeCoverage defaultMain $ testGroup "Tests" [ testNoLoadingErrors rs , exampleTests examplePaths , exampleTests scenarioPrograms - , scenarioParseTests em (rs ^. worlds) parseableScenarios - , scenarioParseInvalidTests em (rs ^. worlds) unparseableScenarios - , testScenarioSolutions rs' ui + , scenarioParseTests scenarioInputs parseableScenarios + , scenarioParseInvalidTests scenarioInputs unparseableScenarios + , testScenarioSolutions rs' ui key , testEditorFiles + , recipeTests ] testNoLoadingErrors :: RuntimeState -> TestTree @@ -118,37 +130,36 @@ isError :: LogEntry -> Bool isError = (>= Warning) . view leSeverity -exampleTests :: [(FilePath, String)] -> TestTree +exampleTests :: [FilePath] -> TestTree exampleTests inputs = testGroup "Test example" (map exampleTest inputs) -exampleTest :: (FilePath, String) -> TestTree -exampleTest (path, fileContent) = +exampleTest :: FilePath -> TestTree +exampleTest path = testCase ("processTerm for contents of " ++ show path) $ do - either (assertFailure . into @String) (const . return $ ()) value - where - value = processTerm $ into @Text fileContent + value <- processTerm <$> T.readFile path + either (assertFailure . into @String) (\_ -> return ()) value -scenarioParseTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree -scenarioParseTests em worldMap inputs = +scenarioParseTests :: ScenarioInputs -> [FilePath] -> TestTree +scenarioParseTests scenarioInputs inputs = testGroup "Test scenarios parse" - (map (scenarioTest Parsed em worldMap) inputs) + (map (scenarioTest Parsed scenarioInputs) inputs) -scenarioParseInvalidTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree -scenarioParseInvalidTests em worldMap inputs = +scenarioParseInvalidTests :: ScenarioInputs -> [FilePath] -> TestTree +scenarioParseInvalidTests scenarioInputs inputs = testGroup "Test invalid scenarios fail to parse" - (map (scenarioTest Failed em worldMap) inputs) + (map (scenarioTest Failed scenarioInputs) inputs) data ParseResult = Parsed | Failed -scenarioTest :: ParseResult -> EntityMap -> WorldMap -> (FilePath, String) -> TestTree -scenarioTest expRes em worldMap (path, _) = - testCase ("parse scenario " ++ show path) (getScenario expRes em worldMap path) +scenarioTest :: ParseResult -> ScenarioInputs -> FilePath -> TestTree +scenarioTest expRes scenarioInputs path = + testCase ("parse scenario " ++ show path) (getScenario expRes scenarioInputs path) -getScenario :: ParseResult -> EntityMap -> WorldMap -> FilePath -> IO () -getScenario expRes em worldMap p = do - res <- decodeFileEitherE (em, worldMap) p :: IO (Either ParseException Scenario) +getScenario :: ParseResult -> ScenarioInputs -> FilePath -> IO () +getScenario expRes scenarioInputs p = do + res <- decodeFileEitherE scenarioInputs p :: IO (Either ParseException Scenario) case expRes of Parsed -> case res of Left err -> assertFailure (prettyPrintParseException err) @@ -176,8 +187,8 @@ data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show) -testScenarioSolutions :: RuntimeState -> UIState -> TestTree -testScenarioSolutions rs ui = +testScenarioSolutions :: RuntimeState -> UIState -> KeyEventHandlingState -> TestTree +testScenarioSolutions rs ui key = testGroup "Test scenario solutions" [ testGroup @@ -193,7 +204,7 @@ , testTutorialSolution Default "Tutorials/build" , testTutorialSolution Default "Tutorials/bind2" , testTutorialSolution' Default "Tutorials/crash" CheckForBadErrors $ \g -> do - let robots = toList $ g ^. robotMap + 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 assertBool "Could not find a robot with winning instructions!" win @@ -208,12 +219,16 @@ , testTutorialSolution (Sec 5) "Tutorials/farming" ] , testGroup + "Fun" + [ testSolution (Sec 20) "Fun/snake" + ] + , testGroup "Challenges" [ testSolution Default "Challenges/chess_horse" , testSolution Default "Challenges/teleport" , testSolution Default "Challenges/maypole" , testSolution (Sec 5) "Challenges/2048" - , testSolution (Sec 3) "Challenges/word-search" + , testSolution (Sec 6) "Challenges/word-search" , testSolution (Sec 10) "Challenges/bridge-building" , testSolution (Sec 5) "Challenges/ice-cream" , testSolution (Sec 10) "Challenges/combo-lock" @@ -226,6 +241,9 @@ , 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" , testGroup "Mazes" [ testSolution Default "Challenges/Mazes/easy_cave_maze" @@ -236,7 +254,9 @@ , testGroup "Ranching" [ testSolution Default "Challenges/Ranching/capture" - , testSolution (Sec 10) "Challenges/Ranching/powerset" + , testSolution (Sec 60) "Challenges/Ranching/beekeeping" + , testSolution (Sec 20) "Challenges/Ranching/powerset" + , testSolution (Sec 10) "Challenges/Ranching/fishing" , testSolution (Sec 30) "Challenges/Ranching/gated-paddock" ] , testGroup @@ -265,9 +285,9 @@ , testSolution Default "Testing/428-drowning-destroy" , testSolution' Default "Testing/475-wait-one" CheckForBadErrors $ \g -> do let t = g ^. temporal . ticks - r1Waits = g ^?! robotMap . ix 1 . to waitingUntil - active = IS.member 1 $ g ^. activeRobots - waiting = elem 1 . concat . M.elems $ g ^. waitingRobots + r1Waits = g ^?! robotInfo . robotMap . ix 1 . to waitingUntil + active = IS.member 1 $ g ^. robotInfo . activeRobots + waiting = elem 1 . concat . M.elems $ 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 @@ -290,8 +310,9 @@ , testSolution Default "Testing/201-require/201-require-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" ] - , testSolution Default "Testing/479-atomic-race" + , testSolution (Sec 2) "Testing/479-atomic-race" , testSolution (Sec 5) "Testing/479-atomic" , testSolution Default "Testing/555-teleport-location" , testSolution (Sec 2) "Testing/562-lodestone" @@ -305,8 +326,8 @@ , testSolution Default "Testing/955-heading" , testSolution' Default "Testing/397-wrong-missing" CheckForBadErrors $ \g -> do let msgs = - (g ^. messageInfo . messageQueue . to seqToTexts) - <> (g ^.. robotMap . traverse . robotLog . to seqToTexts . traverse) + (g ^. messageInfo . messageQueue . to logToText) + <> (g ^.. robotInfo . robotMap . traverse . robotLog . to logToText . traverse) assertBool "Should be some messages" (not (null msgs)) assertBool "Error messages should not mention treads" $ @@ -318,6 +339,7 @@ , testSolution Default "Testing/958-isempty" , testSolution Default "Testing/1007-use-command" , testSolution Default "Testing/1024-sand" + , testSolution Default "Testing/1034-custom-attributes" , testSolution Default "Testing/1140-detect-command" , testSolution Default "Testing/1157-drill-return-value" , testSolution Default "Testing/1171-sniff-command" @@ -326,16 +348,29 @@ , testSolution Default "Testing/1207-scout-command" , testSolution Default "Testing/1218-stride-command" , testSolution Default "Testing/1234-push-command" + , testSolution Default "Testing/1681-pushable-entity" , testSolution Default "Testing/1256-halt-command" , 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/subworld-mapped-robots" , testSolution Default "Testing/144-subworlds/subworld-located-robots" + , testSolution Default "Testing/144-subworlds/subworld-shared-structures" , testSolution Default "Testing/1355-combustion" , testSolution Default "Testing/1379-single-world-portal-reorientation" + , testSolution Default "Testing/1322-wait-with-instant" + , testSolution Default "Testing/1598-detect-entity-change" , testSolution Default "Testing/1399-backup-command" , testSolution Default "Testing/1536-custom-unwalkable-entities" + , testSolution Default "Testing/1721-custom-walkable-entities" + , testSolution Default "Testing/1721-walkability-whitelist-path-cache" + , testSolution Default "Testing/1631-tags" + , testSolution Default "Testing/1747-volume-command" + , testSolution Default "Testing/1775-custom-terrain" + , testSolution Default "Testing/1777-capability-cost" + , testSolution Default "Testing/1642-biomes" + , testSolution (Sec 10) "Testing/1533-sow-command" + , testSolution Default "Testing/1533-sow-seed-maturation" , testGroup -- Note that the description of the classic world in -- data/worlds/classic.yaml (automatically tested to some @@ -356,22 +391,77 @@ , testSolution Default "Testing/836-pathfinding/836-path-exists-distance-limit-unreachable" , testSolution Default "Testing/836-pathfinding/836-no-path-exists1" , testSolution (Sec 10) "Testing/836-pathfinding/836-no-path-exists2" - , testSolution (Sec 3) "Testing/836-pathfinding/836-automatic-waypoint-navigation.yaml" + , testSolution (Sec 3) "Testing/836-pathfinding/836-automatic-waypoint-navigation" ] , testGroup + "Pathfinding cache (#1569)" + [ testSolution Default "Testing/1569-pathfinding-cache/1569-harvest-batch" + , testTutorialSolution' Default "Testing/1569-pathfinding-cache/1569-cache-invalidation-modes" CheckForBadErrors $ \g -> do + let cachingLog = g ^. pathCaching . pathCachingLog + actualEntries = map (\(CacheLogEntry _ x) -> x) $ toList $ RB.getValues cachingLog + expectedEntries = + [ RetrievalAttempt (RecomputationRequired NotCached) + , Invalidate UnwalkableOntoPath + , RetrievalAttempt (RecomputationRequired NotCached) + , RetrievalAttempt Success + , Invalidate UnwalkableRemoved + , RetrievalAttempt (RecomputationRequired NotCached) + , Invalidate TargetEntityAddedOutsidePath + , RetrievalAttempt (RecomputationRequired NotCached) + , Preserve PathTruncated + , RetrievalAttempt Success + ] + assertEqual "Incorrect sequence of invalidations!" expectedEntries actualEntries + , testTutorialSolution' Default "Testing/1569-pathfinding-cache/1569-cache-invalidation-distance-limit" CheckForBadErrors $ \g -> do + let cachingLog = g ^. pathCaching . pathCachingLog + actualEntries = map (\(CacheLogEntry _ x) -> x) $ toList $ RB.getValues cachingLog + expectedEntries = + [ RetrievalAttempt (RecomputationRequired NotCached) + , RetrievalAttempt Success + , RetrievalAttempt Success + , RetrievalAttempt Success + , RetrievalAttempt (RecomputationRequired PositionOutsidePath) + , RetrievalAttempt Success + , RetrievalAttempt (RecomputationRequired (DifferentArg (NewDistanceLimit LimitIncreased))) + , RetrievalAttempt Success + , RetrievalAttempt (RecomputationRequired (DifferentArg (NewDistanceLimit PathExceededLimit))) + , RetrievalAttempt Success + ] + assertEqual "Incorrect sequence of invalidations!" expectedEntries actualEntries + ] + , testGroup "Ping (#1535)" [ testSolution Default "Testing/1535-ping/1535-in-range" , testSolution Default "Testing/1535-ping/1535-out-of-range" ] + , testGroup + "Structure recognition (#1575)" + [ testSolution Default "Testing/1575-structure-recognizer/1575-browse-structures" + , testSolution Default "Testing/1575-structure-recognizer/1575-nested-structure-definition" + , testSolution Default "Testing/1575-structure-recognizer/1575-construction-count" + , testSolution Default "Testing/1575-structure-recognizer/1575-handle-overlapping" + , testSolution Default "Testing/1575-structure-recognizer/1575-ensure-single-recognition" + , testSolution Default "Testing/1575-structure-recognizer/1575-ensure-disjoint" + , testSolution Default "Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest" + , testSolution Default "Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location" + , testSolution Default "Testing/1575-structure-recognizer/1575-remove-structure" + , testSolution Default "Testing/1575-structure-recognizer/1575-swap-structure" + , testSolution Default "Testing/1575-structure-recognizer/1575-placement-occlusion" + , testSolution Default "Testing/1575-structure-recognizer/1575-interior-entity-placement" + , testSolution Default "Testing/1575-structure-recognizer/1575-floorplan-command" + , 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/1430-built-robot-ownership" CheckForBadErrors $ \g -> do - let r2 = g ^. robotMap . at 2 - let r3 = g ^. robotMap . at 3 + let r2 = g ^. robotInfo . robotMap . at 2 + let r3 = g ^. robotInfo . robotMap . at 3 assertBool "The second built robot should be a system robot like it's parent." $ maybe False (view systemRobot) r2 assertBool "The third built robot should be a normal robot like base." $ maybe False (not . view systemRobot) r3 - , testSolution' Default "Testing/1341-command-count" CheckForBadErrors $ \g -> case g ^. robotMap . at 0 of + , testSolution' Default "Testing/1341-command-count" CheckForBadErrors $ \g -> case g ^. robotInfo . robotMap . at 0 of Nothing -> assertFailure "No base bot!" Just base -> do let counters = base ^. activityCounts @@ -382,6 +472,8 @@ assertEqual "Incorrect tangible command count." 7 $ view tangibleCommandCount counters assertEqual "Incorrect command count." 10 $ sum . M.elems $ view commandsHistogram counters assertEqual "Incorrect step count." 62 $ view lifetimeStepCount counters + , expectFailBecause "Awaiting fix for #231" $ + testSolution Default "Testing/231-requirements/231-command-transformer-reqs" ] where -- expectFailIf :: Bool -> String -> TestTree -> TestTree @@ -392,27 +484,25 @@ testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree testSolution' s p shouldCheckBadErrors verify = testCase p $ do - out <- runM . runThrow @SystemFailure $ constructAppState rs ui $ defaultAppOpts {userScenario = Just p} + out <- runM . runThrow @SystemFailure $ constructAppState rs ui key $ defaultAppOpts {userScenario = Just p} case out of Left err -> assertFailure $ prettyString err Right appState -> case appState ^. gameState . winSolution of Nothing -> assertFailure "No solution to test!" - Just sol@(ProcessedTerm _ _ reqCtx) -> do + Just sol -> do when (shouldCheckBadErrors == CheckForBadErrors) (checkNoRuntimeErrors $ appState ^. runtimeState) let gs' = (appState ^. gameState) - -- See #827 for an explanation of why it's important to add to - -- the robotContext defReqs here (and also why this will, - -- hopefully, eventually, go away). - & baseRobot . robotContext . defReqs <>~ reqCtx - & baseRobot . machine .~ initMachine sol Ctx.empty emptyStore - m <- timeout (time s) (snd <$> runStateT playUntilWin gs') + & baseRobot . machine .~ initMachine sol + m <- timeout (time s) (execStateT playUntilWin gs') case m of Nothing -> assertFailure "Timed out - this likely means that the solution did not work." Just g -> do -- When debugging, try logging all robot messages. -- printAllLogs - when (shouldCheckBadErrors == CheckForBadErrors) $ noBadErrors g + when (shouldCheckBadErrors == CheckForBadErrors) $ case noBadErrors g of + Left x -> assertFailure $ T.unpack x + _ -> return () verify g tutorialHasLog :: GameState -> Assertion @@ -423,36 +513,17 @@ testTutorialSolution t f = testSolution' t f CheckForBadErrors tutorialHasLog testTutorialSolution' t f s v = testSolution' t f s $ \g -> tutorialHasLog g >> v g - playUntilWin :: StateT GameState IO () - playUntilWin = do - w <- use winCondition - b <- gets badErrorsInLogs - when (null b) $ case w of - WinConditions (Won _) _ -> return () - _ -> gameTick >> playUntilWin - -noBadErrors :: GameState -> Assertion -noBadErrors g = do - let bad = badErrorsInLogs g - unless (null bad) (assertFailure . T.unpack . T.unlines . take 5 $ nubOrd bad) - -badErrorsInLogs :: GameState -> [Text] -badErrorsInLogs g = - concatMap - (\r -> filter isBad (seqToTexts $ r ^. robotLog)) - (g ^. robotMap) - <> filter isBad (seqToTexts $ g ^. messageInfo . messageQueue) +noBadErrors :: GameState -> Either T.Text () +noBadErrors g = + unless (null bad) (Left . T.unlines . take 5 $ nubOrd bad) where - isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m - -seqToTexts :: Seq LogEntry -> [Text] -seqToTexts = map (view leText) . toList + bad = badErrorsInLogs g printAllLogs :: GameState -> IO () printAllLogs g = mapM_ (\r -> forM_ (r ^. robotLog) (putStrLn . T.unpack . view leText)) - (g ^. robotMap) + (g ^. robotInfo . robotMap) -- | Test that editor files are up-to-date. testEditorFiles :: TestTree @@ -461,28 +532,30 @@ "editors" [ testGroup "VS Code" - [ testTextInVSCode "operators" (const DocGen.operatorNames) - , testTextInVSCode "builtin" DocGen.builtinFunctionList - , testTextInVSCode "commands" DocGen.keywordsCommands - , testTextInVSCode "directions" DocGen.keywordsDirections + [ testTextInVSCode "operators" Keyword.operatorNames + , testTextInVSCode "builtin" Keyword.builtinFunctionList + , testTextInVSCode "commands" Keyword.keywordsCommands + , testTextInVSCode "directions" Keyword.keywordsDirections ] , testGroup "Emacs" - [ testTextInEmacs "builtin" DocGen.builtinFunctionList - , testTextInEmacs "commands" DocGen.keywordsCommands - , testTextInEmacs "directions" DocGen.keywordsDirections + [ testTextInEmacs "operators" Keyword.operatorNames + , testTextInEmacs "builtin" Keyword.builtinFunctionList + , testTextInEmacs "commands" Keyword.keywordsCommands + , testTextInEmacs "directions" Keyword.keywordsDirections ] , testGroup "Vim" - [ testTextInVim "builtin" DocGen.builtinFunctionList - , testTextInVim "commands" DocGen.keywordsCommands - , testTextInVim "directions" DocGen.keywordsDirections + [ testTextInVim "operators" Keyword.operatorNames + , testTextInVim "builtin" Keyword.builtinFunctionList + , testTextInVim "commands" Keyword.keywordsCommands + , testTextInVim "directions" Keyword.keywordsDirections ] ] where - testTextInVSCode name tf = testTextInFile False name (tf VSCode) "editors/vscode/syntaxes/swarm.tmLanguage.json" + testTextInVSCode name tf = testTextInFile False name (tf VSCode) "editors/vscode/syntaxes/swarm.tmLanguage.yaml" testTextInEmacs name tf = testTextInFile True name (tf Emacs) "editors/emacs/swarm-mode.el" - testTextInVim name tf = testTextInFile True name (tf Vim) "editors/vim/swarm.vim" + testTextInVim name tf = testTextInFile False name (tf Vim) "editors/vim/swarm.vim" testTextInFile :: Bool -> String -> Text -> FilePath -> TestTree testTextInFile whitespace name t fp = testCase name $ do let removeLW' = T.unlines . map (T.dropWhile isSpace) . T.lines diff --git a/test/integration/TestRecipeCoverage.hs b/test/integration/TestRecipeCoverage.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestRecipeCoverage.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Ensure recipe coverage for all entities. +module TestRecipeCoverage (testRecipeCoverage) where + +import Control.Lens (view) +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 Test.Tasty +import Test.Tasty.ExpectedFailure (expectFailBecause) +import Test.Tasty.HUnit + +-- | Generate test tree to check that each entity either has a reachable +-- recipe or is in the world or starting base robot inventory. +-- +-- If you added a recipe, thank you, please remove the entity from the list +-- of known uncraftable entities. +-- If you are not sure why an entity with a recipe is unreachable, check out +-- the dot graph of entity recipes in 'Swarm.Doc.Gen' that this test uses. +testRecipeCoverage :: IO TestTree +testRecipeCoverage = do + graphData <- classicScenarioRecipeGraphData + let sortE = List.sortOn (T.unpack . view entityName) + allEntities = sortE . Set.toList $ rgAllEntities graphData + nonCovered = getNonCoveredEntities graphData + return . testGroup "Ensure all entities have recipes" $ + map (\e -> expectNonCovered e $ checkCoverage nonCovered e) allEntities + where + checkCoverage :: Set.Set Entity -> Entity -> TestTree + checkCoverage s e = + let name = view entityName e + in testCase (T.unpack name) $ do + assertBool (errMessage name) (name `elem` 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 + +-- | Known non-covered entities that need a recipe. +nonCoveredList :: [EntityName] +nonCoveredList = + map + T.toCaseFold + [ "Elmer's glue" + , "ash" + , "binoculars" + , "blueprint" + , "caliper" + , "decoder ring" + , "linotype" + , "tape drive" + , "wedge" + ] + +getNonCoveredEntities :: RecipeGraphData -> Set.Set Entity +getNonCoveredEntities graphData = rgAllEntities graphData `Set.difference` Set.unions (rgLevels graphData) diff --git a/test/standalone-topography/src/Lib.hs b/test/standalone-topography/src/Lib.hs new file mode 100644 --- /dev/null +++ b/test/standalone-topography/src/Lib.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Lib (compareToReferenceImage) where + +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), + ) +import Swarm.Game.Scenario.Topography.Rasterize +import Swarm.Game.Scenario.Topography.Structure +import Swarm.Game.Scenario.Topography.Structure.Assembly +import Swarm.Game.Scenario.Topography.Structure.Overlay +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 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 + 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" + 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 new file mode 100644 --- /dev/null +++ b/test/standalone-topography/src/Main.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Main where + +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (testCase) + +import Lib + +main :: IO () +main = do + defaultMain + $ testGroup + "Test structure assembly" + $ map + doTest + [ "circle-and-crosses" + , "checkerboard" + ] + where + doTest stem = testCase (unwords ["Image equality:", stem]) $ compareToReferenceImage stem diff --git a/test/tournament-host/Main.hs b/test/tournament-host/Main.hs new file mode 100644 --- /dev/null +++ b/test/tournament-host/Main.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Tournament hosting +module Main where + +import Data.ByteString.Lazy qualified as LBS +import Data.Digest.Pure.SHA (sha1, showDigest) +import Data.List.NonEmpty qualified as NE +import Data.Map.NonEmpty (NEMap) +import Data.Map.NonEmpty qualified as NEM +import Data.String (fromString) +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Client.MultipartFormData +import Network.HTTP.Types (ok200) +import Network.Wai.Handler.Warp (testWithApplication) +import Swarm.Game.State (Sha1 (..)) +import Swarm.Web.Tournament qualified as Tournament +import Swarm.Web.Tournament.Database.Query +import Swarm.Web.Tournament.Type (UserAlias (..)) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (Assertion, assertEqual, testCase) + +main :: IO () +main = do + scenariosMap <- buildScenariosMap $ pure "data/scenarios/Challenges/arbitrage.yaml" + let appData = mkAppData scenariosMap + defaultMain $ + testGroup + "Test database-agnostic server interactions" + [ testCase "Test scenario upload" $ testScenarioUpload scenariosMap appData + , testCase "Test solution upload" $ testSolutionUpload scenariosMap appData + ] + where + noPersistence = + ScenarioPersistence + { lookupCache = const $ return Nothing + , storeCache = const $ return $ Sha1 "bogus" + , getContent = const $ return Nothing + } + + mkPersistenceLayer scenariosMap = + PersistenceLayer + { scenarioStorage = + noPersistence + { getContent = return . fmap content . (`NEM.lookup` scenariosMap) + } + , solutionStorage = noPersistence + , authenticationStorage = + AuthenticationStorage + { usernameFromCookie = const $ return $ Just fakeUser + , cookieFromUsername = const $ return "fake-cookie-value" + } + } + + fakeUser = UserAlias "test-user" + + mkAppData scenariosMap = + Tournament.AppData + { Tournament.swarmGameGitVersion = Sha1 "abcdef" + , Tournament.gitHubCredentials = Tournament.GitHubCredentials "" "" + , Tournament.persistence = mkPersistenceLayer scenariosMap + , Tournament.developmentMode = Tournament.LocalDevelopment fakeUser + } + +type LocalFileLookup = NEMap Sha1 FilePathAndContent + +data FilePathAndContent = FilePathAndContent + { filePath :: FilePath + , content :: LBS.ByteString + } + +buildScenariosMap :: NE.NonEmpty FilePath -> IO LocalFileLookup +buildScenariosMap pathList = + NEM.fromList <$> traverse getWithHash pathList + where + getWithHash fp = do + fileContent <- LBS.readFile fp + let h = Sha1 $ showDigest $ sha1 fileContent + return (h, FilePathAndContent fp fileContent) + +testScenarioUpload :: LocalFileLookup -> Tournament.AppData -> Assertion +testScenarioUpload fileLookup appData = + mapM_ f testScenarioPaths + where + f x = uploadForm appData "/api/private/upload/scenario" [partFileSource "file" x] + testScenarioPaths = map filePath $ NE.toList $ NEM.elems fileLookup + +testSolutionUpload :: LocalFileLookup -> Tournament.AppData -> Assertion +testSolutionUpload fileLookup appData = + uploadForm appData "/api/private/upload/solution" form + where + solutionFilePath = "data/scenarios/Challenges/_arbitrage/solution.sw" + Sha1 scenarioSha1 = NE.head $ NEM.keys fileLookup + form = + [ partBS "scenario" $ fromString scenarioSha1 + , partFileSource "file" solutionFilePath + ] + +-- * Utils + +uploadForm :: Tournament.AppData -> String -> [PartM IO] -> Assertion +uploadForm appData urlPath form = + testWithApplication (pure tournamentApp) $ \p -> do + manager <- newManager defaultManagerSettings + + let baseUrl = "http://localhost:" ++ show p + reqLogin <- parseRequest $ baseUrl ++ "/api/private/login/local" + respLogin <- httpLbs reqLogin manager + + let apiUrl = baseUrl ++ urlPath + req <- parseRequest apiUrl + resp <- + flip httpLbs manager + =<< formDataBody form (req {cookieJar = Just $ responseCookieJar respLogin}) + + let assertionMsg = + unwords + [ "Server response from" + , apiUrl + , "should be 200;" + , "'respLogin' was:" + , show respLogin + , "and 'resp' was:" + , show resp + ] + assertEqual assertionMsg ok200 $ responseStatus resp + where + tournamentApp = Tournament.app True appData diff --git a/test/unit/Main.hs b/test/unit/Main.hs --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -32,10 +32,14 @@ import TestInventory (testInventory) import TestLSP (testLSP) import TestLanguagePipeline (testLanguagePipeline) -import TestModel (testModel) import TestNotification (testNotification) +import TestOrdering (testOrdering) +import TestOverlay (testOverlay) +import TestParse (testParse) import TestPedagogy (testPedagogy) import TestPretty (testPrettyConst) +import TestRepl (testRepl) +import TestRequirements (testRequirements) import TestScoring (testHighScores) import Witch (from) @@ -51,15 +55,19 @@ testGroup "Tests" [ testLanguagePipeline + , testParse , testPrettyConst , testBoolExpr , testCommands , testHighScores , testEval (s ^. gameState) - , testModel + , testRepl + , testRequirements , testPedagogy (s ^. runtimeState) , testInventory , testNotification (s ^. gameState) + , testOrdering + , testOverlay , testMisc , testLSP ] diff --git a/test/unit/TestCommand.hs b/test/unit/TestCommand.hs --- a/test/unit/TestCommand.hs +++ b/test/unit/TestCommand.hs @@ -12,12 +12,12 @@ import Graphics.Vty.Input.Events qualified as V import Swarm.Game.Location import Swarm.Language.Key -import Swarm.Language.Parse (runParser) -import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction import Test.QuickCheck qualified as QC import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck (testProperty) +import Text.Megaparsec (runParser) import Witch testCommands :: TestTree @@ -47,7 +47,7 @@ [ testGroup "Parsing" ( let parseKeyTest input mods k = - assertEqual "" (runParser parseKeyCombo input) (Right (mkKeyCombo mods k)) + assertEqual "" (runParser parseKeyCombo "" input) (Right (mkKeyCombo mods k)) in [ testCase "parse x" $ parseKeyTest "x" [] (V.KChar 'x') , testCase "parse X" $ parseKeyTest "X" [] (V.KChar 'X') , testCase "parse C" $ parseKeyTest "C" [] (V.KChar 'C') @@ -89,4 +89,4 @@ prop_parse_pretty_key :: KeyCombo -> Bool prop_parse_pretty_key kc = - runParser parseKeyCombo (prettyKeyCombo kc) == Right kc + runParser parseKeyCombo "" (prettyKeyCombo kc) == Right kc diff --git a/test/unit/TestEval.hs b/test/unit/TestEval.hs --- a/test/unit/TestEval.hs +++ b/test/unit/TestEval.hs @@ -133,13 +133,13 @@ ("case (inr 2) (\\x. x + 1) (\\y. y * 17)" `evaluatesTo` VInt 34) , testCase "nested 1" - ("(\\x : int + bool + text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inl 3)" `evaluatesTo` VInt 1) + ("(\\x : Int + Bool + Text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inl 3)" `evaluatesTo` VInt 1) , testCase "nested 2" - ("(\\x : int + bool + text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inr (inl false))" `evaluatesTo` VInt 2) + ("(\\x : Int + Bool + Text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inr (inl false))" `evaluatesTo` VInt 2) , testCase "nested 2" - ("(\\x : int + bool + text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inr (inr \"hi\"))" `evaluatesTo` VInt 3) + ("(\\x : Int + Bool + Text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inr (inr \"hi\"))" `evaluatesTo` VInt 3) ] , testGroup "operator evaluation" @@ -228,6 +228,9 @@ "format function" ("format (\\x. x + 1)" `evaluatesTo` VText "\\x. x + 1") , testCase + "format forall" + ("format \"∀\"" `evaluatesTo` VText "\"∀\"") + , testCase "concat" ("\"x = \" ++ format (2+3) ++ \"!\"" `evaluatesTo` VText "x = 5!") , testProperty @@ -295,7 +298,7 @@ ("[y=1, x=3] < [x=3,y=0]" `evaluatesTo` VBool False) , testCase "record function" - ("let f : [x:int, y:text] -> int = \\r.r.x + 1 in f [x=3,y=\"hi\"]" `evaluatesTo` VInt 4) + ("let f : [x:Int, y:Text] -> Int = \\r.r.x + 1 in f [x=3,y=\"hi\"]" `evaluatesTo` VInt 4) , testCase "format record" ("format [y = 2, x = 1+2]" `evaluatesTo` VText "[x = 3, y = 2]") @@ -305,10 +308,48 @@ `evaluatesTo` VRcd (M.fromList [("x", VInt 2), ("y", VInt 1)]) ) ] + , testGroup + "scope - #681" + [ testCase + "binder in local scope" + ("def f = a <- scan down end; let a = 2 in f; return (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) + , 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) + , 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) + , testCase + "binder in local scope - #1796" + ("def x = \\x.x end; def foo = x <- return 0 end; foo; return (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) + , 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)" + `evaluatesTo` VInt 6 + ) + , testCase + "nested tydef" + ( "def x = (tydef X = Int end; def z : X = 3 end; return (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) ] where tquote :: String -> Text tquote = T.pack . show + throwsError :: Text -> (Text -> Bool) -> Assertion throwsError tm p = do result <- evaluate tm diff --git a/test/unit/TestInventory.hs b/test/unit/TestInventory.hs --- a/test/unit/TestInventory.hs +++ b/test/unit/TestInventory.hs @@ -109,6 +109,6 @@ ) ] where - x = E.mkEntity (defaultEntityDisplay 'X') "fooX" mempty [] [] - y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" mempty [] [] - z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" mempty [] [] + x = E.mkEntity (defaultEntityDisplay 'X') "fooX" mempty [] mempty + y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" mempty [] mempty + z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" mempty [] mempty diff --git a/test/unit/TestLSP.hs b/test/unit/TestLSP.hs --- a/test/unit/TestLSP.hs +++ b/test/unit/TestLSP.hs @@ -9,7 +9,7 @@ import Data.Text (Text) import Data.Text.IO qualified as TIO import Swarm.Language.LSP.VarUsage qualified as VU -import Swarm.Language.Parse (readTerm') +import Swarm.Language.Parser (readTerm) import Swarm.Language.Syntax qualified as S import System.FilePath (()) import Test.Tasty @@ -84,7 +84,7 @@ getWarnings :: Text -> [UnusedVar] getWarnings content = - case readTerm' content of + case readTerm content of Right (Just term) -> map simplifyWarning problems where VU.Usage _ problems = VU.getUsage mempty term diff --git a/test/unit/TestLanguagePipeline.hs b/test/unit/TestLanguagePipeline.hs --- a/test/unit/TestLanguagePipeline.hs +++ b/test/unit/TestLanguagePipeline.hs @@ -15,10 +15,10 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Swarm.Language.Module (Module (..)) -import Swarm.Language.Parse (readTerm) -import Swarm.Language.Parse.QQ (tyQ) -import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) +import Swarm.Language.JSON () +import Swarm.Language.Parser (readTerm) +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 @@ -63,26 +63,73 @@ , testCase "parsing operators #239 - parse valid operator ($)" (valid "fst $ snd $ (1,2,3)") - , testCase - "Allow ' in variable names #269 - parse variable name containing '" - (valid "def a'_' = 0 end") - , testCase - "Allow ' in variable names #269 - do not parse variable starting with '" - ( process - "def 'a = 0 end" - ( T.unlines - [ "1:5:" - , " |" - , "1 | def 'a = 0 end" - , " | ^" - , "unexpected '''" - , "expecting variable name" - ] + , testGroup + "Identifiers" + [ testCase + "Allow ' in variable names #269 - parse variable name containing '" + (valid "def a'_' = 0 end") + , testCase + "Allow ' in variable names #269 - do not parse variable starting with '" + ( process + "def 'a = 0 end" + ( T.unlines + [ "1:5:" + , " |" + , "1 | def 'a = 0 end" + , " | ^" + , "unexpected '''" + , "expecting variable name" + ] + ) ) - ) + , testCase + "Disallow type name as variable name" + ( process + "let Int = 3 in Int + 1" + ( T.unlines + [ "1:8:" + , " |" + , "1 | let Int = 3 in Int + 1" + , " | ^" + , "Reserved word 'Int' cannot be used as a variable name" + ] + ) + ) + , testCase + "Allow uppercase term variable names" + (valid "let Is = 3 in Is + 1") + , testCase + "Disallow uppercase type variable names" + ( process + "def id : A -> A = \\x. x end" + ( T.init $ + T.unlines + [ "1:1: Undefined type A" + , "" + , " - While checking the definition of id" + ] + ) + ) + , testCase + "Allow term variable names which are lowercase versions of reserved type names" + (valid "def idInt : Int -> Int = \\int. int end") + , testCase + "Disallow type variable names which are lowercase versions of reserved type names" + ( process + "def id : int -> int = \\x. x end" + ( T.unlines + [ "1:13:" + , " |" + , "1 | def id : int -> int = \\x. x end" + , " | ^" + , "Reserved type name 'int' cannot be used as a type variable name; perhaps you meant 'Int'?" + ] + ) + ) + ] , testCase "Parse pair syntax #225" - (valid "def f : (int -> bool) * (int -> bool) = (\\x. false, \\x. true) end") + (valid "def f : (Int -> Bool) * (Int -> Bool) = (\\x. false, \\x. true) end") , testCase "Nested pair syntax" (valid "(1,2,3,4)") @@ -95,19 +142,19 @@ "located type error" ( process "def a =\n 42 + \"oops\"\nend" - "2:7: Type mismatch:\n From context, expected `\"oops\"` to have type `int`,\n but it actually has type `text`" + "2:7: Type mismatch:\n From context, expected `\"oops\"` to have type `Int`,\n but it actually has type `Text`" ) , testCase "failure inside bind chain" ( process "move;\n1;\nmove" - "2:1: Type mismatch:\n From context, expected `1` to be a command,\n but it actually has type `int`" + "2:1: Type mismatch:\n From context, expected `1` to be a command,\n but it actually has type `Int`" ) , testCase "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:1: 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" @@ -163,7 +210,7 @@ , testGroup "json encoding" [ testCase "simple expr" (roundTripTerm "42 + 43") - , testCase "module def" (roundTripTerm "def x = 41 end;\ndef y = 42 end") + , testCase "module def" (roundTripTerm "def x = 41 end\n\ndef y = 42 end") ] , testGroup "atomic - #479" @@ -173,10 +220,10 @@ ) , 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; return ()} {}) 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; return true} {return false}) end") , testCase "atomic move+move" ( process @@ -193,7 +240,7 @@ "atomic non-simple" ( process "def dup = \\c. c; c end; atomic (dup (dup move))" - "1:33: Invalid atomic block: reference to variable with non-simple type ∀ a. cmd a -> cmd a: `dup`" + "1:33: Invalid atomic block: reference to variable with non-simple type ∀ a. Cmd a -> Cmd a: `dup`" ) , testCase "atomic nested" @@ -248,39 +295,39 @@ (process "0xabcD6G2" "1:8:\n |\n1 | 0xabcD6G2\n | ^\nunexpected 'G'\n") ] , testGroup - "void type" + "Void type" [ testCase "isSimpleUType" ( assertBool "" $ isSimpleUType UTyVoid ) , testCase "valid type signature" - (valid "def f : void -> a = \\x. undefined end") + (valid "def f : Void -> a = \\x. undefined end") ] , testGroup "record type" [ testCase "valid record" - (valid "\\x:int. ([y = \"hi\", x, z = \\x.x] : [x:int, y:text, z:bool -> bool])") + (valid "\\x:Int. ([y = \"hi\", x, z = \\x.x] : [x:Int, y:Text, z:Bool -> Bool])") , testCase "infer record type" (valid "[x = 3, y = \"hi\"]") , testCase "field mismatch - missing" ( process - "(\\r:[x:int, y:int]. r.x) [x = 3]" + "(\\r:[x:Int, y:Int]. r.x) [x = 3]" "1:26: Field mismatch; record literal has:\n - Missing field(s) `y`" ) , testCase "field mismatch - extra" ( process - "(\\r:[x:int, y:int]. r.x) [x = 3, y = 4, z = 5]" + "(\\r:[x:Int, y:Int]. r.x) [x = 3, y = 4, z = 5]" "1:26: Field mismatch; record literal has:\n - Extra field(s) `z`" ) , testCase "field mismatch - both" ( process - "(\\r:[x:int, y:int]. r.x) [x = 3, z = 5]" + "(\\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`" ) ] @@ -290,14 +337,12 @@ "annotate 1 + 1" ( assertEqual "type annotations" - (toListOf traverse (getSyntax [tmQ| 1 + 1 |])) - [[tyQ| int -> int -> int|], [tyQ|int|], [tyQ|int -> int|], [tyQ|int|], [tyQ|int|]] + (toListOf traverse [tmQ| 1 + 1 |]) + [[tyQ| Int -> Int -> Int|], [tyQ|Int|], [tyQ|Int -> Int|], [tyQ|Int|], [tyQ|Int|]] ) , testCase "get all annotated variable types" - ( let s = - getSyntax - [tmQ| def f : (int -> int) -> int -> text = \g. \x. format (g x) end |] + ( let s = [tmQ| def f : (Int -> Int) -> Int -> Text = \g. \x. format (g x) end |] isVar (TVar {}) = True isVar _ = False @@ -305,25 +350,25 @@ in assertEqual "variable types" (getVars s) - [ (TVar "g", [tyQ| int -> int |]) - , (TVar "x", [tyQ| int |]) + [ (TVar "g", [tyQ| Int -> Int |]) + , (TVar "x", [tyQ| Int |]) ] ) , testCase "simple type ascription" - (valid "(3 : int) + 5") + (valid "(3 : Int) + 5") , testCase "invalid type ascription" - (process "1 : text" "1:1: Type mismatch:\n From context, expected `1` to have type `text`,\n but it actually has type `int`") + (process "1 : Text" "1:1: Type mismatch:\n From context, expected `1` to have type `Text`,\n but it actually has type `Int`") , testCase "type ascription with a polytype" (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 `s0`,\n but it actually has type `Int`") , testCase "type specialization through type ascription" - (valid "fst:(int + b) * a -> int + b") + (valid "fst:(Int + b) * a -> Int + b") , testCase "type ascription doesn't allow rank 2 types" ( process @@ -333,54 +378,154 @@ , 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`" + "(\\x:Int. x + 2) : Text -> Int" + "1:1: Lambda argument has type annotation `Int`, but expected argument type `Text`" ) ] , testGroup + "kind checking" + [ testCase + "Cmd with no arguments" + ( process + "def x : Cmd = move end" + ( T.init $ + T.unlines + [ "1:1: Kind error:" + , " Cmd requires 1 type argument, but was given 0" + , "" + , " - While checking the definition of x" + ] + ) + ) + , testCase + "Cmd with too many arguments" + ( process + "def x : Cmd Int Unit = move end" + ( T.init $ + T.unlines + [ "1:1: Kind error:" + , " Cmd requires 1 type argument, but was given 2" + , " in the type: Cmd Int Unit" + , "" + , " - While checking the definition of x" + ] + ) + ) + , testCase + "Base type applied to one argument" + ( process + "def isZero : Int Bool = \\n. n == 0 end" + ( T.init $ + T.unlines + [ "1:1: Kind error:" + , " Int requires 0 type arguments, but was given 1" + , " in the type: Int Bool" + , "" + , " - While checking the definition of isZero" + ] + ) + ) + , testCase + "Base type applied to several arguments" + ( process + "def isZero : Int (Bool -> Bool) Text (Unit * Unit) = \\n. n == 0 end" + ( T.init $ + T.unlines + [ "1:1: Kind error:" + , " Int requires 0 type arguments, but was given 3" + , " in the type: Int (Bool -> Bool) Text (Unit * Unit)" + , "" + , " - While checking the definition of isZero" + ] + ) + ) + , testCase + "Kind error in lambda type annotation" + ( process + "\\x : Int Int. x + 1" + ( T.init $ + T.unlines + [ "1:1: Kind error:" + , " Int requires 0 type arguments, but was given 1" + , " in the type: Int Int" + ] + ) + ) + , testCase + "Kind error in type annotation" + ( process + "(\\x. x) : Int Int" + ( T.init $ + T.unlines + [ "1:1: Kind error:" + , " Int requires 0 type arguments, but was given 1" + , " in the type: Int Int" + ] + ) + ) + , testCase + "Kind error in let expression" + ( process + "let x : Int Int = 3 in x + 5" + ( T.init $ + T.unlines + [ "1:1: Kind error:" + , " Int requires 0 type arguments, but was given 1" + , " in the type: Int Int" + ] + ) + ) + ] + , testGroup "typechecking errors" [ testCase "applying a pair" ( process "(1,2) \"hi\"" - "1:1: Type mismatch:\n From context, expected `(1, 2)` to be a function,\n but it is actually a pair" + "1:1: Type mismatch:\n From context, expected `(1, 2)` to be a function,\n but it actually has type `Int * Int`" ) , testCase "providing a pair as an argument" ( process - "(\\x:int. x + 1) (1,2)" - "1:17: Type mismatch:\n From context, expected `(1, 2)` to have type `int`,\n but it is actually a pair" + "(\\x:Int. x + 1) (1,2)" + "1:17: Type mismatch:\n From context, expected `(1, 2)` to have type `Int`,\n but it is actually a pair" ) , testCase "mismatched if branches" ( process "if true {grab} {}" - "1:16: Type mismatch:\n From context, expected `noop` to have type `cmd text`,\n but it actually has type `cmd unit`" + "1:16: Type mismatch:\n From context, expected `noop` to have type `Cmd Text`,\n but it actually has type `Cmd Unit`" ) , testCase "definition with wrong result" ( process - "def m : int -> int -> int = \\x. \\y. {3} end" - "1:37: Type mismatch:\n From context, expected `{3}` to have type `int`,\n but it is actually a delayed expression\n\n - While checking the definition of m" + "def m : Int -> Int -> Int = \\x. \\y. {3} end" + "1:37: Type mismatch:\n From context, expected `{3}` to have type `Int`,\n but it is actually a delayed expression\n\n - While checking the definition of m" ) , testCase "comparing two incompatible functions" ( process - "(\\f:int -> text. f 3) (\\x:int. 3)" - "1:32: Type mismatch:\n From context, expected `3` to have type `text`,\n but it actually has type `int`\n" + "(\\f:Int -> Text. f 3) (\\x:Int. 3)" + "1:32: Type mismatch:\n From context, expected `3` to have type `Text`,\n but it actually has type `Int`\n" ) , testCase "comparing two incompatible functions 2" ( process - "(\\f:int -> text. f 3) (\\x:int. \\y:int. \"hi\")" - "1:32: Type mismatch:\n From context, expected `\\y:int. \"hi\"` to have type `text`,\n but it is actually a function\n" + "(\\f:Int -> Text. f 3) (\\x:Int. \\y:Int. \"hi\")" + "1:32: Type mismatch:\n From context, expected `\\y:Int. \"hi\"` to have type `Text`,\n but it is actually a function\n" ) , testCase - "unify two-argument function and int" + "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:5: 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" + ( process + "(\\f. f 3) 2" + "1:11: Type mismatch:\n From context, expected `2` to have a type like `Int -> _`" + ) ] , testGroup "generalize top-level binds #351 #1501" @@ -392,25 +537,142 @@ (valid "f <- return (\\x.x); return (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 <- return (\\x.x); return (f 3, f \"hi\") end") ] + , testGroup + "type synonyms" + [ testCase + "X" + (valid "tydef X = Int end; let n : X = 3 in log (format n)") + , testCase + "Maybe" + (valid "tydef Maybe a = Unit + a end; let x : Maybe Int = inr 3 in case x (\\_. move) (\\n. log (format (n+2)))") + , testCase + "multi-args" + ( valid $ + T.unlines + [ "tydef Foo a b c = a + (b * Int) + Cmd c end;" + , "let f1 : Foo (Cmd Unit) Int Text = inl move in" + , " let f2 : Foo Int (Cmd Unit) Unit = inr (inl (move, 3)) in" + , " let f3 : Foo Int Int Text = inr (inr grab) in" + , " move" + ] + ) + , testCase + "multiple tydefs" + (valid "tydef X = Int end; tydef Y = Unit end; def f : X -> Y = \\n. () end") + , testCase + "sequential tydefs don't need semicolon" + (valid "tydef X = Int end tydef Y = Unit end") + , testCase + "sequential tydef + def don't need semicolon" + (valid "tydef X = Int end def x : X = 5 end") + , testCase + "recursive tydef not allowed" + ( process + "tydef X = Unit + X end" + "1:1: Undefined type X" + ) + , testCase + "nested tydef is allowed" + (valid "def f : Cmd Unit = tydef X = Int end; move end") + , testCase + "tydef with repeated variables" + ( process + "tydef Repeated a b a = a + b end" + "1:33:\n |\n1 | tydef Repeated a b a = a + b end\n | ^\nDuplicate variable on left-hand side of tydef: a\n" + ) + , testCase + "tydef with unbound variables" + ( process + "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" + ) + ] + , testGroup + "recursive types" + [ testCase + "occurs check" + ( process + "def sum = \\l. case l (\\_. 0) (\\c. fst c + sum (snd c)) 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") + , testCase + "vacuous" + ( process + "tydef X = rec x. x end" + "1:1: Encountered vacuous recursive type rec x. x" + ) + , testCase + "nonobviously vacuous" + ( process + "tydef I a = a end; tydef M a b c = b end; tydef X = rec y. rec x. M x (I x) Int end" + "1:43: Encountered vacuous recursive type rec x. M x (I x) Int" + ) + , testCase + "trivial" + ( process + "tydef X = rec x. Int end" + "1:1: Encountered trivial recursive type rec x. Int" + ) + , testCase + "free rec vars" + ( process + "tydef X = rec y. rec x. y end" + "1:1: Encountered trivial recursive type rec x. y" + ) + , testCase + "rec type with undefined tycon" + ( process + "tydef X = rec x. U + x end" + "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 + "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)") + , testCase + "def at non-cmd type" + ( process + "def x = 3 end; x + 2" + "1:16: Type mismatch:\n From context, expected `x + 2` to be a command" + ) + , testCase + "def at cmd type" + (valid "def x = 3 end; move; return (x+2)") + ] ] where valid = flip process "" process :: Text -> Text -> Assertion - process code expect = case processTerm code of + process = processCompare T.isPrefixOf + + processCompare :: (Text -> Text -> Bool) -> Text -> Text -> Assertion + processCompare cmp code expect = case processTerm code of Left e - | not (T.null expect) && expect `T.isPrefixOf` e -> pure () + | not (T.null expect) && cmp expect e -> pure () | otherwise -> error $ "Unexpected failure:\n\n " <> show e <> "\n\nExpected:\n\n " <> show expect <> "\n" Right _ | expect == "" -> pure () | otherwise -> error "Unexpected success" - - getSyntax :: ProcessedTerm -> Syntax' Polytype - getSyntax (ProcessedTerm (Module s _) _ _) = s -- | Check round tripping of term from and to text, then test ToJSON/FromJSON. roundTripTerm :: Text -> Assertion diff --git a/test/unit/TestModel.hs b/test/unit/TestModel.hs deleted file mode 100644 --- a/test/unit/TestModel.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Swarm unit tests -module TestModel where - -import Data.String (fromString) -import Data.Text (Text) -import Swarm.TUI.Model -import Test.Tasty -import Test.Tasty.HUnit - -testModel :: TestTree -testModel = - testGroup - "TUI Model" - [ testCase - "latest repl lines at start" - ( assertEqual - "get 5 history [0] --> []" - [] - (getLatestREPLHistoryItems 5 history0) - ) - , testCase - "latest repl lines after one input" - ( assertEqual - "get 5 history [0|()] --> [()]" - [REPLEntry "()"] - (getLatestREPLHistoryItems 5 (addREPLItem (REPLEntry "()") history0)) - ) - , testCase - "latest repl lines after one input and output" - ( assertEqual - "get 5 history [0|1,1:int] --> [1,1:int]" - [REPLEntry "1", REPLOutput "1:int"] - (getLatestREPLHistoryItems 5 (addInOutInt 1 history0)) - ) - , testCase - "latest repl lines after nine inputs and outputs" - ( assertEqual - "get 6 history [0|1,1:int .. 9,9:int] --> [7,7:int..9,9:int]" - (concat [[REPLEntry (toT x), REPLOutput (toT x <> ":int")] | x <- [7 .. 9]]) - (getLatestREPLHistoryItems 6 (foldl (flip addInOutInt) history0 [1 .. 9])) - ) - , testCase - "latest repl after restart" - ( assertEqual - "get 5 history (restart [0|()]) --> []" - [] - (getLatestREPLHistoryItems 5 (restartREPLHistory $ addREPLItem (REPLEntry "()") history0)) - ) - , testCase - "current item at start" - (assertEqual "getText [0] --> Nothing" (getCurrentItemText history0) Nothing) - , testCase - "current item after move to older" - ( assertEqual - "getText ([0]<=='') --> Just 0" - (Just "0") - (getCurrentItemText $ moveReplHistIndex Older "" history0) - ) - , testCase - "current item after move to newer" - ( assertEqual - "getText ([0]==>'') --> Nothing" - Nothing - (getCurrentItemText $ moveReplHistIndex Newer "" history0) - ) - , testCase - "current item after move past output" - ( assertEqual - "getText ([0,1,1:int]<=='') --> Just 1" - (Just "1") - (getCurrentItemText $ moveReplHistIndex Older "" (addInOutInt 1 history0)) - ) - , testCase - "current item after move past same" - ( assertEqual - "getText ([0,1,1:int]<=='1') --> Just 0" - (Just "0") - (getCurrentItemText $ moveReplHistIndex Older "1" (addInOutInt 1 history0)) - ) - ] - where - history0 = newREPLHistory [REPLEntry "0"] - toT :: Int -> Text - toT = fromString . show - addInOutInt :: Int -> REPLHistory -> REPLHistory - addInOutInt i = addREPLItem (REPLOutput $ toT i <> ":int") . addREPLItem (REPLEntry $ toT i) diff --git a/test/unit/TestNotification.hs b/test/unit/TestNotification.hs --- a/test/unit/TestNotification.hs +++ b/test/unit/TestNotification.hs @@ -9,9 +9,12 @@ import Control.Lens (Getter, Ixed (ix), view, (&), (.~), (^.), (^?!)) import Data.Text (Text) import Data.Text qualified as T -import Swarm.Game.CESK (TickNumber (..)) import Swarm.Game.Robot +import Swarm.Game.Robot.Concrete (robotLog) import Swarm.Game.State +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Tick (TickNumber (..)) import Swarm.Log import Test.Tasty import Test.Tasty.HUnit @@ -40,7 +43,7 @@ assertNew (gs' & messageInfo . lastSeenMessageTime .~ TickNumber 0) 1 "message" messageNotifications , testCase "new message after log" $ do gs' <- goodPlay "create \"logger\"; equip \"logger\"; log \"Hello world!\"" - let r = gs' ^?! robotMap . ix (-1) + let r = gs' ^?! robotInfo . robotMap . ix (-1) assertBool "There should be one log entry in robots log" (length (r ^. robotLog) == 1) assertEqual "The hypothetical robot should be in focus" (Just (r ^. robotID)) (view robotID <$> focusedRobot gs') assertEqual "There should be one log notification" [TickNumber 2] (view leTime <$> gs' ^. messageNotifications . notificationsContent) diff --git a/test/unit/TestOrdering.hs b/test/unit/TestOrdering.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestOrdering.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Swarm unit tests +module TestOrdering where + +import Data.List (sort) +import Swarm.Game.Location +import Test.Tasty +import Test.Tasty.HUnit + +testOrdering :: TestTree +testOrdering = + testGroup + "Ordering" + [ testCase "Sorted locations" $ do + assertEqual "Locations should be ascending" expectedOrder (sort unsortedLocs) + ] + where + unsortedLocs = + [ Location 4 6 + , Location 3 7 + ] + + expectedOrder = + [ Location 3 7 + , Location 4 6 + ] diff --git a/test/unit/TestOverlay.hs b/test/unit/TestOverlay.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestOverlay.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Unit tests for generic grid overlay logic +module TestOverlay where + +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Structure.Overlay +import Test.Tasty +import Test.Tasty.HUnit + +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) + ] + +mkOriginTestCase :: + String -> + Location -> + Location -> + TestTree +mkOriginTestCase adjustmentDescription overlayLocation expectedBaseLoc = + testCase (unwords [adjustmentDescription, "origin adjustment"]) $ do + assertEqual "Base loc wrong" expectedBaseLoc actualBaseLoc + where + baseLayer = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe ())) + overlayLayer = PositionedGrid overlayLocation EmptyGrid + PositionedGrid actualBaseLoc _ = baseLayer <> overlayLayer diff --git a/test/unit/TestParse.hs b/test/unit/TestParse.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestParse.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Swarm parser tests. +module TestParse where + +import Data.Foldable qualified as F +import Data.Text (Text) +import Swarm.Language.Parser.Core (runParser) +import Swarm.Language.Parser.Lex (sc) +import Swarm.Language.Parser.Term (parseTerm) +import Swarm.Language.Parser.Util (fullyMaybe) +import Swarm.Language.Syntax +import Test.Tasty +import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase) +import Text.Megaparsec (errorBundlePretty) +import Witch (into) + +testParse :: TestTree +testParse = + testGroup + "Parser - comments" + [ testCase "none" $ + expectParsedComments + "1 + 2" + [] + , testCase "suffix" $ + expectParsedComments + "1 + 2 // add" + [Comment (SrcLoc 6 12) LineComment SuffixComment " add"] + , testCase "standalone" $ + expectParsedComments + "// add\n1 + 2" + [Comment (SrcLoc 0 6) LineComment StandaloneComment " add"] + , testCase "block suffix" $ + expectParsedComments + "1 + 2 /* add */" + [Comment (SrcLoc 6 15) BlockComment SuffixComment " add "] + , testCase "block standalone" $ + expectParsedComments + "/* add */\n1 + 2" + [Comment (SrcLoc 0 9) BlockComment StandaloneComment " add "] + , testCase "block prefix" $ + expectParsedComments + "/* add */ 1 + 2" + [Comment (SrcLoc 0 9) BlockComment StandaloneComment " add "] + , testCase "block infix" $ + expectParsedComments + "1 + /*add*/ 2" + [Comment (SrcLoc 4 11) BlockComment SuffixComment "add"] + , testCase "multiline block" $ + expectParsedComments + "/* add \n some numbers */\n 1 + 2" + [Comment (SrcLoc 0 25) BlockComment StandaloneComment " add \n some numbers "] + , testCase "multiple lines" $ + expectParsedComments + "// add\n// some numbers\n 1 + 2" + [ Comment (SrcLoc 0 6) LineComment StandaloneComment " add" + , Comment (SrcLoc 7 22) LineComment StandaloneComment " some numbers" + ] + ] + +expectParsedComments :: Text -> [Comment] -> Assertion +expectParsedComments input ex = case runParser (fullyMaybe sc parseTerm) input of + Left err -> assertFailure (into @String $ errorBundlePretty err) + Right (_, res) -> assertEqual "Expected parsed comments" ex (F.toList res) diff --git a/test/unit/TestPedagogy.hs b/test/unit/TestPedagogy.hs --- a/test/unit/TestPedagogy.hs +++ b/test/unit/TestPedagogy.hs @@ -10,7 +10,7 @@ import Data.Map qualified as M import Swarm.Doc.Pedagogy import Swarm.Game.ScenarioInfo (scenarioPath) -import Swarm.TUI.Model (RuntimeState, scenarios) +import Swarm.Game.State.Runtime (RuntimeState, scenarios) import Test.Tasty import Test.Tasty.HUnit diff --git a/test/unit/TestPretty.hs b/test/unit/TestPretty.hs --- a/test/unit/TestPretty.hs +++ b/test/unit/TestPretty.hs @@ -6,11 +6,13 @@ -- Swarm unit tests module TestPretty where +import Data.Fix (Fix (..)) import Swarm.Language.Pretty import Swarm.Language.Syntax hiding (mkOp) import Swarm.Language.Types import Test.Tasty import Test.Tasty.HUnit +import Witch (into) testPrettyConst :: TestTree testPrettyConst = @@ -18,86 +20,82 @@ "Language - pretty" [ testCase "operators #8 - function application unchanged" - ( equalPretty "f say" $ + ( equalPrettyLine "f say" $ TApp (TVar "f") (TConst Say) ) , testCase "operators #8 - double function application unchanged" - ( equalPretty "f () ()" $ + ( equalPrettyLine "f () ()" $ TApp (TApp (TVar "f") TUnit) TUnit ) , testCase "operators #8 - embrace operator parameter" - ( equalPretty "f (==)" $ + ( equalPrettyLine "f (==)" $ TApp (TVar "f") (TConst Eq) ) , testCase "operators #8 - unary negation" - ( equalPretty "-3" $ + ( equalPrettyLine "-3" $ TApp (TConst Neg) (TInt 3) ) , testCase "operators #8 - double unary negation" - ( equalPretty "-(-1)" $ + ( equalPrettyLine "-(-1)" $ TApp (TConst Neg) $ TApp (TConst Neg) (TInt 1) ) , testCase "operators #8 - unary negation with strongly fixing binary operator" - ( equalPretty "-1 ^ (-2)" + ( equalPrettyLine "-1 ^ (-2)" . TApp (TConst Neg) . mkOp' Exp (TInt 1) $ TApp (TConst Neg) (TInt 2) ) , testCase "operators #8 - unary negation with weakly fixing binary operator" - ( equalPretty "-(1 + -2)" + ( equalPrettyLine "-(1 + -2)" . TApp (TConst Neg) . mkOp' Add (TInt 1) $ TApp (TConst Neg) (TInt 2) ) , testCase "operators #8 - simple infix operator" - ( equalPretty "1 == 2" $ + ( equalPrettyLine "1 == 2" $ mkOp' Eq (TInt 1) (TInt 2) ) , testCase "operators #8 - infix operator with less fixing inner operator" - ( equalPretty "1 * (2 + 3)" $ + ( equalPrettyLine "1 * (2 + 3)" $ mkOp' Mul (TInt 1) (mkOp' Add (TInt 2) (TInt 3)) ) , testCase "operators #8 - infix operator with more fixing inner operator" - ( equalPretty "1 + 2 * 3" $ + ( equalPrettyLine "1 + 2 * 3" $ mkOp' Add (TInt 1) (mkOp' Mul (TInt 2) (TInt 3)) ) , testCase "operators #8 - infix operator right associativity" - ( equalPretty "2 ^ 4 ^ 8" $ + ( equalPrettyLine "2 ^ 4 ^ 8" $ mkOp' Exp (TInt 2) (mkOp' Exp (TInt 4) (TInt 8)) ) , testCase "operators #8 - infix operator right associativity not applied to left" - ( equalPretty "(2 ^ 4) ^ 8" $ + ( equalPrettyLine "(2 ^ 4) ^ 8" $ mkOp' Exp (mkOp' Exp (TInt 2) (TInt 4)) (TInt 8) ) , testCase "pairs #225 - nested pairs are printed right-associative" - ( equalPretty "(1, 2, 3)" $ + ( equalPrettyLine "(1, 2, 3)" $ TPair (TInt 1) (TPair (TInt 2) (TInt 3)) ) , testCase - "void type" - ( assertEqual "" "void" . show $ ppr TyVoid - ) - , testCase "type ascription" - ( equalPretty "1 : int" $ + ( equalPrettyLine "1 : Int" $ TAnnotate (TInt 1) (Forall [] TyInt) ) , testCase "lambda precedence (#1468)" - ( equalPretty "\\m. case m (\\x. x + 1) (\\y. y * 2)" $ + ( equalPrettyLine "\\m. case m (\\x. x + 1) (\\y. y * 2)" $ TLam "m" Nothing @@ -107,7 +105,153 @@ :$: STerm (TLam "y" Nothing (mkOp' Mul (TVar "y") (TInt 2))) ) ) + , testGroup + "types" + [ testCase + "Void type" + ( equalPrettyLine "Void" TyVoid + ) + , testCase + "Unit type" + ( equalPrettyLine "Unit" TyUnit + ) + , testCase + "Function type" + ( equalPrettyLine "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit + ) + , testCase + "Cmd type" + ( equalPrettyLine "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt) + ) + , testCase + "Product type" + ( equalPrettyLine "Int * Int" $ TyInt :*: TyInt + ) + , testCase + "Sum type" + ( equalPrettyLine "Int + Int" $ TyInt :+: TyInt + ) + , testCase + "Sum of sum right" + ( equalPrettyLine "Int + (Unit + Bool)" $ TyInt :+: (TyUnit :+: TyBool) + ) + , testCase + "Sum of sum left" + ( equalPrettyLine "(Int + Unit) + Bool" $ (TyInt :+: TyUnit) :+: TyBool + ) + , testCase + "Product of product right" + ( equalPrettyLine "Int * (Unit * Bool)" $ TyInt :*: (TyUnit :*: TyBool) + ) + , testCase + "Product of product left" + ( equalPrettyLine "(Int * Unit) * Bool" $ (TyInt :*: TyUnit) :*: TyBool + ) + , testCase + "Product of sum" + ( equalPrettyLine "Int * (Unit + Bool)" $ TyInt :*: (TyUnit :+: TyBool) + ) + , testCase + "Sum of product" + ( equalPrettyLine "Int + (Unit * Bool)" $ TyInt :+: (TyUnit :*: TyBool) + ) + , testCase + "Product of function" + ( equalPrettyLine "Int * (Unit -> Bool)" $ TyInt :*: (TyUnit :->: TyBool) + ) + , testCase + "Function of product" + ( equalPrettyLine "Int -> (Unit * Bool)" $ TyInt :->: (TyUnit :*: TyBool) + ) + , testCase + "Function of function right" + ( equalPrettyLine "Int -> Unit -> Bool" $ TyInt :->: (TyUnit :->: TyBool) + ) + , testCase + "Function of function left" + ( equalPrettyLine "(Int -> Unit) -> Bool" $ (TyInt :->: TyUnit) :->: TyBool + ) + , testCase + "density (two nested products)" + ( equalPrettyLine "((Int * Int) * (Int * Int)) -> Cmd Int" $ + ((TyInt :*: TyInt) :*: (TyInt :*: TyInt)) :->: TyCmd TyInt + ) + ] + , testGroup + "types but with limited width for pretty printing" + [ testCase + "Void type" + ( equalPrettyWidth 10 "Void" TyVoid + ) + , testCase + "Function type" + ( equalPrettyWidth 20 "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit + ) + , testCase + "Cmd type" + ( equalPrettyWidth 20 "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt) + ) + , testCase + "Product type" + ( equalPrettyWidth 20 "Int * Int" $ TyInt :*: TyInt + ) + , testCase + "Function of function right" + ( equalPrettyWidth 10 "Int ->\nUnit ->\nBool" $ TyInt :->: (TyUnit :->: TyBool) + ) + , testCase + "Function of function left" + ( 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" $ + ((TyInt :*: TyInt) :*: (TyInt :*: TyInt)) :->: TyCmd TyInt + ) + , testCase + "Resonate" + ( equalPrettyWidth 40 "Text -> ((Int * Int) * (Int * Int)) ->\nCmd (Unit + (Int * Int))" $ + TyText :->: ((TyInt :*: TyInt) :*: (TyInt :*: TyInt)) :->: TyCmd (TyUnit :+: (TyInt :*: TyInt)) + ) + ] + , testGroup + "tydef" + [ testCase "tydef alias" $ + equalPrettyLine "tydef X = Int end" $ + TTydef "X" (Forall [] TyInt) Nothing (TConst Noop) + , testCase "tydef Maybe" $ + equalPrettyLine "tydef Maybe a = Unit + a end" $ + TTydef "Maybe" (Forall ["a"] (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"] + (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)) + ] + , testGroup + "recursive types" + [ testCase "nat" $ + equalPrettyLine "rec n. Unit + n" $ + TyRec "n" (TyUnit :+: Fix (TyRecVarF NZ)) + , testCase "list" $ + equalPrettyLine "rec list. Unit + (a * list)" $ + TyRec "list" (TyUnit :+: (TyVar "a" :*: Fix (TyRecVarF NZ))) + , testCase "rose" $ + equalPrettyLine "rec r. a * (rec l. Unit + (r * l))" $ + TyRec "r" (TyVar "a" :*: TyRec "l" (TyUnit :+: (Fix (TyRecVarF (NS NZ)) :*: Fix (TyRecVarF NZ)))) + ] ] where - equalPretty :: String -> Term -> Assertion - equalPretty expected term = assertEqual "" expected . show $ ppr term + equalPrettyLine :: PrettyPrec a => String -> a -> Assertion + equalPrettyLine expected = assertEqual "" expected . into @String . prettyTextLine + + equalPrettyWidth :: PrettyPrec a => Int -> String -> a -> Assertion + equalPrettyWidth width expected doc = assertEqual "" expected . into @String $ prettyTextWidth doc width diff --git a/test/unit/TestRepl.hs b/test/unit/TestRepl.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestRepl.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Swarm REPL unit tests +module TestRepl where + +import Data.String (fromString) +import Data.Text (Text) +import Swarm.TUI.Model.Repl +import Test.Tasty +import Test.Tasty.HUnit + +testRepl :: TestTree +testRepl = + testGroup + "TUI REPL" + [ testCase + "latest repl lines at start" + ( assertEqual + "get 5 history [0] --> []" + [] + (getLatestREPLHistoryItems 5 history0) + ) + , testCase + "latest repl lines after one input" + ( assertEqual + "get 5 history [0|()] --> [()]" + [mkREPLSubmission "()"] + (getLatestREPLHistoryItems 5 (addREPLItem (mkREPLSubmission "()") history0)) + ) + , testCase + "latest repl lines after one input and output" + ( assertEqual + "get 5 history [0|1,1:Int] --> [1,1:Int]" + [mkREPLSubmission "1", mkREPLOutput "1:Int"] + (getLatestREPLHistoryItems 5 (addInOutInt 1 history0)) + ) + , testCase + "latest repl lines after nine inputs and outputs" + ( assertEqual + "get 6 history [0|1,1:Int .. 9,9:Int] --> [7,7:Int..9,9:Int]" + (concat [[mkREPLSubmission (toT x), mkREPLOutput (toT x <> ":Int")] | x <- [7 .. 9]]) + (getLatestREPLHistoryItems 6 (foldl (flip addInOutInt) history0 [1 .. 9])) + ) + , testCase + "latest repl after restart" + ( assertEqual + "get 5 history (restart [0|()]) --> []" + [] + (getLatestREPLHistoryItems 5 (restartREPLHistory $ addREPLItem (mkREPLSubmission "()") history0)) + ) + , testCase + "current item at start" + (assertEqual "getText [0] --> Nothing" (getCurrentItemText history0) Nothing) + , testCase + "current item after move to older" + ( assertEqual + "getText ([0]<=='') --> Just 0" + (Just "0") + (getCurrentItemText $ moveReplHistIndex Older "" history0) + ) + , testCase + "current item after move to newer" + ( assertEqual + "getText ([0]==>'') --> Nothing" + Nothing + (getCurrentItemText $ moveReplHistIndex Newer "" history0) + ) + , testCase + "current item after move past output" + ( assertEqual + "getText ([0,1,1:Int]<=='') --> Just 1" + (Just "1") + (getCurrentItemText $ moveReplHistIndex Older "" (addInOutInt 1 history0)) + ) + , testCase + "current item after move past same" + ( assertEqual + "getText ([0,1,1:Int]<=='1') --> Just 0" + (Just "0") + (getCurrentItemText $ moveReplHistIndex Older "1" (addInOutInt 1 history0)) + ) + ] + where + history0 = newREPLHistory [mkREPLSubmission "0"] + toT :: Int -> Text + toT = fromString . show + addInOutInt :: Int -> REPLHistory -> REPLHistory + addInOutInt i = addREPLItem (mkREPLOutput $ toT i <> ":Int") . addREPLItem (mkREPLSubmission $ toT i) diff --git a/test/unit/TestRequirements.hs b/test/unit/TestRequirements.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestRequirements.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Swarm requirements analysis tests +module TestRequirements where + +import Data.Set qualified as S +import Data.Text (Text) +import Swarm.Language.Capability +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.Syntax.Util (eraseS) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtil (check) + +testRequirements :: TestTree +testRequirements = + testGroup + "Requirements analysis" + [ testGroup + "Basic capabilities" + [ testCase "solar panel" $ "noop" `requiresCap` CPower + , testCase "move" $ "move" `requiresCap` CMove + , testCase "lambda" $ "\\x. x" `requiresCap` CLambda + , testCase "inl" $ "inl 3" `requiresCap` CSum + , testCase "cap from type" $ "inl () : rec t. Unit + t" `requiresCap` CRectype + ] + , testGroup + "Scope" + [ 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") + ] + ] + +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) + +requiresCap :: Text -> Capability -> Assertion +requiresCap code cap = checkRequirements code ((cap `S.member`) . capReqs) diff --git a/test/unit/TestScoring.hs b/test/unit/TestScoring.hs --- a/test/unit/TestScoring.hs +++ b/test/unit/TestScoring.hs @@ -6,12 +6,11 @@ import Data.Text.IO qualified as TIO import Data.Time.Calendar.OrdinalDate import Data.Time.LocalTime -import Swarm.Game.CESK (TickNumber (..)) import Swarm.Game.Scenario.Scoring.Best import Swarm.Game.Scenario.Scoring.CodeSize import Swarm.Game.Scenario.Scoring.ConcreteMetrics import Swarm.Game.Scenario.Scoring.GenericMetrics -import Swarm.Language.Module +import Swarm.Game.Tick (TickNumber (..)) import Swarm.Language.Pipeline import Swarm.Language.Syntax import System.FilePath (()) @@ -32,10 +31,10 @@ , compareAstSize 2 "single-move-def.sw" , compareAstSize 3 "single-move-let-with-invocation.sw" , compareAstSize 5 "double-move-let-with-invocation.sw" - , compareAstSize 6 "single-move-def-with-invocation.sw" - , compareAstSize 8 "double-move-def-with-invocation.sw" - , compareAstSize 28 "single-def-two-args-recursive.sw" - , compareAstSize 36 "single-def-two-args-recursive-with-invocation.sw" + , compareAstSize 3 "single-move-def-with-invocation.sw" + , compareAstSize 5 "double-move-def-with-invocation.sw" + , compareAstSize 25 "single-def-two-args-recursive.sw" + , compareAstSize 30 "single-def-two-args-recursive-with-invocation.sw" ] , testGroup "Precedence" @@ -61,11 +60,10 @@ compareAstSize :: Int -> FilePath -> TestTree compareAstSize expectedSize path = testCase (unwords ["size of", path]) $ do contents <- TIO.readFile $ baseTestPath path - ProcessedTerm (Module stx _) _ _ <- case processTermEither contents of + t <- case processTermEither contents of Right x -> return x Left y -> assertFailure (into @String y) - let actualSize = measureAstSize stx - assertEqual "incorrect size" expectedSize actualSize + assertEqual "incorrect size" expectedSize (measureAstSize t) betterReplTimeAfterCodeSizeRecord :: TestTree betterReplTimeAfterCodeSizeRecord = diff --git a/test/unit/TestUtil.hs b/test/unit/TestUtil.hs --- a/test/unit/TestUtil.hs +++ b/test/unit/TestUtil.hs @@ -13,25 +13,32 @@ import Control.Monad.Trans (lift) import Data.Text (Text) import Data.Text qualified as T +import Swarm.Effect import Swarm.Game.CESK import Swarm.Game.Exception +import Swarm.Game.Land import Swarm.Game.Robot +import Swarm.Game.Robot.Concrete (isActive) import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot import Swarm.Game.Step (gameTick, hypotheticalRobot, stepCESK) -import Swarm.Language.Context -import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) +import Swarm.Language.Pipeline (processTerm) +import Swarm.Language.Syntax.Pattern (TSyntax) import Swarm.Language.Value +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure) +import Witch (into) eval :: GameState -> Text -> IO (GameState, Robot, Either Text (Value, Int)) eval g = either (return . (g,hypotheticalRobot undefined 0,) . Left) (evalPT g) . processTerm1 -processTerm1 :: Text -> Either Text ProcessedTerm +processTerm1 :: Text -> Either Text TSyntax processTerm1 txt = processTerm txt >>= maybe wsErr Right where wsErr = Left "expecting a term, but got only whitespace" -evalPT :: GameState -> ProcessedTerm -> IO (GameState, Robot, Either Text (Value, Int)) -evalPT g t = evalCESK g (initMachine t empty emptyStore) +evalPT :: GameState -> TSyntax -> IO (GameState, Robot, Either Text (Value, Int)) +evalPT g t = evalCESK g (initMachine t) evalCESK :: GameState -> CESK -> IO (GameState, Robot, Either Text (Value, Int)) evalCESK g cesk = @@ -44,31 +51,36 @@ orderResult ((res, rr), rg) = (rg, rr, res) runCESK :: Int -> CESK -> StateT Robot (StateT GameState IO) (Either Text (Value, Int)) -runCESK _ (Up exn _ []) = Left . flip formatExn exn <$> lift (use $ landscape . entityMap) +runCESK _ (Up exn _ []) = Left . flip formatExn exn <$> lift (use $ landscape . terrainAndEntities . entityMap) runCESK !steps cesk = case finalValue cesk of - Just (v, _) -> return (Right (v, steps)) - Nothing -> stepCESK cesk >>= runCESK (steps + 1) + Just v -> return (Right (v, steps)) + Nothing -> runTimeIO (stepCESK cesk) >>= runCESK (steps + 1) play :: GameState -> Text -> IO (Either Text (), GameState) play g = either (return . (,g) . Left) playPT . processTerm1 where - playPT pt = runStateT (playUntilDone (hr ^. robotID)) gs + playPT t = runStateT (playUntilDone (hr ^. robotID)) gs where - cesk = initMachine pt empty emptyStore + cesk = initMachine t hr = hypotheticalRobot cesk 0 hid = hr ^. robotID gs = g - & execState (addRobot hr) - & viewCenterRule .~ VCRobot hid + & execState (zoomRobots $ addRobot hr) + & robotInfo . viewCenterRule .~ VCRobot hid & creativeMode .~ True playUntilDone :: RID -> StateT GameState IO (Either Text ()) playUntilDone rid = do - w <- use robotMap + w <- use $ robotInfo . robotMap case w ^? ix rid . to isActive of Just True -> do - void gameTick + void $ runTimeIO gameTick playUntilDone rid Just False -> return $ Right () Nothing -> return $ Left . T.pack $ "The robot with ID " <> show rid <> " is nowhere to be found!" + +check :: Text -> (TSyntax -> Bool) -> Assertion +check code expect = case processTerm1 code of + Left err -> assertFailure $ "Term processing failed: " ++ into @String err + Right t -> assertBool "Predicate was false!" (expect t)