packages feed

swarm 0.3.0.1 → 0.4

raw patch · 365 files changed

+27682/−6875 lines, 365 filesdep +SHAdep +blaze-htmldep +boolexprdep ~basedep ~brickdep ~containers

Dependencies added: SHA, blaze-html, boolexpr, brick-list-skip, colour, commonmark, commonmark-extensions, fuzzy, servant-docs, witherable

Dependency ranges changed: base, brick, containers, fused-effects, megaparsec, mtl, optparse-applicative, servant, servant-server, template-haskell, text-zipper, time, transformers, vty, witch, yaml

Files

CHANGELOG.md view
@@ -1,5 +1,106 @@ # Revision history for swarm +## **0.4.0.0** - 2023-08-18++### Bugfixes+* Save completion time immediately upon finishing scenario by @xsebek+  ([#1118](https://github.com/swarm-game/swarm/pull/1118))+* Fix rightward bleeding of custom attributes by @kostmo ([#1137](https://github.com/swarm-game/swarm/pull/1137))+* Recreate `GameState` from scratch when starting a scenario by @byorgey ([#1277](https://github.com/swarm-game/swarm/pull/1277))+* Load persistent state from disk only once and reuse for all integration tests by @byorgey ([#1383](https://github.com/swarm-game/swarm/pull/1383))+* Continue parsing the rest of the scenarios in a directory when one fails by @byorgey ([#1391](https://github.com/swarm-game/swarm/pull/1391))+* Throw an error instead of crashing on impredicative types by @byorgey ([#1418](https://github.com/swarm-game/swarm/pull/1418))++### New Features++#### Tutorials+* Some tutorial improvements, and enforce in CI that commands and entities are introduced before they are required by @kostmo ([#1186](https://github.com/swarm-game/swarm/pull/1186))++#### Swarm language+* The `drill` command now returns the first inventory addition by @kostmo ([#1165](https://github.com/swarm-game/swarm/pull/1165))+* Type ascription syntax by @Alexander-Block ([#1164](https://github.com/swarm-game/swarm/pull/1164))+* Records and record types by @byorgey ([#1148](https://github.com/swarm-game/swarm/pull/1148))+* `requirements` command for viewing requirements of any expression by+  @byorgey ([#1183](https://github.com/swarm-game/swarm/pull/1183))+* `stride` command by @kostmo ([#1219](https://github.com/swarm-game/swarm/pull/1219))+* Many new robot sensing commands by @kostmo:+  * `detect` ([#1170](https://github.com/swarm-game/swarm/pull/1170))+  * `sniff` and `chirp` ([#1181](https://github.com/swarm-game/swarm/pull/1181))+  * `resonate` ([#1204](https://github.com/swarm-game/swarm/pull/1204))+  * `watch` and `surveil` ([#1201](https://github.com/swarm-game/swarm/pull/1201))+  * `scout` ([#1209](https://github.com/swarm-game/swarm/pull/1209))+* New key input handler framework by @byorgey, so you can program robots to+  respond to keypresses ([#1214](https://github.com/swarm-game/swarm/pull/1214))+* `instant` command (unrestricted variant of `atomic`) by @kostmo ([#1231](https://github.com/swarm-game/swarm/pull/1231))+* `push` command by @kostmo ([#1235](https://github.com/swarm-game/swarm/pull/1235))+* `density` command by @kostmo ([#1296](https://github.com/swarm-game/swarm/pull/1296))+* `use` command by @kostmo ([#1287](https://github.com/swarm-game/swarm/pull/1287))+* `halt` command by @byorgey ([#1256](https://github.com/swarm-game/swarm/pull/1256))+* `backup` command by @kostmo ([#1400](https://github.com/swarm-game/swarm/pull/1400))++#### Entities + recipes+* Make `sand` a bit harder to get by @byorgey ([#1024](https://github.com/swarm-game/swarm/pull/1024))+* New `tweezers` entity to enable debugging view and single-stepping CESK machine by @xsebek ([#1081](https://github.com/swarm-game/swarm/pull/1081))+* `ADT calculator` description now mentions `unit` and `void` types [#1226](https://github.com/swarm-game/swarm/pull/1226)+* Allow zero-tick recipes to apply immediately by @kostmo ([#1272](https://github.com/swarm-game/swarm/pull/1272))+* New `hourglass` device that provides relative (`wait`) but not absolute (`time`) capability by @kostmo ([#1261](https://github.com/swarm-game/swarm/pull/1261))+* New `binoculars` device that provides `scout` command by @kostmo ([#1337](https://github.com/swarm-game/swarm/pull/1337))+* Separate entities to provide each text operation by @kostmo ([#1339](https://github.com/swarm-game/swarm/pull/1339))++#### World features+* Structure templates by @kostmo ([#1332](https://github.com/swarm-game/swarm/pull/1332))+* Waypoints and portals by @kostmo ([#1356](https://github.com/swarm-game/swarm/pull/1356))+* Subworlds by @kostmo ([#1353](https://github.com/swarm-game/swarm/pull/1353))+* World description DSL by @byorgey ([#1376](https://github.com/swarm-game/swarm/pull/1376))++#### LSP improvements+* `let`-`in` syntax highlighting by @kostmo ([#1162](https://github.com/swarm-game/swarm/pull/1162))++#### Web API+* Web API to parse, render, and run code by @kostmo ([#1142](https://github.com/swarm-game/swarm/pull/1142))++#### Command line options+* CLI option to set initial speed by @kostmo ([#1255](https://github.com/swarm-game/swarm/pull/1255))++#### New scenarios+* Adventure game scenario by @kostmo ([#1136](https://github.com/swarm-game/swarm/pull/1136))+* Run around in circles by @kostmo ([#1158](https://github.com/swarm-game/swarm/pull/1158))+* hackman by @kostmo ([#1135](https://github.com/swarm-game/swarm/pull/1135))+* Whack-a-mole by @kostmo ([#1026](https://github.com/swarm-game/swarm/pull/1026))+* Additional tutorial level on `give` by @byorgey ([#1249](https://github.com/swarm-game/swarm/pull/1249))+* Lights out by @kostmo ([#1273](https://github.com/swarm-game/swarm/pull/1273))+* Pig capturing scenario by @kostmo ([#1258](https://github.com/swarm-game/swarm/pull/1258))+* Sokoban levels by @kostmo ([#1269](https://github.com/swarm-game/swarm/pull/1269))+* Traffic vignette by @kostmo ([#1334](https://github.com/swarm-game/swarm/pull/1334))+* Active trapdoor demo by @kostmo ([#976](https://github.com/swarm-game/swarm/pull/976))+* Sliding puzzle by @kostmo ([#1237](https://github.com/swarm-game/swarm/pull/1237))+* Scenario with enemies by @kostmo ([#971](https://github.com/swarm-game/swarm/pull/971))+* Arbitrage scenario by @kostmo ([#1192](https://github.com/swarm-game/swarm/pull/1192))+* Powerset scenario by @kostmo ([#1342](https://github.com/swarm-game/swarm/pull/1342))++#### UI enhancements+* Allow scrolling the world map unless explicitly disallowed by @byorgey ([#1109](https://github.com/swarm-game/swarm/pull/1109))+* Add random "static" to `view` outside a certain range by @byorgey ([#1110](https://github.com/swarm-game/swarm/pull/1110), [#1241](https://github.com/swarm-game/swarm/pull/1241))+* Display the scenario in which an achievement was obtained by @kostmo ([#1175](https://github.com/swarm-game/swarm/pull/1175))+* World editor prototype by @kostmo ([#873](https://github.com/swarm-game/swarm/pull/873))+* Scenario launch options selection by @kostmo ([#1010](https://github.com/swarm-game/swarm/pull/1010))+* Record best code size by @kostmo ([#974](https://github.com/swarm-game/swarm/pull/974))+* Inventory search/filter mode by @byorgey ([#1250](https://github.com/swarm-game/swarm/pull/1250))+* Display higher clock resolution at lower speeds by @kostmo ([#1253](https://github.com/swarm-game/swarm/pull/1253))+* Make REPL panel collapsible by @ussgarci ([#1076](https://github.com/swarm-game/swarm/pull/1076))+* Better typechecking error messages by @byorgey+  ([#1308](https://github.com/swarm-game/swarm/pull/1308), [#1318](https://github.com/swarm-game/swarm/pull/1318))+* Rename inventory to compendium by @kostmo ([#1346](https://github.com/swarm-game/swarm/pull/1346))+* Goal dialog suppression with `--autoplay` by @kostmo ([#1344](https://github.com/swarm-game/swarm/pull/1344))+* Change binding for Hide REPL to `M-,` by @noahyor ([#1375](https://github.com/swarm-game/swarm/pull/1375))+* Highlight ticks per frame in red when it reaches the cap by @byorgey ([#1386](https://github.com/swarm-game/swarm/pull/1386))+* Parse and render markdown descriptions by @xsebek ([#1106](https://github.com/swarm-game/swarm/pull/1106), [#1413](https://github.com/swarm-game/swarm/pull/1413))++#### Achievements++* Achievement for disorientation by @kostmo ([#1173](https://github.com/swarm-game/swarm/pull/1173))++ ## **0.3.0.1** - 2023-02-01  A few critical bug fixes and improvements:
app/Main.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Main where  import Data.Foldable qualified@@ -12,10 +14,11 @@ import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) import Options.Applicative import Swarm.App (appMain)-import Swarm.DocGen (EditorType (..), GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs)+import Swarm.Doc.Gen (EditorType (..), GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs) import Swarm.Language.LSP (lspMain) import Swarm.Language.Pipeline (processTerm) import Swarm.TUI.Model (AppOpts (..), ColorMode (..))+import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond) import Swarm.Version import Swarm.Web (defaultPort) import System.Exit (exitFailure, exitSuccess)@@ -53,6 +56,7 @@               <*> scenario               <*> run               <*> autoplay+              <*> speedFactor               <*> cheat               <*> color               <*> webPort@@ -68,7 +72,9 @@     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")       ]   editor :: Parser (Maybe EditorType)   editor =@@ -115,6 +121,8 @@   run = optional $ strOption (long "run" <> short 'r' <> metavar "FILE" <> help "Run the commands in a file at startup")   autoplay :: Parser Bool   autoplay = switch (long "autoplay" <> short 'a' <> help "Automatically run the solution defined in the scenario, if there is one. Mutually exclusive with --run.")+  speedFactor :: Parser Int+  speedFactor = option auto (long "speed" <> short 'm' <> value defaultInitLgTicksPerSecond <> help "Initial game speed multiplier")   cheat :: Parser Bool   cheat = switch (long "cheat" <> short 'x' <> help "Enable cheat mode. This allows toggling Creative Mode with Ctrl+v and unlocks \"Testing\" scenarios in the menu.")   color :: Parser (Maybe ColorMode)
bench/Benchmark.hs view
@@ -1,26 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Main where -import Control.Lens ((&), (.~))+import Control.Lens ((&), (.~), (^.)) import Control.Monad (replicateM_) import Control.Monad.Except (runExceptT) import Control.Monad.State (evalStateT, execStateT) import Criterion.Main (Benchmark, bench, bgroup, defaultConfig, defaultMainWith, whnfAppIO) import Criterion.Types (Config (timeLimit))+import Data.Map qualified as M import Swarm.Game.CESK (emptyStore, initMachine) import Swarm.Game.Display (defaultRobotDisplay)+import Swarm.Game.Location import Swarm.Game.Robot (TRobot, mkRobot)-import Swarm.Game.State (GameState, addTRobot, classicGame0, creativeMode, world)+import Swarm.Game.State (GameState, addTRobot, creativeMode, multiWorld) import Swarm.Game.Step (gameTick) import Swarm.Game.Terrain (TerrainType (DirtT))+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 (north)-import Swarm.Util.Location+import Swarm.TUI.Model (gameState)+import Swarm.TUI.Model.StateUpdate (classicGame0)+import Swarm.Util.Erasable  -- | The program of a robot that does nothing. idleProgram :: ProcessedTerm@@ -70,19 +76,19 @@  -- | Initializes a robot with program prog at location loc facing north. initRobot :: ProcessedTerm -> Location -> TRobot-initRobot prog loc = mkRobot () Nothing "" [] (Just loc) north defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False False 0+initRobot prog loc = mkRobot () Nothing "" mempty (Just $ Cosmic DefaultRootSubworld loc) north defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False False 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   let robots = [robotMaker (Location (fromIntegral x) 0) | x <- [0 .. numRobots - 1]]-  Right initState <- runExceptT classicGame0+  Right initAppState <- runExceptT classicGame0   execStateT     (mapM addTRobot robots)-    ( initState+    ( (initAppState ^. gameState)         & creativeMode .~ True-        & world .~ newWorld (WF $ const (fromEnum DirtT, Nothing))+        & multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (fromEnum DirtT, ENothing)))     )  -- | Runs numGameTicks ticks of the game.@@ -114,6 +120,6 @@    toBenchmarks :: [(Int, GameState)] -> [Benchmark]   toBenchmarks gameStates =-    [ bench (show n) $ whnfAppIO (runGame 1000) gameState-    | (n, gameState) <- gameStates+    [ bench (show n) $ whnfAppIO (runGame 1000) gs+    | (n, gs) <- gameStates     ]
data/about.txt view
@@ -1,4 +1,4 @@-Copyright 2021-2022, Brent Yorgey and other Swarm contributors+Copyright 2021-2023, Brent Yorgey and other Swarm contributors For a full list of contributors, see https://github.com/swarm-game/swarm/graphs/contributors.  Join the community!
data/entities.yaml view
@@ -7,7 +7,7 @@     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]+  properties: [portable, growable, opaque]   growth: [500, 600]  - name: branch@@ -42,8 +42,11 @@   description:   - A plain wooden workbench, providing space to make other     things using the `make` command.-  - 'Example:'-  - 'make "log"'+  - |+    Example:+    ```+    make "log"+    ```   properties: [portable]   capabilities: [make] @@ -71,7 +74,7 @@     char: 'o'   description:   - A medium-sized rock, picked up from the ground or created by drilling.-    Can be used to build a simple furnace, among other things.+    Can be ground into sand or used to build a simple furnace, among other things.   properties: [portable]  - name: handle@@ -117,7 +120,7 @@     char: 'A'   description:   - A mountain. Can be tunneled through with a drill, but it takes time.-  properties: [unwalkable]+  properties: [unwalkable, opaque]  - name: mountain tunnel   display:@@ -336,6 +339,66 @@   properties: [portable, growable]   growth: [100, 800] +- 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@@ -345,24 +408,27 @@     information, made of twisted cotton fibers.  Multiple strings can     also be woven into larger configurations such as cloth or nets.   - |-    An equipped `string` device enables several commands for working with-    `text` values:+    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`+    The infix operator `++ : text -> text -> text`{=snippet}     can be used to concatenate two text values.  For example,   - |-    "Number of widgets: " ++ format numWidgets+    ```+    let numWidgets = 42+    in "Number of widgets: " ++ format numWidgets+    ```   - |     `chars : text -> int` computes the number of characters in a-    `text` value.+    `text`{=type} value.   - |-    `split : int -> text -> text * text` splits a `text` value into+    `split : int -> text -> text * text` splits a `text`{=type} value into     two pieces, one before the given index and one after.   properties: [portable]-  capabilities: [text]+  capabilities: [format, concat, charcount, split]  - name: decoder ring   display:@@ -375,9 +441,9 @@     enables two functions:   - |     `charAt : int -> text -> int` returns the numeric code of the-    character at a specific index in a (0-indexed) `text` value.+    character at a specific index in a (0-indexed) `text`{=type} value.   - |-    `toChar : int -> text` creates a singleton (length-1) `text`+    `toChar : int -> text` creates a singleton (length-1) `text`{=type}     value containing a character with the given numeric code.   properties: [portable]   capabilities: [code]@@ -390,8 +456,11 @@   - 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` which repeats a command three times.+  - |+    ```+    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]@@ -428,7 +497,7 @@   description:   - A robot with a boat equipped can float on top of water without drowning.   - |-    Note: most devices are automatically equipped on robots that+    **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.@@ -440,9 +509,10 @@     attr: sand     char: '█'   description:-  - A substance composed mostly of tiny rocks and mineral particles.  It-    tends to be found near water, and can be used in a furnace to make glass.-  properties: [portable, infinite]+  - 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:@@ -694,13 +764,19 @@   description:   - Equipping treads on a robot allows it to move and turn.   - The `move` command moves the robot forward one unit.-  - 'Example:'-  - '  move; move; // move two units'+  - |+    Example:+    ```+    move; move; // move two units+    ```   - 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'+  - |+    Example:+    ```+    move; turn left; move; turn right+    ```   capabilities: [move, turn]   properties: [portable] @@ -714,6 +790,26 @@   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@@ -741,18 +837,27 @@     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+    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,+  - 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@@ -816,7 +921,9 @@     attr: device     char: '!'   description:-  - A drill allows robots to drill through rocks and mountains, and extract resources from mines.+  - 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] @@ -849,13 +956,19 @@   - 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"}'   - |+    ```+    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'   - |+    ```+    r <- build {move}; view r+    ```+  - |     builds a robot and then views it.    properties: [portable]@@ -869,13 +982,19 @@   description:   - |     A dictionary allows a robot to remember definitions and reuse them-    later.  You can access this ability with either a `def` command,+    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` expression, which names an+    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` and `let` are optional.+  - |+    ```+    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]@@ -891,7 +1010,11 @@     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:'-  - 'if (x > 3) {move} {turn right; move}'+  - |+    ```+    let x = 2 in+    if (x > 3) {move} {turn right; move}+    ```   properties: [portable]   capabilities: [cond] @@ -942,6 +1065,16 @@   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@@ -993,7 +1126,10 @@   - "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`"+  - |+    ```+    l <- listen; log $ "I have waited for someone to say " ++ l+    ```   properties: [portable]   capabilities: [listen] @@ -1003,7 +1139,7 @@     char: 'C'   description:   - |-    A counter enables the command `count : string -> cmd int`,+    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@@ -1033,20 +1169,21 @@     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` is+    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`.+    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` is a type with three elements, then there are 2 * 3 = 6-    different pairs containing a `bool` and a `t`, that is, 6 elements-    of type `bool * t`.  For working with products of types, the ADT-    calculator enables pair syntax `(a, b)` as well as the projection+    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` is either a `bool` value or a `t` value,-    and there are 2 + 3 = 5 such values.  For working with sums of+    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@@ -1070,7 +1207,9 @@     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] @@ -1085,8 +1224,31 @@   - |     `wait : int -> cmd unit` causes a robot to sleep for a specified amount of time (measured in game ticks).   properties: [portable]-  capabilities: [time]+  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@@ -1115,8 +1277,9 @@     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} {}-+    ```+    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@@ -1124,7 +1287,9 @@   - "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} {})+    ```+    atomic (b <- ishere "rock"; if b {grab; return ()} {})+    ```    properties: [portable]   capabilities: [atomic]@@ -1135,9 +1300,11 @@     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,+    equipped, you can use the `try` command to catch errors. For example   - |-    `try {move} {turn left}`+    ```+    try {move} {turn left}+    ```   - will attempt to move, but if that fails, turn left instead.   properties: [portable]   capabilities: [try]@@ -1148,22 +1315,24 @@     char: 'Y'   description:   - A device for transforming electric current into radio waves, and-    vice versa.+    vice versa.  Antennas can be used to increase the viable range+    over which you can communicate with your robots.   - |-    It can be used to locate nearby actors, by bouncing radio+    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 (() + actor)` tries to locate a+    `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`.  For example, if `x`, `y`,-    and `z` are nearby actors, then `meetAll f b0` is equivalent to-    `b1 <- f b0 x; b2 <- f b1 y; f b2 z`.+    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] @@ -1178,3 +1347,87 @@     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]
data/recipes.yaml view
@@ -168,6 +168,22 @@   weight: 3  - in:+  - [1, rock]+  out:+  - [4, sand]+  required:+  - [1, drill]+  time: 9++- in:+  - [1, rock]+  out:+  - [4, sand]+  required:+  - [1, metal drill]+  time: 3++- in:   - [1, mountain]   out:   - [8, rock]@@ -296,8 +312,18 @@   required:   - [1, drill]   time: 42+  weight: 9  - in:+  - [1, copper mine]+  out:+  - [2, rock]+  - [1, copper mine]+  required:+  - [1, drill]+  time: 42++- in:   - [1, iron mine]   out:   - [1, iron ore]@@ -305,8 +331,18 @@   required:   - [1, drill]   time: 64+  weight: 9  - in:+  - [1, iron mine]+  out:+  - [2, rock]+  - [1, iron mine]+  required:+  - [1, drill]+  time: 64++- in:   - [1, quartz mine]   out:   - [1, quartz]@@ -314,8 +350,18 @@   required:   - [1, drill]   time: 64+  weight: 9  - in:+  - [1, quartz mine]+  out:+  - [2, rock]+  - [1, quartz mine]+  required:+  - [1, drill]+  time: 64++- in:   - [1, copper mine]   out:   - [1, copper ore]@@ -539,6 +585,11 @@   out:   - [1, GPS receiver] +- in:+  - [1, iron plate]+  out:+  - [1, tweezers]+ ## MAGIC  - in:@@ -757,3 +808,42 @@   - [256, string]   out:   - [1, net]++#########################################+##                 MISC                ##+#########################################++- in:+  - [1, water]+  - [1, silicon]+  required:+  - [50, solar panel]+  out:+  - [1, quantum dot]++- in:+  - [1, small motor]+  - [1, copper pipe]+  - [1, mithril]+  - [1, quantum dot]+  - [1, iron plate]+  out:+  - [1, victrola]++- in:+  - [1, iron plate]+  out:+  - [4, key]++- in:+  - [1, board]+  - [16, key]+  out:+  - [1, keyboard]++- in:+  - [1, branch predictor]+  - [1, grabber]+  - [1, toolkit]+  out:+  - [1, halting oracle]
data/scenarios/00-ORDER.txt view
@@ -6,3 +6,5 @@ Fun Speedruns Testing+Vignettes+Mechanics
data/scenarios/Challenges/00-ORDER.txt view
@@ -1,11 +1,20 @@+arbitrage.yaml chess_horse.yaml+bridge-building.yaml+maypole.yaml teleport.yaml 2048.yaml word-search.yaml+gopher.yaml ice-cream.yaml hanoi.yaml+hackman.yaml+lights-out.yaml bucket-brigade.yaml wolf-goat-cabbage.yaml+blender.yaml friend.yaml Mazes Ranching+Sokoban+Sliding Puzzles
data/scenarios/Challenges/2048.yaml view
@@ -179,7 +179,8 @@       - [1, "1"] known: [water, wavy water, flower, tree] world:-  default: [stone]+  dsl: |+    {stone}   palette:     "Ω": [grass, null, base]     "┌": [stone, upper left corner]
data/scenarios/Challenges/Mazes/easy_cave_maze.yaml view
@@ -65,7 +65,8 @@     - The place you're trying to reach!  You win by executing `grab` on this item.     properties: [known, portable] world:-  default: [ice]+  dsl: |+    {ice}   palette:     'Ω': [stone, null, base]     ' ': [stone, null]
data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml view
@@ -7,7 +7,7 @@   - 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`.+    you win by `grab`bing the `goal`{=entity}.   - Beware! The winding corridors are wider then they look!   condition: |     j <- robotNamed "judge";@@ -65,7 +65,8 @@     - The place you're trying to reach!  You win by executing `grab` on this item.     properties: [known, portable] world:-  default: [ice]+  dsl: |+    {ice}   palette:     'Ω': [stone, null, base]     ' ': [stone, null]
data/scenarios/Challenges/Mazes/invisible_maze.yaml view
@@ -8,7 +8,7 @@   - 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`.+    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: |@@ -65,7 +65,8 @@     - The place you're trying to reach!  You win by executing `grab` on this item.     properties: [known, portable] world:-  default: [grass]+  dsl: |+    {grass}   palette:     'Ω': [grass, null, base]     '.': [grass, null]
data/scenarios/Challenges/Mazes/loopy_maze.yaml view
@@ -8,7 +8,7 @@   - 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`.+    the `goal`{=entity}.   - In this challenge, you are NOT guaranteed that the maze is a tree, that is,     the maze may contain loops.   condition: |@@ -58,7 +58,8 @@     - The place you're trying to reach!  You win by executing `grab` on this item.     properties: [known, portable] world:-  default: [grass]+  dsl: |+    {grass}   palette:     'Ω': [grass, null, base]     '.': [grass, null]
data/scenarios/Challenges/Ranching/00-ORDER.txt view
@@ -1,1 +1,3 @@+capture.yaml+powerset.yaml gated-paddock.yaml
+ data/scenarios/Challenges/Ranching/_capture/opponent.sw view
@@ -0,0 +1,114 @@+/**+If any blocking entity is touching me, escape.+*/++def elif = \t. \then. \else. {if t then else} end+def else = \t. t end+def abs = \n. if (n < 0) {-n} {n} end;+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+def until = \p. \c. q <- p; if q {} {c; until p c} end;++def getDirection = \n.+    if (n == 0) {+        forward;+    } $ elif (n == 1) {+        right;+    } $ elif (n == 2) {+        back;+    } $ elif (n == 3) {+        left;+    } $ else {+        down;+    };+    end;++def watchDir = \n.+    watch $ getDirection n;+    if (n > 0) {+        watchDir $ n - 1;+    } {};+    end;++def boolToInt = \b.+    if b {1} {0}+    end;++/**+Iterate 4 times (once for each direction)+*/+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 0;+    }+    end;++def reWatch =+    watchDir 4;+    end;++def locationIsOpen =+    emptyHere <- isempty;+    blockedCount <- countBlocked 4;+    return $ emptyHere && blockedCount == 0;+    end;++def faceAwayFrom = \loc.+    myLoc <- whereami;+    let x = fst loc - fst myLoc in+    let y = snd loc - snd myLoc in+    let d = if (abs x > abs y) {+        if (x > 0) {west} {east}+    } {+        if (y > 0) {south} {north}+    } in+    turn d;+    end;++/**+Move in opposite direction from base to+find a cross-shaped region that has zero blockages.+*/+def findOpenArea =+    baseLoc <- as base {whereami};+    faceAwayFrom baseLoc;+    until locationIsOpen move;+    end;++def relocateAway =+    marker <- grab;+    findOpenArea;+    try {+        swap marker;+        return ();+    } {+        place marker;+    };+    end;++def handleBlockage =+    blockedCount <- countBlocked 4;+    if (blockedCount > 0) {+        if (blockedCount < 4) {+            relocateAway;+        } {+            selfdestruct;+        }+    } {};+    end;++def go =+    instant reWatch;+    wait 1000;+    instant handleBlockage;+    go;+    end;++go;
+ data/scenarios/Challenges/Ranching/_capture/solution.sw view
@@ -0,0 +1,123 @@+/**+Need to synchronize pushes so that in the same tick+that the first boulder comes into contact with the+opponent, there is no escape route.+*/++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 walkAround = \d1. \d2.+    turn d1;+    doN 3 move;+    turn d2;++    doN 3 move;+    turn d2;+    end;++def buildBot = \initialTurn.+    _r1 <- build {+        watch back;+        wait 200;+        doN 2 move;+        turn initialTurn;+        walkAround right left;+        push;+    };++    _r2 <- build {+        watch back;+        wait 200;+        doN 2 move;+        turn initialTurn;+        walkAround left right;+        push;+    };+    end;++def arrangeBoulders =+    // First boulder+    turn right;+    move;+    turn left;+    doN 7 move;+    turn left;+    push;+    turn right;+    move;+    turn left;+    move;+    turn left;+    doN 4 push;++    // Second boulder+    turn back;+    doN 7 move;+    turn left;+    doN 2 move;+    turn left;+    doN 5 push;++    // Third boulder+    turn right;+    doN 4 move;+    turn left;+    doN 7 move;+    turn left;+    move;+    turn left;+    doN 3 push;+    turn left;+    move;+    turn right;+    move;+    turn right;+    push;++    // Fourth boulder+    turn right;+    doN 3 move;+    turn left;+    doN 2 push;+    turn right;+    move;+    turn left;+    move;+    turn left;+    push;+    end;++def go =++    doN 3 move;+    obj <- grab;++    arrangeBoulders;++    turn right;+    doN 2 move;+    turn back;+    buildBot right;+    turn back;+    move;++    turn left;+    move;+    buildBot left;+    turn back;+    move;++    place obj;+    move;+    end;++go;
data/scenarios/Challenges/Ranching/_gated-paddock/enclosure-checking.sw view
@@ -59,6 +59,7 @@                     // Nothing will remain on the ground.                     // after making the "steam" via                     // the drilling recipe.+                    return ();                 } {                     grab;                     return ();
+ data/scenarios/Challenges/Ranching/_powerset/setup.sw view
@@ -0,0 +1,257 @@+def elif = \t. \then. \else. {if t then else} end+def else = \t. t end++// modulus function (%)+def mod : int -> int -> int = \i. \m.+  i - m * (i / m)+end++def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def until = \p. \c. q <- p; if q {} {c; until p c} end;+def while = \p. until (x <- p; return $ not x) end;++def isDivisibleBy = \dividend. \divisor.+    (dividend / divisor) * divisor == dividend;+    end;++def isEven = \x.+   isDivisibleBy x 2+   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;++/**+Tests whether only a single bit is set in the bitmask.+Aborts early with 'false' if a second bit is detected.+*/+def exactlyOneBit = \foundOneBit. \bitmask.+    if (bitmask == 0) {+      foundOneBit;+    } {+      let bitIsSet = not $ isEven bitmask in+      if (foundOneBit && bitIsSet) {+        false;+      } {+        exactlyOneBit (foundOneBit || bitIsSet) $ bitmask / 2;+      }+    }+    end;++/** Teleports to a new location to execute a function+  then returns to the original location before+  returning the functions output value.+*/+def atLocation = \newLoc. \f.+    prevLoc <- whereami;+    teleport self newLoc;+    retval <- f;+    teleport self prevLoc;+    return retval;+    end;++def placeSand =+    let item = "sand" in+    create item;+    place item;+    move;+    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;++def getEntName = \idx.+    if (idx == 1) {+        "grape"+    } $ elif (idx == 2) {+        "lemon"+    } $ elif (idx == 3) {+        "apple"+    } $ elif (idx == 4) {+        "blueberry"+    } $ elif (idx == 5) {+        "watermelon"+    } $ elif (idx == 6) {+        "orange"+    } $ else {+        "dragonfruit"+    }+    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;++/**+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;++        // Recursion bug workaround (see #1032):+        let blahNextRandomVal = nextRandomVal in++        let newBitmask = bitmask + shiftLeft 1 nextRandomVal in+        naiveRandomStack valueFunc maxval newBitmask $ n - 1;+        return blahNextRandomVal;+    } {+        // 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 placeThing = \entIdx.+    let entName = getEntName entIdx in+    create entName;+    place entName;+    end;++def placeEntsForBits = \bitmask. \bitIndex.+    if (isBitSet bitmask bitIndex) {+        placeThing bitIndex;+        move;+    } {};+    end;++def columnFunc = \exclusionValue. \inputCardinality. \x.+    if (x != 0 && x != exclusionValue && not (exactlyOneBit false x)) {+        naiveRandomStack (placeEntsForBits x) inputCardinality 0 inputCardinality;+        myloc <- whereami;+        teleport self (fst myloc + 1, 0);+    } {};+    end;++def makeSandRow = \length.+    turn east;+    atLocation (0, -1) $ doN length placeSand;+    end;++def chooseExclusionValue = \powersetCardinality.++    // For cardinality 32, for example, the value of "r"+    // will be between 0 and 30, inclusive.+    r <- random $ powersetCardinality - 1;++    // We offset by one so as not to exclude zero.+    // So the exclusion value is now between+    // 1 and 31, inclusive.+    let value = r + 1 in++    if (exactlyOneBit false value) {+      chooseExclusionValue powersetCardinality;+    } {+      return value;+    }+    end;++/**+"inputCardinality" is the number of distinct entities+*/+def setup = \inputCardinality.+    let powersetCardinality = 2^inputCardinality in+    makeSandRow $ powersetCardinality - (1 + inputCardinality);++    turn north;+    move;+    exclusionValue <- chooseExclusionValue powersetCardinality;+    naiveRandomStack (columnFunc exclusionValue inputCardinality) powersetCardinality 0 powersetCardinality;+    return exclusionValue;+    end;++/**+One-based ordinal of the item.+*/+def getOrdinal : text -> cmd int = \item.+    count item;+    end;++def checkSolutionSum = \runningSum.+    maybeItem <- scan down;+    case maybeItem (\_. return runningSum) (\item.+        // The bell is the only other item we can place in this+        // scenario besides the fruits.+        if (item != "bell") {+            theOrdinal <- getOrdinal item;+            let binaryValue = shiftLeft 1 $ theOrdinal - 1 in+            move;+            checkSolutionSum $ binaryValue + runningSum;+        } {return runningSum};+    );+    end;++def waitForFirstPlacement =+    watch down;+    wait 1000;+    emptyhere <- isempty;+    if emptyhere {waitForFirstPlacement} {};+    end;++def go = \distinctCount.+    exclusionValue <- instant $ setup distinctCount;+    give base "bell";++    waitForFirstPlacement;+    while (as base {has "bell"}) $ wait 2;+    theSum <- checkSolutionSum 0;+    let sentinelItem = if (exclusionValue == theSum) {"bit (1)"} {"bit (0)"} in+    create sentinelItem;+    end;++go 7;
+ data/scenarios/Challenges/Ranching/_powerset/solution.sw view
@@ -0,0 +1,168 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+def until = \p. \c. q <- p; if q {} {c; until p c} end;+def while = \p. until (x <- p; return $ not x) end;++def abs = \n. if (n < 0) {-n} {n} end;++def intersperse = \n. \f2. \f1.+    if (n > 0) {+        f1;+        if (n > 1) {+            f2;+        } {};+        intersperse (n - 1) f2 f1;+    } {};+    end;++def mapTuple = \f. \t.+    (f $ fst t, f $ snd t)+    end;++def sumTuples = \t1. \t2.+    (fst t1 + fst t2, snd t1 + snd t2);+    end;++def negateTuple = \t.+    mapTuple (\x. -x) t;+    end;++def getRelativeLocation = \absCurrentLoc. \absDestLoc.+    let negatedLoc = negateTuple absCurrentLoc in+    return $ sumTuples negatedLoc absDestLoc;+    end;++def splitStride = \n.+    let dist = abs n in+    if (dist > 64) {+        stride 64;+        splitStride $ dist - 64;+    } {+        stride dist;+    }+    end;++def moveTuple = \tup.+    let x = fst tup in+    let y = snd tup in+    turn $ if (x > 0) {east} {west};+    // doN (abs x) move;+    splitStride x;++    turn $ if (y > 0) {north} {south};+    // doN (abs y) move;+    splitStride y;+    end;++def goToLocation = \currentLoc. \absoluteDestination.+    relativeDestination <- getRelativeLocation currentLoc absoluteDestination;+    moveTuple relativeDestination;+    end;++def recordFirstEncounter = \stashLoc. \item.+    originalHeading <- heading;+    originalLoc <- whereami;+    goToLocation originalLoc stashLoc;+    turn south;+    until isempty move;+    place item;++    newCurrentLoc <- whereami;+    goToLocation newCurrentLoc originalLoc;+    turn originalHeading;+    end;++def tryHarvest = \stashLoc.+    maybeItem <- scan down;+    case maybeItem return (\item.+        hasSome <- has item;+        harvest;+        if hasSome {} {+            while isempty $ wait 1;+            // Grab another one so that our "sentinel condition" won't+            // be invalidated when we go on to place it+            harvest;+            recordFirstEncounter stashLoc item;+        };+    );+    end;++def doRow = \stashLoc. \sandLength.+    intersperse (sandLength - 1) move $ tryHarvest stashLoc;+    end;++def turnaround = \d.+    turn d;+    move;+    turn d;+    end;++/**+Precondition:+At the start of the line, facing along the line.+*/+def countLine = \tally.+    emptyhere <- isempty;+    if emptyhere {+        turn back;+        splitStride tally;+        return tally;+    } {+        move;+        countLine $ tally + 1;+    }+    end;++def placeFinalCopy = \item.+    originalLoc <- whereami;+    goToLocation originalLoc (fst originalLoc, 0);+    until isempty move;+    place item;+    newLoc <- whereami;+    goToLocation newLoc originalLoc;+    end;++def copyIfNeeded = \targetCount.+    maybeItem <- scan down;+    case maybeItem return (\item.+        quantity <- count item;+        if (quantity < targetCount) {+            placeFinalCopy item;+        } {};+    );+    move;+    end;++def harvestForCounts = \rowLength. \stashLoc. \sweepCount.++    intersperse sweepCount (turnaround right) $+        intersperse 2 (turnaround left) $ doRow stashLoc rowLength;+    +    turnaround right;+    doRow stashLoc rowLength;+    end;++def go = \sweepCount.+    until (has "bell") $ wait 2;+    +    move;+    rowLength <- countLine 0;+    let stashLoc = (rowLength - 1, -2) in+    turnaround right;++    harvestForCounts rowLength stashLoc sweepCount;++    originalLoc <- whereami;+    goToLocation originalLoc stashLoc;+    turn south;++    entityCardinality <- countLine 0;++    turn back;+    let expectedCount = 2^(entityCardinality - 1) - 1 in+    doN entityCardinality $ copyIfNeeded expectedCount;++    // Mark goal-checkability sentinel+    place "bell";+    end;++go 3;
+ data/scenarios/Challenges/Ranching/capture.yaml view
@@ -0,0 +1,163 @@+version: 1+name: Pig wrestling+author: Karl Ostmo+description: |+  Capture a slippery pig+creative: false+seed: 0+attrs:+  - name: bacon+    fg: "#ba6b57"+  - name: pig+    fg: "#eba28f"+objectives:+  - teaser: Block in pig+    goal:+      - |+        This porcine pest has been running amok.+        Block the pig by a "monolith" on all four sides to capture it.+      - Blocking on fewer than four sides will spook the pig, and he will escape!+    condition: |+      def isSurrounded = \n.+          if (n > 0) {+              blockedFwd <- blocked;+              if blockedFwd {+                  turn left;+                  isSurrounded $ n - 1;+              } {+                  return false;+              }+          } {+              return true;+          }+          end;++      opponent <- robotnamed "opponent";+      as opponent {+        isSurrounded 4;+      };+  - teaser: Spooked+    id: spooked+    optional: true+    hidden: true+    goal:+      - |+        The pig was spooked by the capture attempt.+    condition: |+      def boolToInt = \b.+          if b {1} {0}+          end;++      /**+      Iterate 4 times (once for each direction)+      */+      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 0;+          }+          end;++      opponent <- robotnamed "opponent";+      as opponent {+          blockCount <- countBlocked 4;+          return $ blockCount > 0 && blockCount < 4;+      };+robots:+  - name: base+    dir: [1, 0]+    devices:+      - 3D printer+      - branch predictor+      - calculator+      - clock+      - comparator+      - dictionary+      - dozer blade+      - grabber+      - hearing aid+      - keyboard+      - lambda+      - logger+      - scanner+      - strange loop+      - treads+      - welder+      - workbench+    inventory:+      - [6, dozer blade]+      - [6, ADT calculator]+      - [6, branch predictor]+      - [6, clock]+      - [6, comparator]+      - [6, counter]+      - [6, dictionary]+      - [6, grabber]+      - [6, lambda]+      - [6, lodestone]+      - [6, logger]+      - [6, mirror]+      - [6, net]+      - [6, rolex]+      - [6, scanner]+      - [6, solar panel]+      - [6, string]+      - [6, strange loop]+      - [6, treads]+      - [6, welder]+  - name: opponent+    system: true+    dir: [0, 1]+    display:+      char: P+      attr: pig+      invisible: false+    program: |+      run "scenarios/Challenges/Ranching/_capture/opponent.sw"+solution: |+   run "scenarios/Challenges/Ranching/_capture/solution.sw"+entities:+  - name: monolith+    display:+      char: '@'+    description:+    - Pushable rock+    properties: [known, unwalkable, portable]+    capabilities: [push]+  - name: bacon+    display:+      attr: bacon+      char: 'Z'+    description:+    - Odiferous constitution of pig+    properties: [known]+known: [flower, tree]+world:+  dsl: |+    {grass}+  upperleft: [0, 0]+  offset: false+  palette:+    'B': [grass, null, base]+    '.': [grass]+    '@': [grass, monolith]+    '*': [grass, flower]+    'x': [grass, bacon, opponent]+  map: |+    ................+    ....@...........+    ....@...........+    ................+    .......x......@.+    ................+    ................+    .B..*......@....+    ................+
data/scenarios/Challenges/Ranching/gated-paddock.yaml view
@@ -82,6 +82,7 @@                           // Nothing will remain on the ground.                           // after making the "steam" via                           // the drilling recipe.+                          return ();                       } {                           grab;                           return ();@@ -141,7 +142,7 @@           create specialDrill;           equip specialDrill; -          // NOTE: System robots can walk on water+          // **NOTE:** System robots can walk on water           // so we only need this if we want to           // demo the algorithm with a player robot.       //    create "boat";@@ -505,14 +506,15 @@ solution: |   run "scenarios/Challenges/Ranching/_gated-paddock/fence-construction.sw" world:-  default: [dirt, water]+  dsl: |+    {dirt, water}   palette:-    'B': [grass, null, base]-    '.': [grass]+    'B': [grass, erase, base]+    '.': [grass, erase]     't': [dirt, tree]     'x': [stone, mountain]     'c': [stone, cabin]-    's': [grass, null, sheep]+    's': [grass, erase, sheep]     '%': [grass, clover, null]     'H': [stone, pier, null]     '~': [dirt, water]
+ data/scenarios/Challenges/Ranching/powerset.yaml view
@@ -0,0 +1,191 @@+version: 1+name: Fruit hybrids+author: Karl Ostmo+description: |+  Find the missing fruit combination+creative: false+attrs:+  - name: fruit0+    fg: "#ff0080"+  - name: fruit1+    fg: "#b000ff"+  - name: fruit2+    fg: "#ffff00"+  - name: fruit3+    fg: "#ff0000"+  - name: fruit4+    fg: "#0000ff"+  - name: fruit5+    fg: "#00ff00"+  - name: fruit6+    fg: "#ff8000"+objectives:+  - teaser: Find missing hybrid+    id: complete_powerset+    goal:+      - |+        Farmer Bill is breeding hybrid fruits.+        Each fruit can be paired with one or more other fruit variety, and Bill+        wants to evaluate every such combination.+        He has arranged each hybrid in a column in his orchard.+      - |+        However, his experiment is incomplete! He has forgotten one combination.+      - |+        Place the missing hybrid combination in the empty eastern-most column.+        After you have done this, `place` the "bell" anywhere, and then Bill will inspect+        your work.+    prerequisite:+        not: wrong_anwser+    condition: |+      r <- robotnamed "setup";+      as r {has "bit (1)"};+  - teaser: Wrong answer+    id: wrong_anwser+    optional: true+    goal:+      - |+        Farmer Bill is disappointed.+    condition: |+      r <- robotnamed "setup";+      as r {has "bit (0)"};+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - hourglass+      - comparator+      - compass+      - counter+      - dictionary+      - Elmer's glue+      - fruit picker+      - fruit planter+      - GPS receiver+      - lambda+      - linotype+      - lodestone+      - logger+      - keyboard+      - net+      - rocket skates+      - scanner+      - strange loop+      - treads+  - name: setup+    system: true+    dir: [1, 0]+    display:+      invisible: true+    inventory:+      - [1, bell]+      - [1, dragonfruit]+      - [2, grape]+      - [3, lemon]+      - [4, apple]+      - [5, blueberry]+      - [6, watermelon]+      - [7, orange]+    program: |+      run "scenarios/Challenges/Ranching/_powerset/setup.sw"+solution: |+   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]+    capabilities: [movemultiple]+  - name: bell+    display:+      char: 'B'+      attr: gold+    description:+      - A bell for Bill+    properties: [known, portable]+  - name: fruit picker+    display:+      char: 'P'+    description:+      - Enables the `harvest` command.+    properties: [known]+    capabilities: [harvest]+  - name: fruit planter+    display:+      char: 'p'+    description:+      - Enables the `place` command.+    properties: [known]+    capabilities: [place]+  - name: dragonfruit+    display:+      char: 'Y'+      attr: fruit0+    description:+      - Dragonfruits+    properties: [known, growable, portable]+    growth: [10, 10]+  - name: grape+    display:+      char: 'Y'+      attr: fruit1+    description:+      - Grapes+    growth: [10, 10]+    properties: [known, growable, portable]+  - name: lemon+    display:+      char: 'Y'+      attr: fruit2+    description:+      - Lemons+    growth: [10, 10]+    properties: [known, growable, portable]+  - name: apple+    display:+      char: 'Y'+      attr: fruit3+    description:+      - Apple+    growth: [10, 10]+    properties: [known, growable, portable]+  - name: blueberry+    display:+      char: 'Y'+      attr: fruit4+    description:+      - Blueberries+    growth: [10, 10]+    properties: [known, growable, portable]+  - name: watermelon+    display:+      char: 'Y'+      attr: fruit5+    description:+      - Watermelons+    growth: [10, 10]+    properties: [known, growable, portable]+  - name: orange+    display:+      char: 'Y'+      attr: fruit6+    description:+      - Oranges+    growth: [10, 10]+    properties: [known, growable, portable]+known: [sand]+world:+  dsl: |+    {grass}+  upperleft: [-1, -1]+  offset: false+  palette:+    '.': [grass]+    'B': [grass, null, base]+    'S': [grass, null, setup]+  map: |+    BS
+ data/scenarios/Challenges/Sliding Puzzles/00-ORDER.txt view
@@ -0,0 +1,1 @@+3x3.yaml
+ data/scenarios/Challenges/Sliding Puzzles/3x3.yaml view
@@ -0,0 +1,743 @@+version: 1+name: 3x3 Sliding Puzzle+author: Karl Ostmo+description: |+  Place the 8 tiles in order+creative: false+seed: 0+attrs:+  - name: oddtile+    fg: "#D2B48C"+    bg: "#400000"+  - name: eventile+    fg: "#000000"+    bg: "#B0B0B0"+objectives:+  - teaser: Solve puzzle+    goal:+      - |+        Arrange the tiles in increasing (row-major) order.+      - |+        To slide a tile into the empty space, position yourself+        behind it and `push`.+      - |+        Or, if you prefer, `drill` a tile to cause it to slide+        into the adjacent empty space. However, you must not drill a tile that+        has nowhere to slide. Also, drilling consumes "ink", which will be replenished+        after the sliding operation is complete, so avoid drilling too fast in+        succession.+    condition: |+      j <- robotnamed "setup";+      as j {run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw"};+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - comparator+      - compass+      - counter+      - decoder ring+      - dictionary+      - dozer blade+      - drill+      - gradiator+      - GPS receiver+      - hearing aid+      - hourglass+      - keyboard+      - lambda+      - locator+      - logger+      - mirror+      - scanner+      - string+      - strange loop+      - treads+    inventory:+      - [1, ink]+      - [1, a-tile-ordinal]+      - [2, b-tile-ordinal]+      - [3, c-tile-ordinal]+      - [4, d-tile-ordinal]+      - [5, e-tile-ordinal]+      - [6, f-tile-ordinal]+      - [7, g-tile-ordinal]+      - [8, h-tile-ordinal]+      - [9, i-tile-ordinal]+      - [10, j-tile-ordinal]+      - [11, k-tile-ordinal]+      - [12, l-tile-ordinal]+      - [13, m-tile-ordinal]+      - [14, n-tile-ordinal]+      - [15, o-tile-ordinal]+      - [16, p-tile-ordinal]+      - [17, q-tile-ordinal]+      - [18, r-tile-ordinal]+      - [19, s-tile-ordinal]+      - [20, t-tile-ordinal]+      - [21, u-tile-ordinal]+      - [22, v-tile-ordinal]+      - [23, w-tile-ordinal]+      - [24, x-tile-ordinal]+      - [25, y-tile-ordinal]+  - name: maintainer+    system: true+    dir: [1, 0]+    display:+      invisible: true+      attr: 'gold'+    inventory:+      - [1, a-tile-ordinal]+      - [2, b-tile-ordinal]+      - [3, c-tile-ordinal]+      - [4, d-tile-ordinal]+      - [5, e-tile-ordinal]+      - [6, f-tile-ordinal]+      - [7, g-tile-ordinal]+      - [8, h-tile-ordinal]+      - [9, i-tile-ordinal]+      - [10, j-tile-ordinal]+      - [11, k-tile-ordinal]+      - [12, l-tile-ordinal]+      - [13, m-tile-ordinal]+      - [14, n-tile-ordinal]+      - [15, o-tile-ordinal]+      - [16, p-tile-ordinal]+      - [17, q-tile-ordinal]+      - [18, r-tile-ordinal]+      - [19, s-tile-ordinal]+      - [20, t-tile-ordinal]+      - [21, u-tile-ordinal]+      - [22, v-tile-ordinal]+      - [23, w-tile-ordinal]+      - [24, x-tile-ordinal]+      - [25, y-tile-ordinal]+    program: |+      run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw";+  - name: setup+    system: true+    dir: [1, 0]+    display:+      invisible: true+      attr: 'iron'+    inventory:+      - [1, a-tile-ordinal]+      - [2, b-tile-ordinal]+      - [3, c-tile-ordinal]+      - [4, d-tile-ordinal]+      - [5, e-tile-ordinal]+      - [6, f-tile-ordinal]+      - [7, g-tile-ordinal]+      - [8, h-tile-ordinal]+      - [9, i-tile-ordinal]+      - [10, j-tile-ordinal]+      - [11, k-tile-ordinal]+      - [12, l-tile-ordinal]+      - [13, m-tile-ordinal]+      - [14, n-tile-ordinal]+      - [15, o-tile-ordinal]+      - [16, p-tile-ordinal]+      - [17, q-tile-ordinal]+      - [18, r-tile-ordinal]+      - [19, s-tile-ordinal]+      - [20, t-tile-ordinal]+      - [21, u-tile-ordinal]+      - [22, v-tile-ordinal]+      - [23, w-tile-ordinal]+      - [24, x-tile-ordinal]+      - [25, y-tile-ordinal]+    program: |+      run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw";+solution: |+   run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw"+entities:+  - name: gradiator+    display:+      char: 'G'+    description:+      - Generates a magnetic field gradient that allows the use of `resonate`+    properties: [known]+    capabilities: [detectcount]+  - name: locator+    display:+      char: '{'+    description:+      - Enables the `detect` command+    properties: [known]+    capabilities: [detectloc]+  - name: border+    display:+      char: '▒'+    description:+      - Immovable playfield border+    properties: [known]+  - name: ink+    display:+      char: 'i'+    description:+      - Marking fluid to designate the tile to slide+    properties: [known]+  - name: dozer blade+    display:+      attr: silver+      char: '/'+    description:+    - Facilitates pushing+    properties: [known, portable]+    capabilities: [push]+  - name: sliding-tile+    display:+      char: '*'+    description:+      - Tile that is being moved+    properties: [known]+  - name: a-tile+    display:+      char: 'a'+      attr: oddtile+    description:+      - One+    properties: [known, portable]+  - name: b-tile+    display:+      char: 'b'+      attr: eventile+    description:+      - Two+    properties: [known, portable]+  - name: c-tile+    display:+      char: 'c'+      attr: oddtile+    description:+      - Three+    properties: [known, portable]+  - name: d-tile+    display:+      char: 'd'+      attr: eventile+    description:+      - Four+    properties: [known, portable]+  - name: e-tile+    display:+      char: 'e'+      attr: oddtile+    description:+      - Five+    properties: [known, portable]+  - name: f-tile+    display:+      char: 'f'+      attr: eventile+    description:+      - Six+    properties: [known, portable]+  - name: g-tile+    display:+      char: 'g'+      attr: oddtile+    description:+      - Seven+    properties: [known, portable]+  - name: h-tile+    display:+      char: 'h'+      attr: eventile+    description:+      - Eight+    properties: [known, portable]+  - name: i-tile+    display:+      char: 'i'+      attr: oddtile+    description:+      - Nine+    properties: [known, portable]+  - name: j-tile+    display:+      char: 'j'+      attr: eventile+    description:+      - Ten+    properties: [known, portable]+  - name: k-tile+    display:+      char: 'k'+      attr: oddtile+    description:+      - Eleven+    properties: [known, portable]+  - name: l-tile+    display:+      char: 'l'+      attr: eventile+    description:+      - Twelve+    properties: [known, portable]+  - name: m-tile+    display:+      char: 'm'+      attr: oddtile+    description:+      - Thirteen+    properties: [known, portable]+  - name: n-tile+    display:+      char: 'n'+      attr: eventile+    description:+      - Fourteen+    properties: [known, portable]+  - name: o-tile+    display:+      char: 'o'+      attr: oddtile+    description:+      - Fifteen+    properties: [known, portable]+  - name: p-tile+    display:+      char: 'p'+      attr: eventile+    description:+      - Sixteen+    properties: [known, portable]+  - name: q-tile+    display:+      char: 'q'+      attr: oddtile+    description:+      - Seventeen+    properties: [known, portable]+  - name: r-tile+    display:+      char: 'r'+      attr: eventile+    description:+      - Eighteen+    properties: [known, portable]+  - name: s-tile+    display:+      char: 's'+      attr: oddtile+    description:+      - Nineteen+    properties: [known, portable]+  - name: t-tile+    display:+      char: 't'+      attr: eventile+    description:+      - Twenty+    properties: [known, portable]+  - name: u-tile+    display:+      char: 'u'+      attr: oddtile+    description:+      - Twenty-one+    properties: [known, portable]+  - name: v-tile+    display:+      char: 'v'+      attr: eventile+    description:+      - Twenty-two+    properties: [known, portable]+  - name: w-tile+    display:+      char: 'w'+      attr: oddtile+    description:+      - Twenty-three+    properties: [known, portable]+  - name: x-tile+    display:+      char: 'x'+      attr: eventile+    description:+      - Twenty-four+    properties: [known, portable]+  - name: y-tile+    display:+      char: 'y'+      attr: oddtile+    description:+      - Twenty-five+    properties: [known, portable]+  - name: a-tile-ordinal+    display:+      char: 'a'+    description:+      - One+    properties: [known]+  - name: b-tile-ordinal+    display:+      char: 'b'+    description:+      - Two+    properties: [known]+  - name: c-tile-ordinal+    display:+      char: 'c'+    description:+      - Three+    properties: [known]+  - name: d-tile-ordinal+    display:+      char: 'd'+    description:+      - Four+    properties: [known]+  - name: e-tile-ordinal+    display:+      char: 'e'+    description:+      - Five+    properties: [known]+  - name: f-tile-ordinal+    display:+      char: 'f'+    description:+      - Six+    properties: [known]+  - name: g-tile-ordinal+    display:+      char: 'g'+    description:+      - Seven+    properties: [known]+  - name: h-tile-ordinal+    display:+      char: 'h'+    description:+      - Eight+    properties: [known]+  - name: i-tile-ordinal+    display:+      char: 'i'+    description:+      - Nine+    properties: [known]+  - name: j-tile-ordinal+    display:+      char: 'j'+    description:+      - Ten+    properties: [known]+  - name: k-tile-ordinal+    display:+      char: 'k'+    description:+      - Eleven+    properties: [known]+  - name: l-tile-ordinal+    display:+      char: 'l'+    description:+      - Twelve+    properties: [known]+  - name: m-tile-ordinal+    display:+      char: 'm'+    description:+      - Thirteen+    properties: [known]+  - name: n-tile-ordinal+    display:+      char: 'n'+    description:+      - Fourteen+    properties: [known]+  - name: o-tile-ordinal+    display:+      char: 'o'+    description:+      - Fifteen+    properties: [known]+  - name: p-tile-ordinal+    display:+      char: 'p'+    description:+      - Sixteen+    properties: [known]+  - name: q-tile-ordinal+    display:+      char: 'q'+    description:+      - Seventeen+    properties: [known]+  - name: r-tile-ordinal+    display:+      char: 'r'+    description:+      - Eighteen+    properties: [known]+  - name: s-tile-ordinal+    display:+      char: 's'+    description:+      - Nineteen+    properties: [known]+  - name: t-tile-ordinal+    display:+      char: 't'+    description:+      - Twenty+    properties: [known]+  - name: u-tile-ordinal+    display:+      char: 'u'+    description:+      - Twenty-one+    properties: [known]+  - name: v-tile-ordinal+    display:+      char: 'v'+    description:+      - Twenty-two+    properties: [known]+  - name: w-tile-ordinal+    display:+      char: 'w'+    description:+      - Twenty-three+    properties: [known]+  - name: x-tile-ordinal+    display:+      char: 'x'+    description:+      - Twenty-four+    properties: [known]+  - name: y-tile-ordinal+    display:+      char: 'y'+    description:+      - Twenty-five+    properties: [known]+recipes:+  - in:+      - [1, ink]+      - [1, a-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, b-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, c-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, d-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, e-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, f-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, g-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, h-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, i-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, j-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, k-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, l-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, m-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, n-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, o-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, p-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, q-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, r-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, s-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, t-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, u-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, v-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, w-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, x-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, ink]+      - [1, y-tile]+    out:+      - [1, sliding-tile]+    required:+      - [1, drill]+    time: 0+known: []+world:+  dsl: |+    {grass}+  upperleft: [-3, 2]+  offset: false+  palette:+    B: [grass, null, base]+    y: [grass, null, setup]+    z: [grass, null, maintainer]+    '.': [grass]+    'x': [grass]+  map: |+    ..................+    ..xxxxxx..........+    B.x....x..........+    ..x....x..........+    ..x....x..........+    ..x....x..........+    ..xxxxxx..........+    ..................+    zy................
+ data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw view
@@ -0,0 +1,215 @@+/**+The "maintainer" bot handles legal and illegal moves.+*/++def until = \p. \c. q <- p; if q {} {c; until p c} end;++/**+Sums of consecutive integers+*/+def computeTriangularNumber = \n.+    (n * (n + 1)) / 2+    end;++def mod : int -> int -> int = \i.\m.+    i - m * (i / m);+    end++def sumTuples = \t1. \t2.+    (fst t1 + fst t2, snd t1 + snd t2);+    end;++/** Teleports to a new location to execute a function+  then returns to the original location before+  returning the functions output value.+*/+def atLocation = \newLoc. \f.+    prevLoc <- whereami;+    teleport self newLoc;+    retval <- f;+    teleport self prevLoc;+    return retval;+    end;++def itemIsHere = \item.+    x <- scan down;+    case x (\_. return false) (\found. return $ found == item);+    end;++def getLetterEntityByIndex = \idx.+    let letter = toChar $ idx - 1 + charAt 0 "a" in+    letter ++ "-tile";+    end;++def teleportToDetectResult = \referenceLoc. \relativeLoc.+    let newLoc = sumTuples referenceLoc relativeLoc in+    teleport self newLoc;+    end;++def getOrdinal : text -> cmd int = \item.+    count $ item ++ "-ordinal";+    end;++def getValueHere =+    maybeItem <- scan down;+    ordNum <- case maybeItem (\_. return 0) getOrdinal;+    end;++def getIndexesTotal = \boardWidth. \boardHeight. \n.+    if (n > 0) {+        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 0;+    }+    end;++/**+If we iterate over all of the tiles, assigning each a contiguous index+starting with one, we can determine whether a single tile is missing+by subtrating the observed sum of indices from the expected sum.+*/+def findMissingIndex = \boardWidth. \boardHeight.+    let squareCount = boardWidth * boardHeight in+    let tileCount = squareCount - 1 in+    let indicesSum = computeTriangularNumber tileCount in+    mySum <- getIndexesTotal boardWidth boardHeight squareCount;+    return $ indicesSum - mySum;+    end;++def replenishInk =+    baseHasInk <- as base {has "ink"};+    if baseHasInk {} {+        create "ink";+        give base "ink";+    };+    end;++def replaceTileByIndex = \idx.+    let entName = getLetterEntityByIndex idx in+    create entName;+    _ <- swap entName;+    replenishInk;+    end;++def placeTileByIndex = \idx.+    let entName = getLetterEntityByIndex idx in+    create entName;+    place entName;+    end;++def handleLegalMove = \tileIdx.+    grab;+    move;+    placeTileByIndex tileIdx;+    replenishInk;+    end;++/**+Checks in the four directions.+*/+def hasAdjacentBlank = \tileIdx. \n.+    if (n > 0) {+        result <- scan forward;+        case result (\_. handleLegalMove tileIdx; return true;) (\_.+            turn left;+            hasAdjacentBlank tileIdx $ n - 1;+        );+    } {+        return false;+    }+    end;++/**+Check whether the mark is adjacent to a blank space+*/+def isLegalMark = \tileIdx.+    hasAdjacentBlank tileIdx 4;+    end;++/**+If the player has "drilled" a location that doesn't make+sense to move, find it and restore it to its original value.++Preconditions:+* We have already attempted to move a "sensibly"-marked tile.+* We are located at the bottom-left corner of the board.+*/+def handleMarker = \boardWidth. \boardHeight.+    detectReferenceLoc <- whereami;+    result <- detect "sliding-tile" ((0, 0), (boardWidth - 1, boardHeight - 1));+    case result return (\badLoc.+        teleportToDetectResult detectReferenceLoc badLoc;+        missingIdx <- atLocation (0, 0) $ findMissingIndex boardWidth boardHeight;+        markIsLegal <- isLegalMark missingIdx;+        if markIsLegal {} {+            if (missingIdx > 0) {+                replaceTileByIndex missingIdx;+                say "Illegal move";+            } {};+        }+    );+    end;++/**+  Recurses over all cells in all rows.+  Traverses within rows via physical `move`-ment.+  Wraps to the next row via teleport if a border is encountered.+  Terminates if still on a border immediately after wrapping.++  Precondition: Facing east at location (0, 0).+*/+def iterateAllTiles : cmd unit -> cmd unit = \func.+    let b = "border" in+    isOnBottomBorder <- itemIsHere b;+    if isOnBottomBorder {} {++        func;+        move;++        isOnRightBorder <- itemIsHere b;+        if isOnRightBorder {+            loc <- whereami;+            teleport self (0, snd loc - 1);+        } {};+        iterateAllTiles func;+    }+    end;++def watchBoard =+    turn east;+    atLocation (0, 0) $ iterateAllTiles $ (+        // Note: W actually don't need to watch the "empty" space+        watch down;+    );+    wait 1000;+    end;++def go = \boardWidth. \boardHeight.++    // Re-position at the bottom-left corner+    instant $ atLocation (0, -(boardHeight - 1)) (+        handleMarker boardWidth boardHeight;++        // NOTE: I originally intended to use 'watch' as a performance optimization.+        // Hoewver, Using 'watch' seems to incur some lag in the 'maintainer' bot's reaction+        // such that the player is not replentished with 'ink' by the time they might+        // want to perform their next 'drill' operation.+        // watchBoard;+    );++    // Throttle the recursion, otherwise it will max out the allowed operations per tick+    wait 1;++    go boardWidth boardHeight;+    end;++until (has "flower") $ wait 1;+go 3 3;
+ data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw view
@@ -0,0 +1,298 @@+/**+This robot is responsible for both the initial board setup.+*/++def id = \t. t end+def elif = \t. \then. \else. {if t then else} end+def else = id end++def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def mod : int -> int -> int = \i.\m.+  i - m * (i / m)+end++def isEven = \n.+    mod n 2 == 0;+    end++/** One-based index+*/+def getLetterEntityByIndex = \idx.+    let letter = toChar $ idx - 1 + charAt 0 "a" in+    letter ++ "-tile";+    end;++def getOrdinal : text -> cmd int = \item.+    count $ item ++ "-ordinal";+    end;++def getValueHere =+    maybeItem <- scan down;+    ordNum <- case maybeItem (\_. return 0) getOrdinal;+    end;++/**+  Swaps the element at the current position+  with the element "x" cells away.+  Useful for an in-place sort.++  Precondition: Facing east.+*/+def swapRelative = \x.+    if (x > 0) {+        currentItem <- grab;+        stride x;+        otherItem <- grab;+        place currentItem;+        turn back;+        stride x;+        place otherItem;+        turn back;+    } {};+    end;++/**+  Fisher-Yates shuffle on a physical array++  Precondition:+  * Array is oriented horizontally+  * Robot is placed at the head (left end) of the array+  * Robot is facing right++  "n" is the size of the array.+*/+def shuffle = \n. \i.+    if (i < n - 1) {+        let randAmplitude = n - i in+        x <- random randAmplitude;+        swapRelative x;+        move;+        shuffle n $ i + 1;+    } {};+    end;++// Inner loop in inversion-counting algorithm+def countInnerInversions = \n. \referenceVal. \j.++    if (j < n - 1) {+        move;+        valueHere <- getValueHere;+        let addend = if (referenceVal > valueHere) {1} {0} in+        recursiveSum <- countInnerInversions n referenceVal $ j + 1;+        let foo = recursiveSum in+        return $ addend + foo;+    } {+        return 0;+    };+    end++/**+  "n" represents array length.+  Runs in O(n^2) time.+*/+def countInversions = \n. \i.+    if (i < n - 1) {+        valueHere <- getValueHere;+        innerCount <- countInnerInversions n valueHere i;+        let innerCountFoo = innerCount in+        turn back;+        // Go backward one fewer space each time.+        stride $ n - i - 2;+        turn back;+        subarrayInversions <- countInversions n $ i + 1;+        let foo = subarrayInversions in+        return $ innerCountFoo + foo;+    } {+        return 0;+    };+    end++/**+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.+    maybeTileForward <- scan d;+    case maybeTileForward+        (\_. return $ inL false)+        (\x.+            if (x == "sliding-tile") {+                return $ inL true;+            } {+                y <- getOrdinal x;+                return $ if (y > 0) {+                    inR x;+                } {+                    inL false;+                };+            };+        );+    end++/**+  Precondition: The original item was a valid tile.+  Returns true if a drilling took place.+  Returns false if something unexpected happened+  and we should abort/reset.+*/+def actOnItemComparison = \maybeNewItem. \original.++    case maybeNewItem (\isSlidingTile.+        if isSlidingTile {+            create original;+            place original;+            move;+            grab;+            // Abort early from the recursion.+            return false;+        } {+            // The new tile is not a sliding tile.+            // We assume it's a blank tile and move there.+            // If it turns out not to be blank, that will+            // be addressed in the outer "observe" loop.+            move;+            return false;+        };+    ) (\newItem.+        let isSame = newItem == original in+        // We expect the tile to be unchanged, if it is not a sliding tile.+        if isSame {} {+            say $ "Original was " ++ original ++ "; newItem was " ++ newItem;+        };+        return isSame;+    );+    end;++def unwind = \keepChecking. \maybeItem.+    if keepChecking {++        turn right;++        // For now, we assume that there exist no "drilled" tiles+        // at the "wind-up"; the drilling shall always happen while+        // we are waiting at the peak of the recursion stack.+        maybeItem2 <- scanValid forward;++        keepGoing <- case maybeItem (+            \isSlidingTile. if isSlidingTile {+                // Our assumption was invalid; we don't have a+                // valid reference tile to compared the drilled tile to.+                say "Unexpected drilling; no reference tile.";+                return false;+            } {+                return true;+            }+        ) (actOnItemComparison maybeItem2);+        return keepGoing;+    } {+        return false;+    };+    end;++/**+If there is an odd number of inversions, simply+swap the first two tiles to obtain the correct+parity.+*/+def fixInversions = \arrayLoc. \arrayLength.+    teleport self arrayLoc;+    inversionCount <- countInversions arrayLength 0;+    if (isEven inversionCount) {} {+        teleport self arrayLoc;+        swapRelative 1;+    };+    end;++def layOrderedTiles = \n.+    if (n > 0) {+        let tileName = getLetterEntityByIndex n in+        create tileName;+        place tileName;+        move;+        layOrderedTiles $ n - 1;+    } {};+    end;++def prepareArray = \arrayLoc. \boardWidth. \boardHeight.+    +    turn east;+    teleport self arrayLoc;++    layOrderedTiles $ (boardWidth * boardHeight) - 1;++    teleport self arrayLoc;++    let cellCount = boardWidth * boardHeight in+    let arrayLength = cellCount - 1 in++    shuffle arrayLength 0;+    fixInversions arrayLoc arrayLength;+    end;++def relocateEnt = \from. \to.+    teleport self from;+    emptyHere <- isempty;+    if emptyHere {} {+        e <- grab;+        teleport self to;+        place e;+    };+    end;++def placeSingleRow = \sourceRow. \boardWidth. \rowIndex. \colIndex.+    if (colIndex >= 0) {+        relocateEnt (rowIndex*boardWidth + colIndex, sourceRow) (colIndex, -rowIndex);+        placeSingleRow sourceRow boardWidth rowIndex $ colIndex - 1;+    } {};+    end;++def placeRandomizedPuzzle = \arrayLoc. \boardWidth. \rowIndex.+    if (rowIndex >= 0) {+        placeSingleRow (snd arrayLoc) boardWidth rowIndex $ boardWidth - 1;+        placeRandomizedPuzzle arrayLoc boardWidth $ rowIndex - 1;+    } {};+    end;++def drawBorderLine = \boardSideLength.+    let b = "border" in+    doN (boardSideLength + 1) $ (+        create b;+        place b;+        move;+    );+    turn right;+    end;++def createBorder = \boardWidth. \boardHeight.+    teleport self (-1, 1);++    turn east;+    doN 2 (+        drawBorderLine boardWidth;+        drawBorderLine boardHeight;+    );+    end;++def setupGame = \boardWidth. \boardHeight.+    createBorder boardWidth boardHeight;+    let arrayLoc = (0, -6) in+    prepareArray arrayLoc boardWidth boardHeight;+    placeRandomizedPuzzle arrayLoc boardWidth $ boardHeight - 1;++    teleport self (6, -6);++    // Sentinel to indicate we are ready to start checking goal condition+    create "flower";++    // Sentinel that the maintainer can start checking+    create "flower";+    r <- robotnamed "maintainer";+    give r "flower";+    end;++def go = \boardWidth. \boardHeight.+    instant $ setupGame boardWidth boardHeight;+    end;++go 3 3;
+ data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw view
@@ -0,0 +1,420 @@+/**+Approach:+Place correct tiles in top row and left column,+then recurse into sub-rectangle.++NOTE: Much of this code is experimental and unused.+It may be revisited.++In particular, the Quad-tree search code should probably+be extracted into its own demo scenario.+*/++def elif = \t. \then. \else. {if t then else} end+def else = \t. t end++def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def signum = \x.+    if (x < 0) {-1}+    $ elif (x > 0) {1}+    $ else {0};+    end;++def mod : int -> int -> int = \i.\m.+    i - m * (i / m);+    end++def abs = \n. if (n < 0) {-n} {n} end;++def mapTuple = \f. \t.+    (f $ fst t, f $ snd t)+    end;++def sumTuples = \t1. \t2.+    (fst t1 + fst t2, snd t1 + snd t2);+    end;++def getOrdinal : text -> cmd int = \item.+    count $ item ++ "-ordinal";+    end;++/** One-based index+*/+def getLetterEntityByIndex = \idx.+    let letter = toChar $ idx - 1 + charAt 0 "a" in+    letter ++ "-tile";+    end;++def negateTuple = \t.+    mapTuple (\x. -x) t;+    end;++def subtractTuple = \t1. \t2.+    sumTuples t1 $ negateTuple t2;+    end;++def getRelativeLocation = \absLoc.+    myloc <- whereami;+    let negatedLoc = negateTuple myloc in+    return $ sumTuples negatedLoc absLoc;+    end;++def getRelativeRectangle : (int * int) * (int * int) -> cmd ((int * int) * (int * int)) = \corners.+    myloc <- whereami;+    let negatedLoc = negateTuple myloc in+    return $ mapTuple (sumTuples negatedLoc) corners;+    end;++/**+Generates rectangle corners+relative to the player's current location,+given corners specified as absolute GPS coords.+*/+def getBoardRectangle =+    getRelativeRectangle ((0, 0), (3, -3));+    end;++/** Gets relative location to letter by its ordinal */+def getLetterLocation = \idx.+    corners <- getBoardRectangle;+    let entName = getLetterEntityByIndex idx in+    loc <- detect entName corners;+    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;++/**+Index is 1-based.+Coordinates are relative to the upper-left+corner of the board (which happens to be at (0,0) world coords),+with down being the negative Y direction.+*/+def getAbsoluteTargetLocationForIndex = \boardWidth. \n.+    let idx = n - 1 in+    (idx/boardWidth, -(mod idx boardWidth));+    end;++/**+The first Boolean argument indicates whether+we should extract the vertical or horizontal dimension.+*/+def getRectDimension = \vertical. \rect.+    let extractor = if vertical {snd} {fst} in+    let tuple = mapTuple extractor rect in+    abs $ snd tuple - fst tuple;+    end;++def getOffsets = \rect.+    subtractTuple (snd rect) (fst rect);+    end;++def getAbsDelta = \rect.+    let difference = getOffsets rect in+    mapTuple abs difference;+    end;++def distance = \loc1. \loc2.+    let d = getAbsDelta (loc1, loc2) in+    fst d + snd d;+    end;++// NOT USED+def selectCloser = \refloc. \loc1. \loc2.+    let d1 = distance refloc loc1 in+    let d2 = distance refloc loc2 in+    if (d1 < d2) {loc1} {loc2}+    end;++/**+Get rectangle dimensions as a tuple.++Since the rectangle is specified by "inclusive" corners,+we add one to each dimension of the absolute difference+of corners to obtain the corrected area.+*/+def getDimensions = \rect.+    let absDifference = getAbsDelta rect in+    mapTuple (\x. x + 1) absDifference;+    end;++def getRectArea = \dims.+    fst dims * snd dims;+    end;++/**+Determines whether the vertical dimension is larger+than the horizontal dimension.+*/+def isVerticalLarger = \dims.+    snd dims > fst dims;+    end;++/**+Returns a tuple of the two rectangle partitions.++Precondition:+Rectangle corners are specified in the order:+  (top left, bottom right)++The "rightward/downward offset" (i.e. +1 horizontally, -1 vertically)+to the "avg" for the second rectangle depends on this assumption.+*/+def splitRectangle = \vertically. \rect.+    let cornerA = fst rect in+    let cornerB = snd rect in+    if vertically {+        // TODO: We should "round down" the height of the second partition+        // so that the first partition is more likely to contain+        // the target (i.e. we perform one fewer iteration).+        let avgY = (snd cornerA + snd cornerB) / 2 in+        let firstRect = (cornerA, (fst cornerB, avgY)) in+        let secondRect = ((fst cornerA, avgY - 1), cornerB) in+        (firstRect, secondRect)+    } {+        let avgX = (fst cornerA + fst cornerB) / 2 in+        let firstRect = (cornerA, (avgX, snd cornerB)) in+        let secondRect = ((avgX + 1, snd cornerA), cornerB) in+        (firstRect, secondRect)+    };+    end;++def blankCellLocatorCriteria = \rect.+    entCount <- density rect;+    let dims = getDimensions rect in+    let tileCount = getRectArea dims in+    return $ entCount < tileCount;+    end;++/**+Performs a quad-tree search for the blank square.++Partitioning can be either vertical or horizontal.+We always partition along the largest dimension.++The "first" partition in a vertical split is the "top" partition.+The "first" partition in a horizontal split is the "left" partition.+*/+def findEmptyCell = \foundCriteria. \rect.+    +    let dims = getDimensions rect in+    let tileCount = getRectArea dims in++    if (tileCount < 1) {+        return $ inL ();+    } $ elif (tileCount == 1) {+        foundHere <- foundCriteria rect;+        return $ if foundHere {+            inR $ fst rect;+        } {+            inL ();+        };+    } $ else {+        let isBiggerVertically = isVerticalLarger dims in+        let splitted = splitRectangle isBiggerVertically rect in+        let firstPartition = fst splitted in+        let secondPartition = snd splitted in++        foundInFirst <- foundCriteria firstPartition;+        let selectedPartition = if foundInFirst {firstPartition} {secondPartition} in+        findEmptyCell foundCriteria selectedPartition;+    };+    end;++/**+Out of two candidate locations, select the one+that is not co-linear with the blank tile location+and the letter location.++It is assumed that one of the candidates will meet+this criteria, so we only need check the first.+*/+def avoidCollinear = \blankloc. \tileloc. \loc1. \loc2.+    let firstOk = if (fst blankloc == fst tileloc) {+            fst loc1 != fst tileloc+        } $ elif (snd blankloc == snd tileloc) {+            snd loc1 != snd tileloc+        } $ else {true} in+    if firstOk {loc1} {loc2};+    end;++/**+Move the blank to the cell that allows+the selected letter to advance in the+direction of its target location.++We select a cell with either a vertical offset+or a horizontal offset from the letter tile.+The offset must be in the direction of the+letter's ultimate destination.+*/+def getInitialBlankDestination = \blankLoc. \letterloc. \targetloc.+    let getCoord = \f. signum (f targetloc - f letterloc) + f letterloc in+    avoidCollinear blankLoc letterloc (getCoord fst, snd letterloc) (fst letterloc, getCoord snd);+    end;++def moveSpaceToTile = \blankLoc. \targetRelativeLoc. \letterloc.+    +    log $ "first letter loc: " ++ format letterloc;++    // Note: this rectangle might not be "normalized" in terms+    // of corner ordering...+    let boundingPathRect = (letterloc, targetRelativeLoc) in+    log $ "Bounding rect: " ++ format boundingPathRect;++    let moveBlankTo = getInitialBlankDestination blankLoc letterloc targetRelativeLoc in+    log $ "Move blank to: " ++ format moveBlankTo;+    let incrementalBlankDest1 = getInitialBlankDestination letterloc blankLoc moveBlankTo in+    log $ "Incremental destination 1: " ++ format incrementalBlankDest1;++    moveTuple incrementalBlankDest1;+    end;++/**+Algorithm:+1. Bring the empty space into the rotational path of the letter.+2. Rotate the tile along the perimeter of the bounding rectangle.+*/+def placeTile = \boardWidth. \idx. \blankLoc.++    // TODO: Bring the empty space into the smallest+    // rectangle bounding both the letter and its+    // destination.++    log $ "empty space loc: " ++ format blankLoc;++    eitherLetterloc <- getLetterLocation idx;++    let targetLocAbsolute = getAbsoluteTargetLocationForIndex boardWidth idx in+    log $ "absolute target loc: " ++ format targetLocAbsolute;+    targetRelativeLoc <- getRelativeLocation targetLocAbsolute;++//    case eitherLetterloc return $ moveSpaceToTile blankLoc targetRelativeLoc;+    moveTuple blankLoc;+    end;++def moveManually =+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    turn left;+    drill forward;+    move;+    drill forward;+    move;+    turn left;+    drill forward;++    move;+    turn left;+    drill forward;+    move;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    turn right;+    drill forward;+    move;+    drill forward;+    move;+    turn right;+    drill forward;+    end;++def go = \boardWidth.+    corners <- getBoardRectangle;+    eitherBlankLoc <- findEmptyCell blankCellLocatorCriteria corners;++    case eitherBlankLoc return $ placeTile boardWidth 1;++    moveManually;+    end;++go 3;
+ data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw view
@@ -0,0 +1,72 @@+def id = \t. t end+def elif = \t. \then. \else. {if t then else} end+def else = id end++def itemIsHere = \item.+    x <- scan down;+    case x (\_. return false) (\found. return $ found == item);+    end;++def getOrdinal : text -> cmd int = \item.+    count $ item ++ "-ordinal";+    end;++/**+  Cells are allowed to be either empty or a valid game tile.+  Returns a Left if we are non-monotonic.+  Otherwise returns the next expected value.+*/+def isMonotonic : int -> cmd (unit + int) = \expectedVal.+    maybeItem <- scan down;+    case maybeItem+        (\_. return $ inR expectedVal) // Cell was blank+        (\entity.+            intVal <- getOrdinal entity;+            return $ if (intVal == expectedVal) {+                inR $ expectedVal + 1;+            } {+                inL ();+            };+        );+    end;++/**+  Recurses over all cells in all rows.+  Traverses within rows via physical `move`-ment.+  Wraps to the next row via teleport if a border is encountered.+  Terminates if still on a border immediately after wrapping.++  Precondition: Facing east at location (0, 0).+*/+def loopMonotonicityCheck : int -> cmd bool = \expectedVal.+    isOnBottomBorder <- itemIsHere "border";+    if isOnBottomBorder {+        return true;+    } {+        maybeNextVal <- isMonotonic expectedVal;+        case maybeNextVal+            (\_. return false)+            (\nextVal.+                move;+                isOnRightBorder <- itemIsHere "border";+                if isOnRightBorder {+                    loc <- whereami;+                    teleport self (0, snd loc - 1);+                } {};+                loopMonotonicityCheck nextVal;+            );+    }+    end;++def go =+    hasFlower <- has "flower";+    if hasFlower {+        turn east;+        teleport self (0, 0);+        loopMonotonicityCheck 1;+    } {+        return false;+    };+    end;++go;
+ data/scenarios/Challenges/Sokoban/00-ORDER.txt view
@@ -0,0 +1,3 @@+foresight.yaml+Simple+Gadgets
+ data/scenarios/Challenges/Sokoban/Gadgets/00-ORDER.txt view
@@ -0,0 +1,2 @@+no-reverse.yaml+one-way.yaml
+ data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml view
@@ -0,0 +1,83 @@+version: 1+name: No-reverse gadget+author: Karl Ostmo+description: |+  Once a robot passes from left to right, they cannot return they way they came.+creative: false+seed: 0+objectives:+  - goal:+      - Grab the flower.+    condition: |+      as base {+        has "flower";+      };+robots:+  - name: base+    dir: [0, -1]+    display:+      attr: gold+    devices:+      - branch predictor+      - ADT calculator+      - comparator+      - compass+      - dictionary+      - dozer blade+      - grabber+      - keyboard+      - lambda+      - logger+      - scanner+      - strange loop+      - treads+      - workbench+solution: |+  move;+  move;+  turn left;+  move;+  turn right;+  move;+  turn left;+  move;+  move;+  turn left;+  move;+  turn left;+  push;+  turn right;+  move;+  move;+  turn right;+  push;+  turn right;+  push;+  turn left;+  move;+  move;+  grab;+entities:+  - name: monolith+    display:+      char: '@'+    description:+    - Pushable rock+    properties: [known, unwalkable, portable]+known: [mountain, water, flower]+world:+  dsl: |+    {grass, water}+  upperleft: [-1, 1]+  offset: false+  palette:+    'B': [grass, erase, base]+    '.': [grass, erase]+    '@': [grass, monolith]+    'A': [grass, mountain]+    '*': [grass, flower]+  map: |+    BA.@.A+    .A.@.*+    ..@.AA+    A...AA
+ data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml view
@@ -0,0 +1,66 @@+version: 1+name: One-way gadget+author: Karl Ostmo+description: |+  Initially permits passage only from left to right.+creative: false+seed: 0+objectives:+  - goal:+      - Grab the flower.+    condition: |+      as base {+        has "flower";+      };+robots:+  - name: base+    dir: [1, 0]+    display:+      attr: gold+    devices:+      - branch predictor+      - ADT calculator+      - comparator+      - compass+      - dictionary+      - dozer blade+      - grabber+      - keyboard+      - lambda+      - logger+      - scanner+      - strange loop+      - treads+      - workbench+solution: |+  move;+  move;+  push;+  turn right;+  move;+  move;+  grab;+entities:+  - name: monolith+    display:+      char: '@'+    description:+    - Pushable rock+    properties: [known, unwalkable, portable]+known: [mountain, water, flower]+world:+  dsl: |+    {grass, water}+  upperleft: [-1, 1]+  offset: false+  palette:+    'B': [grass, erase, base]+    '.': [grass, erase]+    '@': [grass, monolith]+    'A': [grass, mountain]+    '*': [grass, flower]+  map: |+    AAAAAA+    B..@.A+    AAA.AA+    AAA*AA
+ data/scenarios/Challenges/Sokoban/Simple/00-ORDER.txt view
@@ -0,0 +1,1 @@+trapdoor.yaml
+ data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml view
@@ -0,0 +1,118 @@+version: 1+name: Trapdoor 1+author: Karl Ostmo+# NOTES: There is a way to push the blocks+# so that you cannot get back the way you+# came. This is the "trap door".+# But there is one other route that will allow+# you to go back.+description: |+  Bring the flower back.+creative: false+seed: 0+objectives:+  - goal:+      - Place the flower on the target.+      - You may have to start over if you get stuck.+    condition: |+      as base {+        teleport self (0,0);+        ishere "flower";+      };+robots:+  - name: base+    dir: [1, 0]+    display:+      attr: gold+    devices:+      - branch predictor+      - ADT calculator+      - comparator+      - compass+      - dictionary+      - dozer blade+      - grabber+      - keyboard+      - lambda+      - logger+      - scanner+      - strange loop+      - treads+      - workbench+solution: |+  def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+  move;+  turn right;+  move;+  turn left;++  doN 2 move;+  turn left;+  move;+  turn right;+  move;+  turn left;+  move;+  turn right;+  doN 2 move;+  turn right;+  push;+  turn back;+  move;+  turn left;+  doN 2 move;+  turn left;+  move;+  turn left;+  push;+  turn right;+  move;+  turn left;+  doN 3 push;+  turn left;+  doN 2 move;+  turn right;+  doN 2 move;+  f <- grab;+  turn back;++  doN 2 move;+  turn left;+  doN 2 move;+  turn right;+  doN 3 move;+  turn right;+  move;+  turn left;+  doN 2 move;+  turn left;+  move;+  turn right;+  doN 3 move;+  turn right;+  move;+  place f;+entities:+  - name: monolith+    display:+      char: '@'+    description:+    - Pushable rock+    properties: [known, unwalkable, portable]+known: [mountain, water, flower]+world:+  dsl: |+    {grass, water}+  upperleft: [-1, 1]+  offset: false+  palette:+    'B': [ice, erase, base]+    '.': [grass, erase]+    'x': [dirt, erase]+    '@': [grass, monolith]+    'A': [grass, mountain]+    '*': [grass, flower]+  map: |+    xxxAA...A..*+    xBxA..@@A...+    xxx..A.....A
+ data/scenarios/Challenges/Sokoban/_foresight/solution.sw view
@@ -0,0 +1,198 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def moveUntilBlocked =+    isBlocked <- blocked;+    if isBlocked {} {+        move;+        moveUntilBlocked;+    }+    end;++def pushUntilBarrier =+    try {+        push;+        pushUntilBarrier;+    } {}+    end;++def goAroundCell =+    turn right;+    move;+    turn left;+    doN 2 move;+    turn left;+    end;++def repositionFromMiddle =+    turn right;+    move;+    turn left;+    move;+    turn right;+    moveUntilBlocked;+    end;++def childShared =+    goAroundCell;+    moveUntilBlocked;+    end;++def childSharedPrep =+    move;+    turn back;+    watch forward;+    wait 200;+    end;++def childSharedWait =+    childSharedPrep;+    pushUntilBarrier;+    end;++def firstChild =+    childShared;+    turn right;+    childSharedWait;++    doN 4 (turn left; moveUntilBlocked);+    repositionFromMiddle;+    turn left;+    childSharedWait;+    end;++def secondChild =+    childShared;++    doN 1 (turn left; moveUntilBlocked);+    +    turn right;+    childSharedWait;+    doN 3 (turn left; moveUntilBlocked);++    repositionFromMiddle;+    doN 1 (turn right; moveUntilBlocked);+    turn left;+    childSharedWait;+    end;++def thirdChild =+    childShared;+    +    doN 2 (turn left; moveUntilBlocked);+    turn right;+    childSharedWait;+    doN 2 (turn left; moveUntilBlocked);+    +    repositionFromMiddle;+    doN 2 (turn right; moveUntilBlocked);+    turn left;+    childSharedWait;+    end;++def fourthChild =+    childShared;+    doN 3 (turn left; moveUntilBlocked);+    turn right;+    childSharedWait;+    doN 1 (turn left; moveUntilBlocked);++    repositionFromMiddle;+    doN 3 (turn right; moveUntilBlocked);+    turn left;+    childSharedWait;+    end;++def fifthChild =+    childShared;+    doN 4 (turn left; moveUntilBlocked);+    turn right;+    childSharedPrep;+    doN 2 push;++    repositionFromMiddle;+    doN 4 (turn right; moveUntilBlocked);+    turn left;+    childSharedWait;++    turn right;+    move;+    turn left;+    move;+    turn left;+    doN 3 push;+    end;++def firstLeg =+    build {fifthChild};+    build {fourthChild};+    build {thirdChild};+    build {secondChild};+    build {firstChild};+    wait 10;+    +    push;+    turn right;+    move;+    turn left;+    move;+    turn left;+    pushUntilBarrier;++    wait 4;+    move;+    doN 5 (turn left; moveUntilBlocked);++    turn right;+    move;+    turn left;+    doN 2 move;+    turn left;+    doN 2 move;+    turn left;+    move;+    turn left;+    doN 3 push;+    end;++def getToCaveEntrance =+    moveUntilBlocked;+    turn right;+    move;+    turn left;+    move;+    turn right;+    move;+    turn left;+    doN 2 move;+    turn left;+    move;+    turn left;+    push;+    turn right;+    doN 2 move;+    turn right;+    push;+    turn right;+    push;+    turn left;+    doN 3 move;+    turn left;+    doN 3 move;++    x <- grab;+    equip x;+    doN 18 move;+    turn left;+    doN 5 move;+    turn left;+    move;+    turn right;+    doN 10 push;+    end;++def go =+    getToCaveEntrance;+    firstLeg;+    end;++go;
+ data/scenarios/Challenges/Sokoban/foresight.yaml view
@@ -0,0 +1,134 @@+version: 1+name: Foresight+author: Karl Ostmo+description: |+  Have assistants take their marks to execute the heist.+creative: false+seed: 0+attrs:+  - name: barrier+    fg: "#222222"+    bg: "#111111"+  - name: bluish+    fg: "#bbbbff"+objectives:+  - goal:+      - Push a monolith onto the base's initial location.+    condition: |+      as base {+        teleport self (0,0);+        ishere "monolith";+      };+  - teaser: Pick flower+    hidden: true+    optional: true+    goal:+      - Grab the flower+    condition: |+      as base {+        has "flower";+      };+robots:+  - name: base+    display:+      attr: bluish+    dir: [0, 1]+    devices:+      - branch predictor+      - ADT calculator+      - comparator+      - compass+      - dictionary+      - dozer blade+      - grabber+      - hourglass+      - keyboard+      - lambda+      - logger+      - net+      - scanner+      - strange loop+      - treads+      - welder+    inventory:+      - [5, dozer blade]+      - [5, ADT calculator]+      - [5, branch predictor]+      - [5, hourglass]+      - [5, comparator]+      - [5, counter]+      - [5, dictionary]+      - [5, grabber]+      - [5, lambda]+      - [5, lodestone]+      - [5, logger]+      - [5, net]+      - [5, rolex]+      - [5, scanner]+      - [5, solar panel]+      - [5, string]+      - [5, strange loop]+      - [5, treads]+solution: |+   run "scenarios/Challenges/Sokoban/_foresight/solution.sw"+entities:+  - name: monolith+    display:+      char: '@'+      attr: gold+    description:+    - Pushable rock+    properties: [known, unwalkable, portable]+  - name: crate+    display:+      attr: wood+      char: '▪'+    description:+    - Pushable crate+    properties: [known, portable, unwalkable]+  - name: wall+    display:+      attr: barrier+      char: '#'+    description:+    - Unmovable barrier+    properties: [known, unwalkable]+known: [mountain, water, 3D printer, flower]+world:+  dsl: |+    {grass, water}+  upperleft: [-21, 10]+  offset: false+  palette:+    'B': [ice, erase, base]+    '.': [grass, erase]+    '*': [grass, flower]+    'b': [grass, boat]+    '3': [grass, 3D printer]+    '@': [grass, monolith]+    'c': [grass, crate]+    'A': [grass, wall]+    'w': [dirt, water]+    'x': [stone, erase]+    'z': [dirt, erase]+  map: |+    ..................3...A.+    .................AAAA.A*+    .AAAAAAAAAAAAAAAAA.A..AA+    .A.................Acc..+    .AA.AAAAAAAAAAAAAA.A..c.+    ..A.AA.AAAAAAAAAAA.AAA..+    .@A.AA...........A.....A+    ..A.AA.AAAAAAAA.AA....AA+    ..A.AA.AzzzA.AA.A.......+    ..A.AA.Azzz..AA.A...xxx.+    ..A.AA.AA..A.AA.A...xBx.+    ..A.A.....AA.AA.AAA.xxx.+    ..A.AAAAA.AA.AA.A.......+    ..A.AAAAAAAA.AA.A.......+    ..A...........A.A.......+    ..A.AAAAAAAAAAA.A.......+    ..AAAAAAAAAAAAA.A.......+    ................A.......+    .AAAAAAAAAAAAAA.A.......+    .............bAAA.......
+ data/scenarios/Challenges/_arbitrage/solution.sw view
@@ -0,0 +1,48 @@+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;++/**+False = Left+*/+def boolAsLeftRight = \b.+    if b {right} {left}+    end;++def squareSide =+    drill down;+    doN 5 move;+    end;++def goToFirstShop =+    doN 3 move;+    doN 5 (doN 2 move; grab);+    turn left;+    doN 2 move;+    end;++def doPartialFigureEight =+    intersperse 2 (turn left) squareSide;+    intersperse 4 (turn right) squareSide;+    end;++def doFullFigureEight = \startLeft.+    intersperse 4 (turn $ boolAsLeftRight $ not startLeft) squareSide;+    intersperse 4 (turn $ boolAsLeftRight startLeft) squareSide;+    end;++goToFirstShop;++doN 1 doPartialFigureEight;+doN 9 $ doFullFigureEight true;++doN 8 $ doFullFigureEight false;+squareSide;+drill down;
+ data/scenarios/Challenges/_blender/apprehension-checker.sw view
@@ -0,0 +1,37 @@+def hasMetBase = \r.+    let basename = "base" in+    x <- as r {whoami};+    if (x == basename) {+        return false;+    } {+        mr0 <- as r {meet};+        case mr0+          (\_. return false)+          (\bot. name <- as bot {whoami}; return $ name == basename);+    };+    end;++/**+Iterates sequentially until+encountering an invalid robot index.++Distinguishes system bots from the base by name.+Returns true if a bot has "met" the base.+*/+def anyHasMetBase : int -> cmd bool = \idx.+    +    try {+        bot <- robotnumbered idx;+        intermediate <- hasMetBase bot;+        let foo = intermediate in+        let newIdx = idx + 1 in+        recursiveResult <- anyHasMetBase newIdx;+        return $ foo || recursiveResult;+    } {+      // Terminates the recursion on the+      // lowest index at which a robot does not exist+      return false;+    };+    end;++anyHasMetBase 1;
+ data/scenarios/Challenges/_blender/patrol-clockwise.sw view
@@ -0,0 +1,20 @@+def forever = \c.+    c;+    forever c;+    end;++def encircle = \lDir. \rDir.+    turn lDir;+    b <- blocked;+    if b {+        turn rDir;+    } {+        wait 1;+    };+    fwBlocked <- blocked;+    if fwBlocked {turn rDir} {move};+    end;++def patrolCW = forever (encircle right left); end;++patrolCW;
+ data/scenarios/Challenges/_blender/patrol-counter-clockwise.sw view
@@ -0,0 +1,20 @@+def forever = \c.+    c;+    forever c;+    end;++def encircle = \lDir. \rDir.+    turn lDir;+    b <- blocked;+    if b {+        turn rDir;+    } {+        wait 1;+    };+    fwBlocked <- blocked;+    if fwBlocked {turn rDir} {move};+    end;++def patrolCCW = forever (encircle left right); end;++patrolCCW;
+ data/scenarios/Challenges/_blender/solution.sw view
@@ -0,0 +1,64 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def slowM = move; wait 2; end;++def navigatePath =+    doN 9 move;+    turn left;+    wait 13; // Get this timing right+    doN 12 slowM;+    turn right;+    doN 8 move;+    turn right;++    wait 0; // Get this timing right+    doN 12 slowM;+    turn left;+    doN 8 move;++    turn left;+    wait 0; // Get this timing right+    doN 12 slowM;+    turn left;+    move;++    k <- grab;+    equip k;++    doN 5 move;+    drill forward;++    doN 2 move;+    turn left;++    wait 0; // Get this timing right+    doN 4 move;+    turn right;+    drill forward;+    doN 2 move;++    // Close the door behind us!+    drill back;++    doN 4 move;+    turn left;+    doN 4 move;+    turn right;+    +    wait 4; // Get this timing right+    drill forward;+    doN 2 move;+    turn left;+    doN 4 move;+    turn right;+    doN 10 move;+    turn right;+    doN 12 move;+    turn right;+    move;+    drill forward;+    doN 7 move;+    grab;+    end;++navigatePath;
+ data/scenarios/Challenges/_bridge-building/flower-ring-check.sw view
@@ -0,0 +1,62 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+++def isItemInDirection = \direction. \item. +    x <- scan direction;+    return $ case x (\_. false) (\y. y == item);+    end;++def isFlankedByItem = \item.+    hasLeft <- isItemInDirection left item;+    hasRight <- isItemInDirection right item;+    return $ hasLeft && hasRight;+    end;++def flowersInCardinalDirections = \item. \n.+    if (n > 0) {+        x <- isItemInDirection forward item;+        if x {+            turn left;+            flowersInCardinalDirections item $ n - 1;+        } {+            return false;+        };+    } {+        return true;+    }+    end;++def flowersAround = \item.+    hasCardinals <- flowersInCardinalDirections item 4;+    if hasCardinals {+        move;+        isFlanked1 <- isFlankedByItem item;+        turn back;+        move;+        if isFlanked1 {+            move;+            isFlanked2 <- isFlankedByItem item;+            turn back;+            move;+            return isFlanked2;+        } {+            return false;+        }+    } {+        return false;+    }+    end;++// loop until condition is met+def waitUntilSurrounded =+    isSurrounded <- flowersAround "flower";+    if isSurrounded {} {+        wait 2;+        waitUntilSurrounded;+    }+    end;++waitUntilSurrounded;++_t <- swap "painted plate";+selfdestruct;
+ data/scenarios/Challenges/_bridge-building/solution.sw view
@@ -0,0 +1,496 @@+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;++// Grab the empty water tank and crucible+move;++// get the map+grab;+++// get the peat+doN 8 move;+doN 10 (move; drill forward);+turn right;+doN 2 move;+turn right;+doN 21 move;+turn right;+doN 2 move;++// get the water tank+grab;++// get the clay+turn left;+doN 3 move;++intersperse 8 move grab;+make "crucible";+turn right;++doN 14 move;+turn right;+doN 4 move;+turn left;++// Start working on the lava+move;+drill forward;+turn back;+doN 2 move;+turn left;+doN 30 move;+drill forward;+turn back;+doN 30 move;+turn right;+doN 2 move;+drill forward;+turn right;+move;+turn left;+drill forward;++turn back;+doN 2 move;+turn left;+doN 30 move;+drill forward;+turn back;+doN 31 move;+turn right;+doN 3 move;+drill forward;++drill right;+turn back;+doN 3 move;+turn left;+doN 32 move;+drill forward;+turn back;+doN 32 move;+turn right;+doN 4 move;+drill forward;++drill right;+turn back;+doN 4 move;+turn left;+doN 33 move;+drill forward;+turn back;+doN 33 move;+turn right;+doN 5 move;++// Since there are two recipes that take in lava+// one will (according to the seed) fill the crucible,+// and the next will tranform into obsidian.+drill forward;+drill forward;+turn back;+doN 5 move;+turn left;+doN 34 move;++def meltRoundTrip = \hDist.++    drill forward;+    // dump out the pail+    make "empty water tank";+    turn back;+    doN hDist move;+    turn right;+    doN 2 move;+    drill forward;+    turn back;+    doN 2 move;+    turn left;+    doN (hDist + 1) move;+    end;+++meltRoundTrip 28;+meltRoundTrip 29;+meltRoundTrip 30;+meltRoundTrip 31;+meltRoundTrip 32;+meltRoundTrip 33;+++drill forward;+// dump out the pail+make "empty water tank";++doN 7 move;+turn left;+doN 5 move;+turn left;+doN 8 move;+turn right;+doN 6 move;+// Get 3 iron ores+doN 3 (drill forward);+// Make 6 iron plates+doN 3 (make "iron plate");++turn back;+doN 6 move;+turn left;+doN 8 move;+turn right;+doN 5 move;+turn right;+doN 43 move;+++// Harvest hemp for rope++def uTurn = \d.+    turn d;+    move;+    turn d;+    end;++def harvestHempField =+    turn left;+    intersperse 5 move harvest;+    uTurn right;+    intersperse 5 move harvest;+    uTurn left;+    intersperse 5 move harvest;+    uTurn right;+    intersperse 5 move harvest;+    uTurn left;+    intersperse 5 move harvest;+    uTurn right;+    intersperse 5 move harvest;+    uTurn left;+    intersperse 5 move harvest;+    uTurn right;+    intersperse 5 move harvest;+    uTurn left;+    intersperse 5 move harvest;+    end;++def repositionToHempCorner =+    turn left;+    doN 8 move;+    turn left;+    doN 4 move;+    turn left;+    end;++// Default growth stage time is 100-200. There are two growth stages.+intersperse 3 (repositionToHempCorner; wait 400) harvestHempField;+doN 2 (make "rope");+make "rubble skip";++// Go to the quarry+turn left;+doN 4 move;+turn right;+doN 3 move;+drill forward;++def causewayTrek = \dist.+    turn back;+    doN dist move;+    drill forward;+    turn back;+    doN dist move;+    drill forward;+    end;++causewayTrek 18;+causewayTrek 19;+causewayTrek 20;+causewayTrek 21;++def secondCauseway = \dist.+    turn back;+    doN 24 move;+    turn right;+    doN dist move;+    drill forward;+    turn back;+    doN dist move;+    turn left;+    doN 24 move;+    drill forward;+    end;++secondCauseway 4;+secondCauseway 5;+secondCauseway 6;+secondCauseway 7;+++def thirdCausewayHalf = \dist.+    turn back;+    doN 24 move;+    turn right;+    doN 11 move;+    turn left;+    move;+    turn right;+    doN dist move;+    drill forward;+    end;++def thirdCauseway = \dist.+    thirdCausewayHalf dist;+    turn back;+    doN dist move;+    turn left;+    move;+    turn right;+    doN 11 move;+    turn left;+    doN 24 move;+    drill forward;+    end;+++thirdCauseway 1;+thirdCauseway 2;+thirdCauseway 3;+thirdCauseway 4;+thirdCauseway 5;++thirdCausewayHalf 6;++// Navigate through the mountain peaks+doN 5 move;+turn left;+doN 2 move;+turn right;+doN 4 move;+turn right;+move;++// Make the rope+make "rope";+// Install the rope+drill forward;+// Abseil down the cliff+doN 2 move;++turn left;+doN 7 move;+turn left;+move;+turn right;+move;+turn left;+move;+turn right;+doN 5 move;+turn right;+doN 2 move;++// Make the rope+make "rope";+// Install the rope+drill forward;+// Abseil down the cliff+doN 2 move;+turn left;+doN 4 move;+turn right;+move;+// Get the machete+grab;++turn back;+move;+turn left;+doN 4 move;+turn right;+doN 4 move;+turn left;+doN 5 move;+turn left;+move;+turn right;+move;+turn left;+move;+turn right;+doN 7 move;+turn right;+doN 3 move;+turn left;+doN 5 move;+turn left;+doN 2 move;+turn right;+doN 9 move;+turn left;+move;+turn right;+doN 10 move;++// harvest the palm tree+turn right;+move;+p <- harvest;+turn back;+move;+turn right;+doN 2 move;++turn left;+doN 17 move;+turn left;++def sowSeed = \p.+   place p;+   _p <- harvest;+   move;+   end;+// Harvest palm trees,+// traverse bog,+// grab flower.++def sowAndHarvestRow = \item. \length. \waitTime.++    doN length $ sowSeed item;+    turn back;+    doN length move;+    turn back;+    wait waitTime;+    doN length (grab; move;);+    end;+++doN 9 move;++sowAndHarvestRow p 5 400;++// Head toward the bog+doN 16 move;+turn right;+doN 3 move;++// Make coconuts and flimsy boards+doN 6 (make "coconut"; make "flimsy board");++doN 2 (drill forward; move;);+turn left;+doN 4 (drill forward; move;);+move;++def navigateToFlower =+    turn right;+    doN 2 move;+    turn left;+    doN 4 move;+    turn right;+    move;+    turn left;+    doN 2 move;+    turn left;+    doN 2 move;+    turn right;+    doN 2 move;+    turn right;+    doN 2 move;+    turn left;+    doN 3 move;+    turn right;+    move;+    turn left;+    doN 2 move;+    turn left;+    move;+    grab;+    end;++flower <- navigateToFlower;++def exitBog =+    turn back;+    move;+    turn right;+    doN 2 move;+    turn right;+    move;+    turn left;+    doN 3 move;+    turn right;+    doN 2 move;+    turn left;+    doN 2 move;+    turn left;+    doN 2 move;+    turn right;+    doN 2 move;+    turn right;+    doN 2 move;+    turn left;+    doN 4 move;+    turn right;+    move;+    turn left;+    doN 5 move;+    turn right;+    doN 3 move;+    end;++exitBog;++turn left;++// Flower growth stage is 50 (two stages)+sowAndHarvestRow flower 7 100;++doN 23 move;+turn right;+doN 13 move;+turn right;++// Head toward the jungle+doN 16 move;+doN 8 (drill forward; move);++doN 2 move;+turn left;+scan forward;+turn right;+move;+turn left;++// Plant flower ring+intersperse 4 (turn left) (doN 2 (place flower; move));+turn back;+move;+turn right;+move;+wait 20;+plate <- grab;++turn back;+move;+turn right;+doN 26 move;+turn left;+doN 17 move;+turn left;+doN 11 move;+turn right;+doN 7 move;+turn right;+doN 2 move;+place plate;
+ data/scenarios/Challenges/_gopher/gopher.sw view
@@ -0,0 +1,131 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; 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 randSign = \x.+    opposite <- random 2;+    if (opposite == 1) {+        return (-x);+    } {+        return x;+    }+    end;++def goDir = \dist. \d1. \d2.+    if (dist < 0) {+        turn d1;+    } $ elif (dist > 0) {+        turn d2;+    } {};++    doN (abs dist) move;+    end;++def randSwap = \f. \g.+    r <- random 2;+    if (r == 0) {+        f; g;+    } {+        g; f;+    };+    end;++def converge = \dest. \currentLoc.+    let xDist = fst currentLoc - fst dest in+    let yDist = snd currentLoc - snd dest in+    randSwap (goDir xDist east west) (goDir yDist north south);+    end;++def navigateTo = \destTuple.+    loc <- whereami;+    converge destTuple loc;+    end;++def arrive = \fieldWidth. \fieldHeight.+    newDestinationX <- random fieldWidth;+    newDestinationYtemp <- random fieldHeight;+    let newDestinationY = -newDestinationYtemp in+    navigateTo (newDestinationX, newDestinationY);+    turn down;+    end;++def getTauntStage = \startingAmount. \newCount.+    if ((newCount * 5) / startingAmount < 1) {+        (0, "Hey, maybe we can work this out?")+    } $ elif ((newCount * 5) / startingAmount < 2) {+        (1, "I didn't hear no bell!")+    } $ elif ((newCount * 5) / startingAmount < 3) {+        (2, "Why don't you just give up?")+    } $ elif ((newCount * 5) / startingAmount < 4) {+        (3, "Close one!")+    } $ elif (newCount < startingAmount - 2) {+        (4, "OK, no more Mr. Nice Gopher!")+    } $ elif (newCount < startingAmount - 1) {+        (5, "Bet you can't do that again!")+    } $ elif (newCount < startingAmount) {+        (6, "Beginner's luck!")+    } $ else {(7, "You'll never catch me!")};+    end;++def waitWhileHere = \e. \remainingTime.+    here <- isHere e;+    if here {+        wait 1;+        if (remainingTime > 0) {+            waitWhileHere e $ remainingTime - 1;+        } {+            // Pick up the "dropping"+            try {+                // Note: There exists a race condition;+                // if the user happens to drill the mound+                // *after* the gopher checks it with `ishere`+                // but *before* it executes `grab`, the gopher will crash.+                // Thus we have wrapped this `grab` in a `try`.+                grab;+                return ();+            } {};+        };+    } {};+    end;++def go = \width. \height. \lastTauntIndex. \startingAmount. \dropping.+    newCount <- count dropping;+    if (newCount > 0) {+        let tauntStage = getTauntStage startingAmount newCount in+        let tauntIndex = fst tauntStage in+        if (tauntIndex != lastTauntIndex) {+            say $ snd tauntStage;+        } {};++        appear "o";+        arrive width height;++        place dropping;+        appear "G";+        waitWhileHere dropping 150;+        go width height tauntIndex startingAmount dropping;+    } {+        say "Argh! I give up.";++        // Allow the player to salvage their robots+        let reward = "toolkit" in+        try {+            place reward;+        } {+            swap reward;+            return ();+        };++        baseloc <- as base {whereami};+        teleport self baseloc;+        give base "serenity";++        selfdestruct;+    };+    end;++let dropping = "mound" in+startingAmount <- count dropping;+go 28 18 (-1) startingAmount dropping;
+ data/scenarios/Challenges/_gopher/solution.sw view
@@ -0,0 +1,170 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+def elif = \t. \then. \else. {if t then else} end+def else = \t. t end++def makeSigned = \b. \x.+    if b {-x} {x};+    end;++def getDirection = \n.+    if (n == 0) {+        forward;+    } $ elif (n == 1) {+        right;+    } $ elif (n == 2) {+        back;+    } $ elif (n == 3) {+        left;+    } $ else {+        down;+    };+    end;++def watchDir = \n.+    watch $ getDirection n;+    if (n > 0) {+        watchDir $ n - 1;+    } {};+    end;++/**+Loops forever+*/+def scanDirections = \n.+    let d = getDirection n in+    out <- scan d;+    shouldContinue <- case out+        (\_. return true)+        (\x. if (x == "mound") {+            drill d;+            return true;+        } {+            // A "flower" shall serve as+            // a semaphore to terminate the loop,+            // so that the base can `salvage` us.+            return $ x != "flower";+        });++    if shouldContinue {+        if (n > 0) {+            scanDirections $ n - 1;+        } {+            watchDir 4;+            wait 1000;+            scanDirections 4;+        };+    } {};+    end;++def deploySensor =+    _s <- build {scanDirections 0};+    return ();+    end;++def isDivisibleBy = \dividend. \divisor.+    (dividend / divisor) * divisor == dividend;+    end;++// stagger at every fifth cell+def deployRow = \f. \offset. \cellCount.+    if (isDivisibleBy (cellCount + offset) 5) {+        f;+    } {};+    if (cellCount > 1) {+        move;+        deployRow f offset $ cellCount - 1;+    } {};+    end;++def isEven = \x.+   isDivisibleBy x 2+   end;++def deployGrid = \f. \width. \height.++    if (height > 0) {++        let nowEven = isEven height in+        let offsetVal = makeSigned nowEven $ height * 2 in+        let extraOffset = if nowEven {-1} {0} in+        deployRow f (offsetVal + extraOffset) width;++        let d = if nowEven {right} {left} in+        turn d;+        move;+        turn d;+        deployGrid f width $ height - 1;+    } {};+    end;++def pickupToolkit =+    x <- scan down;+    case x+        (\_. return false)+        (\y. if (y == "toolkit") {+            tk <- grab;+            equip tk;+            return true+        } {+            return false+        });+    end;++def searchToolkitSingleRow = \colCount.++    _found <- pickupToolkit;+    if (colCount > 1) {+        move;+        searchToolkitSingleRow $ colCount - 1;+    } {};+    end;    ++def searchToolkitRows = \width. \rowCount.+    searchToolkitSingleRow width;+    if (rowCount > 1) {++        let nowEven = isEven rowCount in+        let d = if nowEven {right} {left} in++        turn d;+        move;+        turn d;++        searchToolkitRows width $ rowCount - 1;+    } {};+    end;++def listenForDefeat =+    // Block until the gopher is defeated+    m <- has "serenity";+    if m {} {+        listenForDefeat;+    };+    end;++def searchForToolkit = \width. \height.+    searchToolkitRows width height;++    turn right;+    doN (height - 1) move;+    turn right;+    doN (width - 1) move;+    turn right;+    end;++def go = \width. \height.+    deployGrid deploySensor width height;+    turn left;+    move;++    listenForDefeat;+    searchForToolkit height width;++    deployGrid (place "flower") width height;+    turn left;+    doN height move;+    turn right;+    deployGrid salvage width height;+    end;++go 30 20;
+ data/scenarios/Challenges/_hackman/fruit_maker.sw view
@@ -0,0 +1,10 @@+def go =+    pelletCount <- as base {count "pellet"};+    if (pelletCount > 90) {+        teleport self (0, -2);+        place "strawberry";+    } {go};+    end;++go;+selfdestruct;
+ data/scenarios/Challenges/_hackman/ghost.sw view
@@ -0,0 +1,156 @@+/* Algorithm:+Go forward until along any straight passage until reaching+an intersection. Then randomly choose any available direction+(except backwards).+*/++def isItemInDirection = \direction. \item.+    x <- scan direction;+    return $ case x (\_. false) (\y. y == item);+    end;++// A ghost is not blocked by a "gate" when it is leaving the "nursery".+def canCrossGate =+    isGate <- isItemInDirection forward "gate";+    loc <- whereami;+    let amCentered = loc == (0, 0) in+    return $ isGate && amCentered;+    end;++def isBlockedAhead =+    isBlockedByWall <- blocked;+    ghostCanCrossGate <- canCrossGate;+    return $ isBlockedByWall && not ghostCanCrossGate;+    end;++def checkLeftBlocked =+    turn left;+    isBlocked <- isBlockedAhead;+    turn right;+    return isBlocked;+    end;++def checkRightBlocked =+    turn right;+    isBlocked <- isBlockedAhead;+    turn left;+    return isBlocked;+    end;++def chooseDirection : cmd dir =+    leftBlocked <- checkLeftBlocked;+    rightBlocked <- checkRightBlocked;+    forwardBlocked <- isBlockedAhead;+    if (leftBlocked && rightBlocked && forwardBlocked) {+        say "Dead end; turning back";+        return back;+    } {+        // Since we're in the "else" case of all three+        // being blocked, we know that at least one+        // direction is available. So we check all+        // the combinations.+        if (leftBlocked && rightBlocked) {+            // Keep going straight+            return forward;+        } {+            if (leftBlocked && forwardBlocked) {+                return right;+            } {+                if (rightBlocked && forwardBlocked) {+                    return left;+                } {+                    // Now we have exhaused all of the combinations+                    // of *two* directions being blocked, so we+                    // check single directions.++                    if leftBlocked {+                        // Decide whether to go right or straight+                        d <- random 2;+                        if (d == 0) {+                            return right;+                        } {+                            // go straight+                            return forward;+                        }+                    } {+                        if rightBlocked {+                            // Decide whether to go left or straight+                            d <- random 2;+                            if (d == 0) {+                                return left;+                            } {+                                // go straight+                                return forward;+                            }+                        } {+                            if forwardBlocked {+                                // Decide whether to go left or right+                                d <- random 2;+                                if (d == 0) {+                                    return left;+                                } {+                                    // go right+                                    return right;+                                }+                            } {+                                // No directions are blocked, so we can+                                // go left, right, or straight with+                                // equal probability.++                                d <- random 3;+                                if (d == 0) {+                                    return left;+                                } {+                                    if (d == 1) {+                                        return right;+                                    } {+                                        // go straight+                                        return forward;+                                    }+                                }+                            }+                        }+                    }+                }+            }+        }+    }+    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 =+    hasGift <- has "donut";+    if hasGift {+        teleport self startPos;+    } {+        move;+        checkNeedsTeleport 11;+        newDirection <- chooseDirection;+        turn newDirection;+        go;+    }+    end;++def waitToStart =+    offset <- random 300;+    let startDelay = 50 + offset in+    wait startDelay;+    teleport self (0, 0);+    go;+    end;++waitToStart;
+ data/scenarios/Challenges/_hackman/solution.sw view
@@ -0,0 +1,143 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def tryGrab =+    try {+        grab;+        return ();+    } {};+    end;++def tryGive = \thing.+    hasPowerup <- has thing;+    if hasPowerup {+        r <- meet;+        case r+            (\_. return ())+            (\r. give r thing; wait 10);+    } {};+    end;++def turnAndEat = \d. \c.+    turn d;+    doN c (move; tryGrab; tryGive "donut");+    end;++def eatAllPellets =++    doN 4 move;+    turn right;+    doN 2 move;++    tryGrab;+    turnAndEat right 3;+    turnAndEat left 2;+    turnAndEat left 5;+    turnAndEat right 2;+    turnAndEat left 4;+    turnAndEat right 2;+    turnAndEat right 20;+    turnAndEat right 2;+    turnAndEat right 4;+    turnAndEat left 4;+    turnAndEat right 5;+    turnAndEat right 2;+    turnAndEat right 3;+    turnAndEat left 2;+    turnAndEat left 3;+    turnAndEat right 2;+    turnAndEat left 2;+    turnAndEat left 2;+    turnAndEat right 3;+    turnAndEat left 2;+    turnAndEat left 10;+    turnAndEat left 2;+    turnAndEat right 2;+    turnAndEat right 2;+    turnAndEat left 2;+    turnAndEat right 2;+    turnAndEat right 4;+    turnAndEat left 13;+    turnAndEat right 5;+    turnAndEat right 3;+    turnAndEat right 9;+    turnAndEat right 3;+    turnAndEat right 4;+    turnAndEat right 5;+    turnAndEat right 4;+    turnAndEat right 2;+    turnAndEat right 6;+    turnAndEat right 2;+    turnAndEat left 3;+    turnAndEat right 2;+    turnAndEat left 2;+    turnAndEat left 2;+    turnAndEat right 3;+    turnAndEat left 2;+    turnAndEat left 4;+    turnAndEat back 1;+    turnAndEat left 3;+    turnAndEat right 5;+    turnAndEat right 3;+    turnAndEat left 4;+    turnAndEat left 3;+    turnAndEat left 4;+    turnAndEat left 3;+    turnAndEat right 1;+    turnAndEat back 5;+    turnAndEat right 2;+    turnAndEat right 4;+    turnAndEat right 1;+    turnAndEat back 9;+    turnAndEat right 1;+    turnAndEat back 1;+    turnAndEat right 1;+    turnAndEat back 1;+    turnAndEat right 4;+    turnAndEat right 2;+    turnAndEat right 2;+    turnAndEat left 1;+    end;++def waitToGive =+    tryGive "donut";+    hasDonut <- has "donut";+    if hasDonut {waitToGive} {};+    end;++def returnToCenter =+    turn back;+    move;+    turn right;+    doN 2 move;+    turn left;+    doN 2 move;+    turn left;+    doN 6 move;+    turn right;+    doN 2 move;+    turn left;+    doN 4 move;+    _strawberry <-grab;+    doN 4 move;+    turn right;+    doN 2 move;+    turn left;+    doN 2 move;+    end;++def invadeDen =+    doN 14 move;+    turn right;+    doN 2 move;+    turn left;+    doN 4 move;+    turn left;+    make "den key";+    drill forward;+    doN 2 move;+    end;++eatAllPellets;+returnToCenter;+waitToGive;+invadeDen;
+ data/scenarios/Challenges/_hackman/teleporter.sw view
@@ -0,0 +1,41 @@+/* 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;
+ data/scenarios/Challenges/_hanoi/hanoi-count.sw view
@@ -0,0 +1,62 @@+def repeat = \c. force c; repeat c end;++def i2e = \i.+  if (i == 2) { "two" } {+  if (i == 3) { "three" } {+  fail $ "Fatal error: There should be only 2 or 3 entities placed at any time: " ++ format i+  }}+end;++def cscan = \d.+  s <- scan d;+  if (s == inl ()) {return 0} {return 1}+end;++def count_column =+  i <- cscan north;+  j <- cscan down;+  k <- cscan south;+  // log "one column";+  // wait 8;+  // log (format i);+  // wait 8;+  // log (format j);+  // wait 8;+  // log (format k);+  // wait 8;+  return (i + j + k)+end;+++repeat {+    sum <- as self {+        // left column+        teleport self (-2,-2);+        x <- count_column;+        // middle column+        teleport self (0,-2);+        y <- count_column;+        // right column+        teleport self (2,-2);+        z <- count_column;+        // DEBUG+        // log "all columns";+        // wait 8;+        // log (format x);+        // wait 8;+        // log (format y);+        // wait 8;+        // log (format z);+        return $ i2e (x + y + z)+    };+    //let sum = i2e (x + y + z) in+    teleport self (0,-6);+    counted <- scan down;+    //wait 8;+    //log (format counted);+    case counted (\e.+        fail $ "Fatal error: there should always be a count entity at (0,-6)! " ++ format e ++ " " ++ format counted+    ) (\e.+        if (e == sum) {} {swap sum; return ()}+    )+}
+ data/scenarios/Challenges/_hanoi/hanoi-increasing.sw view
@@ -0,0 +1,48 @@+// if+//  0. all (but max 3) disks in my column are sorted+// then+//  - place "OK"+// else+//  - try to grab "OK"+def null = inl () end;+def repeat = \c. c; repeat c end;+def toI = \e.+  if (e == "one"   || e == "blocked one")   {1} {+  if (e == "two"   || e == "blocked two")   {2} {+  if (e == "three" || e == "blocked three") {3} {+  fail $ "There should be no other placeable entity: " ++ e+  }}}+end;+def f = \x.\y.+  case x (\_. false) (\i.+    case y (\_. false) (\j.+      let xi = toI i in+      let yj = toI j in+      xi > yj+    )+  )+end;++w <- whereami;+// the middle of the column+let a = (fst w, snd w + 3) in+repeat (+    o <- as self {+        teleport self a;+        x <- scan south;+        y <- scan down;+        z <- scan north;+        if (z == null) {+          if (y == null) {+            return true+          } {+            return $ f x y+          }+        } {+          return $ f x y && f y z+        }+    };+    try {+        if o {place "OK"} {grab; return ()}+    } {}+)
+ data/scenarios/Challenges/_hanoi/hanoi-invariant.sw view
@@ -0,0 +1,64 @@+def repeat = \c. c; repeat c end;+def isUnlocked = \e. e == "one" || e == "two" || e == "three" end;+def unlock = \e.+  if (e == "blocked one")   {"one"}   {+  if (e == "blocked two")   {"two"}   {+  if (e == "blocked three") {"three"} {+  fail $ "Can not unlock: " ++ e+  }}}+end;++repeat (+me <- scan down;+case me (\_. return ()) (\e.+// if+//  0. I stand on unlocked X+//  1. place north of me is NOT empty+//     or+//     the count of all placed is NOT 3+// then+//  - lock X+if (isUnlocked e)+{+    northFullOrAllPlaced <- as self {+      mn <- scan north;+      case mn (\_.+        teleport self (0,-6);+        allPlaced <- ishere "three";+        return (not allPlaced)+      ) (\_.+        return true+      );+    };+    if northFullOrAllPlaced {+      swap ("blocked " ++ e); return ()+    } {}+}+// if+//  0. I stand on locked X+//  1. place north of me is empty+//  2. all disks are placed+//  3. other columns are sorted (check "OK")+// then+//  - unlock X+{+    mn <- scan north;+    case mn (\_.+      wait 16;+      allPlaced <- as self {+        teleport self (0,-6);+        ishere "three"+      };+      allSorted <- as self {+        teleport self (-2,-5);+        o1 <- ishere "OK";+        teleport self (0,-5);+        o2 <- ishere "OK";+        teleport self (2,-5);+        o3 <- ishere "OK";+        return (o1 && o2 && o3)+      };+      if (allPlaced && allSorted) {swap (unlock e); return ()} {}+    ) (\_. return ())+}+))
+ data/scenarios/Challenges/_hanoi/hanoi-solution.sw view
@@ -0,0 +1,64 @@+def until = \p. \c. q <- p; if q {} {c; until p c} end;+def rep = \n. \c. if (n == 0) {} {c; rep (n-1) c} end;++def ifC = \p. \t. \e. res <- p; if res t e end;++def orC = \c1. \c2.+  b1 <- c1; b2 <- c2; return (b1 || b2)+end;++def somethingHere =+  res <- scan down;+  return (res != inl ())+end;++def fwdToThing = until blocked move end;++def fwdToBlank =+  move;+  until (orC blocked somethingHere) move;+  ifC somethingHere {turn back; move; turn back} {}+end;++def goBack = turn back; fwdToBlank; turn back end;++def getDisk =+  fwdToThing;+  d <- grab;+  goBack;+  return d+end;++def placeDisk = \d.+  fwdToBlank;+  place d;+  goBack+end;++def moveToCol = \w.\x.+  if (w < x) { turn east; rep (x - w) move }+  { if (w > x) { turn west; rep (w - x) move } {} };+  turn south+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+  = \n. \o. \a. \b. \c.+  if (n == 0) {return o}+  {+    o_new <- hanoi (n-1) o a c b;+    moveToCol o_new a;+    wait 8;+    d <- getDisk;+    moveToCol a c;+    placeDisk d;+    hanoi (n-1) c b a c;+  }+end;++hanoi 3 0 (-2) 0 2
+ data/scenarios/Challenges/_lights-out/assistant.sw view
@@ -0,0 +1,275 @@+def elif = \t. \then. \else. {if t then else} end+def else = \t. t end+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def boolToInt = \b.+    if b {1} {0}+    end;++// modulus function (%)+def mod : int -> int -> int = \i.\m.+  i - m * (i / m)+end++def isEven = \n.+    mod n 2 == 0;+    end++def intersperse = \n. \f2. \f1. if (n > 0) {+        f1;+        if (n > 1) {+            f2;+        } {};+        intersperse (n - 1) f2 f1;+    } {};+    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 replaceWith = \withThis.+    create withThis;+    swap withThis;+    return ();+    end;++/** Modifies the cell */+def invertLight = \e.+    if (e == "off") {+        replaceWith "on";+    } $ elif (e == "on") {+        replaceWith "off";+    } {}+    end;++def toggleLightHere =+    entHere <- scan down;+    case entHere return invertLight;+    end;++/** Precondition: in the middle of a "cross" */+def toggleSingleNeighbor =+    move;+    toggleLightHere;+    turn back;+    move;+    end;++def toggleAllNeighbors =+    doN 2 (+        doN 2 toggleSingleNeighbor;+        turn left;+    );+    end;++def flipSelfAndNeighbors = \newState. \locOffset.+    curLoc <- whereami;+    let newLoc = sumTuples locOffset curLoc in+    teleport self newLoc;+    replaceWith newState;+    toggleAllNeighbors;+    teleport self curLoc;+    end;++def togglePending = \state.+    let pendingEntityName = "pending-" ++ state in+    maybePending <- detect pendingEntityName ((1, 1), (6, 6));+    case maybePending return $ flipSelfAndNeighbors state;+    end;++def observe =+    instant (+        togglePending "on";+        togglePending "off";+    );++    // Without this 'wait' call, we may end up doing the instant call+    // multiple times in one tick, until it uses up its step allotment.+    // We really only want the 'observe' function to execute once per tick.+    wait 1;++    observe;+    end;++def makeOnIf = \b.+    if b {replaceWith "on"} {};+    end;++/** Precondition: Light is off */+def randomOn =+    x <- random 2;+    makeOnIf $ x == 0;+    end;++/**+This is a distillation into code of the+first quiet pattern here:+https://www.jaapsch.net/puzzles/lights.htm#quiet++10101+10101+00000+10101+10101++Note that the second quiet pattern is just the transpose,+so we can simply swap the position index arguments to obtain it:++11011+00000+11011+00000+11011++Indices are zero-based.+*/+def isQuietPatternMember = \rowIdx. \colIdx.+    rowIdx != 2 && mod colIdx 2 == 0;+    end;++def advanceRowViaTeleport =+    curLoc <- whereami;+    teleport self (0, snd curLoc - 1);+    end;++def shouldCorrectTile : (bool * bool) -> (bool * bool) -> cmd bool = \evenOverlaps. \isQuietTiles.+    if (evenOverlaps == isQuietTiles) {+        toggleLightHere;+        return true;+    } {+        return false;+    }+    end;++/** Returns the number of lights in common+with each quiet pattern, for this row.+*/+def prepareBoardRow = \abortFunc. \rowIdx. \colIdx.+    if (colIdx >= 0) {++        isCurrentlyOn <- ishere "on";++        let isQuietTile1 = isQuietPatternMember rowIdx colIdx in+        let isQuietTile2 = isQuietPatternMember colIdx rowIdx in++        let quietTuple = (isQuietTile1, isQuietTile2) in++        shouldAbort <- abortFunc quietTuple;+        if shouldAbort {+            return ((0, 0), true);+        } {+            let quietCellOn = mapTuple (\x. x && isCurrentlyOn) quietTuple in+            let addend = mapTuple boolToInt quietCellOn in++            move;+            retval <- prepareBoardRow abortFunc rowIdx $ colIdx - 1;+            let subTotal = fst retval in+            return $ (sumTuples addend subTotal, snd retval);+        }+    } {+        return ((0, 0), false);+    }+    end;++/** Returns the number of lights in common+with each quiet pattern.+*/+def prepareBoardAllRows = \abortFunc. \boardWidth. \rowIdx.+    if (rowIdx >= 0) {+        retval <- prepareBoardRow abortFunc rowIdx $ boardWidth - 1;+        let rowCommonCount = fst retval in+        let shouldAbort = snd retval in++        if shouldAbort {+            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 (0, 0);+    }+    end;++def checkIsSolvable = \boardWidth. \boardHeight.+    overlapCounts <- prepareBoardAllRows (\_. return false) boardWidth $ boardHeight - 1;+    // say $ "Overlap counts: " ++ format overlapCounts;+    return $ mapTuple isEven overlapCounts;+    end;++/** Teleports to a new location to execute a function+  then returns to the original location before+  returning the functions output value.+*/+def atLocation = \newLoc. \f.+    prevLoc <- whereami;+    teleport self newLoc;+    retval <- f;+    teleport self prevLoc;+    return retval;+    end;++def analyzeSolvability : int -> int -> cmd (bool * bool) = \boardWidth. \boardHeight.+    atLocation (0, 0) $+        checkIsSolvable boardWidth boardHeight;+    end;++def prepareBoardRandom = \boardWidth. \boardHeight. +    atLocation (0, 0) $+        intersperse boardHeight advanceRowViaTeleport $+            intersperse boardWidth move randomOn;+    end;++def ensureSolvability = \evenOverlaps. \boardWidth. \boardHeight.+    let isSolvable = fst evenOverlaps && snd evenOverlaps in+    // say $ "isSolvable: " ++ format isSolvable;+    if isSolvable {} {+        atLocation (0, 0) $+            prepareBoardAllRows (shouldCorrectTile $ mapTuple not evenOverlaps) boardWidth $ boardHeight - 1;+        return ()+    }+    end;++/**+Only about one in four randomly-assigned light patterns+are actual solvable lights-out games, so we make+an adjustment if our particular pattern is not solvable.++It so happens that an unsolvable board can be made+solvable by toggling exactly one carefully chosen light.+*/+def generateGame = \boardWidth. \boardHeight.++    prepareBoardRandom boardWidth boardHeight;++    evenOverlaps <- analyzeSolvability boardWidth boardHeight;+    ensureSolvability evenOverlaps boardWidth boardHeight;++    // Sanity checking:+    // evenOverlaps2 <- analyzeSolvability boardWidth boardHeight;+    // let isSolvable2 = fst evenOverlaps2 && snd evenOverlaps2 in+    // say $ "isSolvable2: " ++ format isSolvable2;++    // "Sentinel" to indicate that board preparation is complete+    create "flower";+    end;++def go =+    let boardWidth = 5 in+    let boardHeight = 5 in+    instant $ generateGame boardWidth boardHeight;+    observe;+    end;++go;
+ data/scenarios/Challenges/_lights-out/solution.sw view
@@ -0,0 +1,139 @@+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;++/** Precondition: facing "d" direction */+def toggleToDark = \d.+    onHere <- ishere "on";+    if onHere {drill d; return ()} {};+    end;++def visitSingleRow = \rowWidth. \d.+    intersperse rowWidth move $ toggleToDark d;+    end;++def turnAround = \d.+    turn d;+    move;+    turn d;+    end;++/** Iterates through the first four rows. */+def chaseUpperLights = \rowWidth.+    visitSingleRow rowWidth right;+    turnAround right;+    visitSingleRow rowWidth left;+    turnAround left;+    visitSingleRow rowWidth right;+    turnAround right;+    visitSingleRow rowWidth left;+    end;++/**+Place yourself in the upper-left corner, facing east.+*/+def goToCorner =+    move;+    turn right;+    move;+    turn left;+    end;++def onInDirection = \d.+    entHere <- scan d;+    return $ case entHere (\_. false) (\e. e == "on");+    end;++/**+If the light at A5 is on, press D1 and E1.+*/+def fixA5 =+    turn back;+    doN 2 move;+    turn right;+    doN 3 move;+    drill left;+    move;+    drill left;+    turn back;+    doN 3 move;+    turn left;+    doN 2 move;+    end;++/**+If the light at B5 is on, press B1 and E1.+*/+def fixB5 =+    turn back;+    doN 2 move;+    drill forward;+    turn right;+    doN 3 move;+    drill left;+    turn back;+    doN 2 move;+    turn left;+    doN 2 move;+    end;++/**+If the light at C5 is on, press D1.+*/+def fixC5 =+    turn back;+    doN 3 move;+    turn right;+    drill forward;++    turn back;+    doN 2 move;+    turn back;+    end;++/**+Precondition: on first column of fourth row, facing south.+*/+def fixUpperLights =+    a5on <- onInDirection forward;+    if a5on {fixA5} {+        turn left;+        move;+        turn right;+    };++    b5on <- onInDirection forward;+    if b5on {fixB5} {+        turn left;+        move;+        turn right;+    };++    c5on <- onInDirection forward;+    if c5on {fixC5} {+        turn right;+        doN 2 move;+        turn right;+        doN 3 move;+        turn right;+    };+++    end;++def go =+    goToCorner;+    chaseUpperLights 5;+    turn left;+    fixUpperLights;+    chaseUpperLights 5;+    end;++go;
+ data/scenarios/Challenges/_maypole/monitor.sw view
@@ -0,0 +1,105 @@+def elif = \t. \then. \else. {if t then else} end+def else = \t. t end+def abs = \n. if (n < 0) {-n} {n} end+// modulus function (%)+def mod : int -> int -> int = \i.\m.+  i - m * (i / m)+end++/*+Quadrants are numbered counter-clockwise, staring in the northeast:+        |+     1  |  0+   _____|_____+        |+     2  |  3+        |+This is same as the standard graph quadrants in mathematics, except+for 0-based numbering rather than 1-based.+*/+def getQuadrant : (int * int) -> (int * int) -> int = \baseLoc. \myLoc.+    let baseX = fst baseLoc in+    let baseY = snd baseLoc in++    let myX = fst myLoc in+    let myY = snd myLoc in++    let isUp = myY < baseY in+    let isRight = myX < baseX in++    if (isUp && isRight) {0}+    $ elif (isUp) {1}+    $ elif (isRight) {3}+    $ else {2}+    end;++/*+Possible edge case:+----+If the difference in quadrants is 2, then either+the monitor is not making observations with high+enough frequency, or the target has teleported+diagonally.+Either way, the direction of rotation is ambiguous,+so we should make the increment zero.+*/+def getQuadrantIncrement = \oldQuadrant. \newQuadrant.++    let rawDifference = newQuadrant - oldQuadrant in+    let difference = if (abs rawDifference == 3) {-rawDifference} {rawDifference} in++    if (difference > 0) {1}+    $ elif (difference < 0) {-1}+    $ else {0}+    end;++def getCurrentQuadrant : (int * int) -> cmd int = \myLoc.+  baseLoc <- as base {whereami};+  return $ getQuadrant baseLoc myLoc;+  end;++def checkNewQuadrant = \myLoc. \prevQuadrant. \quadrantTraversalCount.+  currentQuadrant <- getCurrentQuadrant myLoc;+  let changeCount = getQuadrantIncrement prevQuadrant currentQuadrant in+  let newQuadrantCount = quadrantTraversalCount + changeCount in++  if (changeCount != 0) {+    swap $ "maypole " ++ format currentQuadrant;+    return ();+  } {};+  return (currentQuadrant, newQuadrantCount);+  end;++/*+Although conceivably the current quadrant could+be derived from the quadrant traversal count,+since it is possible to start "traversing" from+any quadrant we just keep track of them separately.++Also, the edge case for disregarding "diagonal" teleportation+means that the traversal number could get out of sync+with the absolute quadrant index.+*/+def monitorAngle : (int * int) -> int -> int -> int -> cmd unit =+    \myLoc. \targetQuadrantCount. \prevQuadrant. \quadrantTraversalCount.+  result <- instant $ checkNewQuadrant myLoc prevQuadrant quadrantTraversalCount;+  let currentQuadrant = fst result in+  let newQuadrantCount = snd result in++  if (newQuadrantCount < targetQuadrantCount) {+    monitorAngle myLoc targetQuadrantCount currentQuadrant newQuadrantCount;+  } {+    create "dizzy";+    swap "bitcoin";+    return ();+  }+  end;++def go =+  myLoc <- whereami;+  currentQuadrant <- getCurrentQuadrant myLoc;+  monitorAngle myLoc 12 currentQuadrant 0;+  end;++go;+selfdestruct;
+ data/scenarios/Challenges/_maypole/solution.sw view
@@ -0,0 +1,17 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def singleLeg =+    doN 4 move;+    turn left;+    end;++def singleLoop =+    doN 4 singleLeg;+    end;++doN 3 singleLoop;++doN 2 move;+turn left;+doN 2 move;+grab;
data/scenarios/Challenges/_word-search/create-puzzle.sw view
@@ -244,4 +244,4 @@     removeBoulder;     end; -createPuzzle 25 15;+instant $ createPuzzle 25 15;
+ data/scenarios/Challenges/arbitrage.yaml view
@@ -0,0 +1,417 @@+version: 1+name: Paperclip maximizer+author: Karl Ostmo+description: |+  Make trades to earn your fortune.+creative: false+objectives:+  - teaser: Earn riches+    goal:+      - |+        Each shop offers different wares for trade.+        Recipes dictate which items may be exchanged+        at any given shop. Use the `drill`{=entity} on a shop to perform+        an exchange.+      - |+        As an itinerant merchant, you may exploit market asymmetry+        for profit.+      - |+        Amass a fortune of 100 paperclips.+    condition: |+      as base {+        pcount <- count "paperclip";+        return $ pcount >= 100;+      };+  - teaser: Beginner capital+    goal:+      - |+        Great start! Perhaps it is time+        to enter a higher-end goods market?+    optional: true+    hidden: true+    condition: |+      as base {+        pcount <- count "paperclip";+        return $ pcount >= 20;+      };+attrs:+  - name: shopA+    fg: '#ff0000'+  - name: shopB+    fg: '#00ff00'+  - name: shopC+    fg: '#0000ff'+  - name: shopD+    fg: '#ffff00'+  - name: shopE+    fg: '#ff00ff'+  - name: shopF+    fg: '#00ffff'+  - name: shopG+    fg: '#bb8844'+  - name: shopX+    fg: '#000000'+    bg: '#ffffff'+  - name: shopY+    fg: '#ffffff'+    bg: '#000000'+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - antenna+      - branch predictor+      - comparator+      - compass+      - dictionary+      - drill+      - grabber+      - keyboard+      - lambda+      - lodestone+      - logger+      - net+      - scanner+      - strange loop+      - treads+    inventory:+      - [5, paperclip]+solution: |+   run "scenarios/Challenges/_arbitrage/solution.sw"+entities:+  - name: paperclip+    display:+      char: '@'+      attr: red+    description:+      - An ubiquitous office accoutrement.+      - Practically worthless as a single unit.+    properties: [known, portable]+  - name: pinwheel+    display:+      char: 'P'+      attr: gold+    description:+      - Watch it spin. Wheee!+    properties: [portable]+  - name: stapler+    display:+      char: 'S'+      attr: red+    description:+      - A shiny red stapler+    properties: [portable]+  - name: toothbrush+    display:+      char: 'b'+      attr: blue+    description:+      - Brushy brushy+    properties: [portable]+  - name: Pez dispenser+    display:+      char: 'P'+    description:+      - Classic collectible toy. Absent its chalky candy.+    properties: [portable]+  - name: shoehorn+    display:+      char: 'h'+    description:+      - Handheld apparatus for donning snug footwear+    properties: [portable]+  - name: trivet+    display:+      char: 'v'+    description:+      - Protective silicone mat for hot cookware+    properties: [portable]+  - name: coffee mug+    display:+      char: 'c'+    description:+      - Caffeine conveyance+    properties: [portable]+  - name: toaster+    display:+      char: 'A'+    description:+      - Bread warmer-upper+    properties: [portable]+  - name: blender+    display:+      char: 'B'+    description:+      - Essential for smoothie preparation+    properties: [portable]+  - name: electric can opener+    display:+      char: 'B'+    description:+      - |+        For when you can't be bothered to manually open a can+    properties: [portable]+  - name: wok+    display:+      char: 'w'+    description:+      - One must wok before one can run.+    properties: [portable]+  - name: sous vide cooker+    display:+      char: 's'+    description:+      - trendy gourmet cooking appliance+    properties: [portable]+  - name: french press+    display:+      char: 'f'+    description:+      - plunger-based coffee maker+    properties: [portable]+  - name: stand mixer+    display:+      char: 'm'+    description:+      - whips, kneads, and mixes+    properties: [portable]+  - name: shopA+    display:+      char: 'A'+      attr: shopA+    description:+      - A trading post+    properties: [known]+  - name: shopB+    display:+      char: 'B'+      attr: shopB+    description:+      - A trading post+    properties: [known]+  - name: shopC+    display:+      char: 'C'+      attr: shopC+    description:+      - A trading post+    properties: [known]+  - name: shopD+    display:+      char: 'D'+      attr: shopD+    description:+      - A trading post+    properties: [known]+  - name: shopE+    display:+      char: 'E'+      attr: shopE+    description:+      - A trading post+    properties: [known]+  - name: shopF+    display:+      char: 'F'+      attr: shopF+    description:+      - A trading post+    properties: [known]+  - name: shopG+    display:+      char: 'G'+      attr: shopG+    description:+      - A trading post+    properties: [known]+  - name: shopX+    display:+      char: 'X'+      attr: shopX+    description:+      - A high-end trading post+    properties: [known]+  - name: shopY+    display:+      char: 'Y'+      attr: shopY+    description:+      - A high-end trading post+    properties: [known]+recipes:+  - in:+      - [1, shopA]+      - [10, paperclip]+    out:+      - [1, shopA]+      - [1, pinwheel]+    required:+      - [1, drill]+  - in:+      - [1, shopB]+      - [1, pinwheel]+    out:+      - [1, shopB]+      - [1, stapler]+    required:+      - [1, drill]+  - in:+      - [1, shopC]+      - [1, stapler]+    out:+      - [1, shopC]+      - [1, toothbrush]+    required:+      - [1, drill]+  - in:+      - [1, shopD]+      - [1, toothbrush]+    out:+      - [1, shopD]+      - [1, Pez dispenser]+    required:+      - [1, drill]+  - in:+      - [1, shopD]+      - [1, toaster]+    out:+      - [1, shopD]+      - [1, blender]+    required:+      - [1, drill]+  - in:+      - [1, shopE]+      - [1, Pez dispenser]+    out:+      - [1, shopE]+      - [1, shoehorn]+    required:+      - [1, drill]+  - in:+      - [1, shopC]+      - [1, blender]+    out:+      - [1, shopC]+      - [1, electric can opener]+    required:+      - [1, drill]+  - in:+      - [1, shopF]+      - [1, shoehorn]+    out:+      - [1, shopF]+      - [1, trivet]+    required:+      - [1, drill]+  - in:+      - [1, shopX]+      - [20, paperclip]+    out:+      - [1, shopX]+      - [1, toaster]+    required:+      - [1, drill]+  - in:+      - [1, shopG]+      - [1, coffee mug]+    out:+      - [1, shopG]+      - [11, paperclip]+    required:+      - [1, drill]+  - in:+      - [1, shopG]+      - [1, stand mixer]+    out:+      - [1, shopG]+      - [30, paperclip]+    required:+      - [1, drill]+  - in:+      - [1, shopC]+      - [1, trivet]+    out:+      - [1, shopC]+      - [1, coffee mug]+    required:+      - [1, drill]+  - in:+      - [1, shopB]+      - [1, electric can opener]+    out:+      - [1, shopB]+      - [1, wok]+    required:+      - [1, drill]+  - in:+      - [1, shopY]+      - [1, wok]+    out:+      - [1, shopY]+      - [1, sous vide cooker]+    required:+      - [1, drill]+  - in:+      - [1, shopF]+      - [1, sous vide cooker]+    out:+      - [1, shopF]+      - [1, french press]+    required:+      - [1, drill]+  - in:+      - [1, shopC]+      - [1, french press]+    out:+      - [1, shopC]+      - [1, stand mixer]+    required:+      - [1, drill]+  - in:+      - [1, shopY]+      - [1, wok]+    out:+      - [1, shopY]+      - [1, sous vide cooker]+    required:+      - [1, drill]+known: []+world:+  dsl: |+    {dirt}+  upperleft: [0, 0]+  offset: false+  palette:+    '.': [grass]+    '*': [stone]+    '/': [dirt]+    '1': [dirt, shopA]+    '2': [dirt, shopB]+    '3': [dirt, shopC]+    '4': [dirt, shopD]+    '5': [dirt, shopE]+    '6': [dirt, shopF]+    '7': [dirt, shopG]+    'X': [dirt, shopX]+    'Y': [dirt, shopY]+    'B': [grass, null, base]+    'p': [grass, paperclip]+  map: |+    /.............../+    .................+    ........*........+    ...5****6****Y...+    ...*....*....*...+    ...*....*........+    ...*....*........+    ...*....*........+    ...4****3****2...+    ........*....*...+    ........*....*...+    ........*....*...+    ...*....*....*...+    ...X****7****1...+    ........*........+    B....p.p.p.p.p...+    /.............../
+ data/scenarios/Challenges/blender.yaml view
@@ -0,0 +1,229 @@+version: 1+name: Fortress infiltration+author: Karl Ostmo+description: |+  Navigate enemy-infested passages of Lambda Fortress to retrieve the prize.+creative: false+objectives:+  - teaser: Get amulet+    goal:+      - |+        `grab` the Amulet of Yoneda from the northwest sanctum while+        timing your passage carefully to avoid Side Effects (X) on patrol.+      - |+        To unlock a red door, `drill` it with the "door key" equipped.+    condition: |+      as base {has "Amulet of Yoneda"}+    prerequisite:+      not: get_caught+  - id: get_caught+    teaser: Apprehended+    goal:+      - Got caught by the patrolling bots+    hidden: true+    optional: true+    condition: |+      // run "scenarios/Challenges/_blender/apprehension-checker.sw"+      def hasMetBase = \r.+          let basename = "base" in+          x <- as r {whoami};+          if (x == basename) {+              return false;+          } {+              mr0 <- as r {meet};+              case mr0+                (\_. return false)+                (\bot. name <- as bot {whoami}; return $ name == basename);+          };+          end;++      /**+      Iterates sequentially until+      encountering an invalid robot index.++      Distinguishes system bots from the base by name.+      Returns true if a bot has "met" the base.+      */+      def anyHasMetBase : int -> cmd bool = \idx.+          +          try {+              bot <- robotnumbered idx;+              intermediate <- hasMetBase bot;+              let foo = intermediate in+              let newIdx = idx + 1 in+              recursiveResult <- anyHasMetBase newIdx;+              return $ foo || recursiveResult;+          } {+            // Terminates the recursion on the+            // lowest index at which a robot does not exist+            return false;+          };+          end;++      anyHasMetBase 1;+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - binoculars+      - branch predictor+      - clock+      - comparator+      - compass+      - counter+      - dictionary+      - grabber+      - hearing aid+      - keyboard+      - lambda+      - logger+      - mirror+      - net+      - scanner+      - strange loop+      - string+      - treads+      - welder+  - name: cw_robot+    system: true+    dir: [0, 1]+    display:+      invisible: false+      char: 'X'+      attr: robot+    program: |+      run "scenarios/Challenges/_blender/patrol-clockwise.sw"+  - name: cw_robot_down+    system: true+    dir: [0, -1]+    display:+      invisible: false+      char: 'X'+      attr: robot+    program: |+      run "scenarios/Challenges/_blender/patrol-clockwise.sw"+  - name: ccw_robot+    system: true+    dir: [0, 1]+    display:+      invisible: false+      char: 'X'+      attr: robot+    program: |+      run "scenarios/Challenges/_blender/patrol-counter-clockwise.sw"+  - name: ccw_robot_down+    system: true+    dir: [0, -1]+    display:+      invisible: false+      char: 'X'+      attr: robot+    program: |+      run "scenarios/Challenges/_blender/patrol-counter-clockwise.sw"+solution: |+  run "scenarios/Challenges/_blender/solution.sw"+entities:+  - name: granite boulder+    display:+      char: '@'+      attr: rock+    description:+      - Impassible rock, resistant to drilling+    properties: [known, unwalkable]+  - name: locked door+    display:+      char: '@'+      attr: red+    description:+      - Locked door+    properties: [known, unwalkable]+  - name: unlocked door+    display:+      char: '@'+      attr: green+    description:+      - Unlocked door+    properties: [known]+  - name: door key+    display:+      char: 'k'+      attr: gold+    description:+      - used to unlock a door+    properties: [known, portable]+    capabilities: [drill]+  - name: bind gt+    display:+      char: '>'+      attr: gold+    description:+      - Decorative sculpture+    properties: [known]+  - name: bind eq+    display:+      char: '='+      attr: gold+    description:+      - Decorative sculpture+    properties: [known]+  - name: Amulet of Yoneda+    display:+      char: 'Y'+      attr: snow+    description:+      - The figurative jewel of category theory+    properties: [known, portable]+recipes:+  - in:+      - [1, locked door]+    out:+      - [1, unlocked door]+    required:+      - [1, door key]+  - in:+      - [1, unlocked door]+    out:+      - [1, locked door]+    required:+      - [1, door key]+known: [water]+seed: 0+world:+  dsl: |+    {stone, water}+  upperleft: [0, 0]+  offset: false+  palette:+    '0': [stone, water]+    '@': [stone, granite boulder]+    '.': [grass, erase]+    'L': [stone, erase]+    '>': [stone, bind gt]+    '=': [stone, bind eq]+    H: [dirt, erase]+    A: [grass, water, ccw_robot]+    a: [grass, water, ccw_robot_down]+    B: [grass, erase, cw_robot]+    b: [grass, erase, cw_robot_down]+    Ω: [grass, erase, base]+    f: [stone, Amulet of Yoneda]+    x: [stone, locked door]+    k: [grass, door key]+  map: |+    ..@@@@@@@@@@@@@@@@@@@@@@@@@@@..+    ..LxLLLLLf@.........x.....k.@..+    ..@@@@@@@@@.@@@@@@@.@@@@@@@.@..+    ..@H000A000H0000000H000A000H@..+    ..@.@@@@@@@.@@@@@@@.@@@@@@@.@..+    ..@.@L....@.@L....x.@L....@.@..+    ..@.@.L...@.@.L...@.@.L...@.@..+    ..@.@..L..@B@..L..@b@..L..@.@..+    ..@.@.L.L.@.@.L.L.@.@.L.L.@.@..+    ..@.@L...L@.xL...L@.@L...L@.@..+    ..@.@@@@@@@.@@@@@@@.@@@@@@@.@..+    ..@H000a000H0000000H000a000H@..+    ..@@@@@@@@@.@@@@@@@.@@@@@@@.@..+    ..Ω.........@.....@.........@..+    @@@@@@@@@@@@@.>>=.@@@@@@@@@@@..+    ...............................
+ data/scenarios/Challenges/bridge-building.yaml view
@@ -0,0 +1,692 @@+version: 1+name: A Frivolous Excursion+author: Karl Ostmo+description: |+  Use the resources at hand to open paths between the geographic regions.+creative: false+attrs:+  - name: magenta+    fg: "#ff00ff"+  - name: lavender+    fg: "#eebbff"+  - name: tan+    fg: "#D2B48C"+  - name: beach+    fg: "#8b4513"+    bg: "#c2b280"+  - name: blueBG+    bg: "#86C5D8"+  - name: lavaBG+    bg: "#ff8800"+  - name: cyan+    fg: "#00ffff"+  - name: lava+    bg: "#bb0000"+    fg: "#ff8800"+  - name: glacier+    bg: "#8888dd"+    fg: "#ddddff"+  - name: obsidian+    bg: "#000000"+    fg: "#FFFFFF"+  - name: quarry+    bg: "#888888"+    fg: "#555533"+  - name: jungle+    bg: "#004400"+    fg: "#00CC00"+  - name: bog+    bg: "#002200"+    fg: "#885522"+  - name: niceBog+    bg: "#224422"+    fg: "#964B00"+objectives:+  - id: get_peat+    teaser: Collect peat+    goal:+      - The old grind.+    optional: true+    hidden: true+    condition: |+      as base {+        has "peat";+      };+  - id: hammer_time+    teaser: Hammer time+    goal:+      - Produce an obsidian shard.+    optional: true+    hidden: true+    condition: |+      as base {+        has "obsidian shard";+      };+  - id: trespass_neighbor+    teaser: Tresspassing+    goal:+      - Snoop inside the neighbor's house.+    optional: true+    hidden: true+    condition: |+      as base {+        c <- whereami;+        let x = fst c in+        return $ x >= 1 && x <= 2 && snd c == -30;+      };+  - id: get_pebble+    teaser: Off-piste+    goal:+      - Collect a souvenir from outside the borders of the map.+    optional: true+    hidden: true+    condition: |+      as base {+        has "pebble";+      };+  - id: get_map+    teaser: Get the map+    goal:+      - As a humble peat farmer, you subsist in a simple cabin by the bog.+        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-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 to orient yourself.+    condition: |+      as base {+        has "map";+      };+  - id: find_temple+    teaser: Find the temple+    prerequisite: get_map+    goal:+      - You study the map.+      - Glacier-bound mountains tower in the east,+        a volcano oozes a river of lava 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 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 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 to the east.+        A highly-prized flower 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";+      };+  - id: flower_ring+    teaser: Encircle the temple+    prerequisite: find_temple+    goal:+      - "A note on the door says:"+      - '"Greetings, intrepid traveler. Encircle this temple with the rare "flower" of the southeastern+        caves, and the treasure of this temple shall be revealed."'+      - Plant a ring of flowers around the jungle temple.+    condition: |+      as base {+        has "painted plate";+      };+  - id: decorate_cabin+    teaser: Decorate cabin+    prerequisite: flower_ring+    goal:+      - Brighten up your hovel with some kitsch.+    condition: |+      r <- robotnamed "platecheck";+      as base {+        ishere "painted plate";+      };+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - treads+      - lodestone+      - clock+      - compass+      - comparator+      - counter+      - dictionary+      - grabber+      - keyboard+      - lambda+      - logger+      - mirror+      - drill+      - net+      - scanner+      - strange loop+      - workbench+      - harvester+      - oven mitts+      - big furnace+      - peat furnace+    inventory:+      - [0, rubble skip]+      - [0, crucible]+      - [0, cliff]+      - [0, obsidian path]+      - [0, causeway]+      - [0, glacier]+      - [0, swampy bog]+      - [0, jungle]+  - name: flowercheck+    system: true+    dir: [0, 1]+    display:+      invisible: true+    devices:+      - logger+    inventory:+      - [1, painted plate]+    program: |+      run "scenarios/Challenges/_bridge-building/flower-ring-check.sw"+  - name: platecheck+    system: true+    dir: [0, 1]+    display:+      invisible: true+solution: |+  run "scenarios/Challenges/_bridge-building/solution.sw"+entities:+  - name: map+    display:+      char: 'M'+      attr: 'magenta'+    description:+      - The map describes local points of interest, relative to your cabin.+    properties: [portable, known]+  - name: peat furnace+    display:+      char: 'F'+      attr: tan+    description:+      - Fueled by peat.+    properties: [portable, known]+  - name: clay+    display:+      char: 'c'+      attr: tan+    description:+      - Can be fired in a peat furnace into a vessel.+    properties: [portable, known]+  - name: lava+    display:+      char: 'w'+      attr: lava+    description:+      - Hot liquid rock.+    properties: [known, unwalkable]+  - name: pebble+    display:+      char: '.'+      attr: tan+    description:+      - A tiny, inconsequential rock.+    properties: [known, portable]+  - name: machete+    display:+      char: '/'+      attr: cyan+    description:+      - Easily cuts through jungle overgrowth.+    properties: [known, portable]+  - name: painted plate+    display:+      char: 'o'+      attr: obsidian+    description:+      - Limited edition 1978 collectible Helix the Cat ornamental hand-painted dinner plate.+    properties: [known, portable]+  - name: oven mitts+    display:+      char: 'm'+    description:+      - Required for handling hot material.+  - name: temple+    display:+      char: 'T'+      attr: gold+    description:+      - Ancient ruins+    properties: []+  - name: jungle+    display:+      char: 'J'+      attr: jungle+    description:+      - Thick, impassible vegetation.+    properties: [known, unwalkable]+  - name: path+    display:+      char: '▒'+      attr: wood+    description:+      - A path through the jungle.+    properties: [known]+  - name: cliff+    display:+      char: '}'+      attr: lavender+    description:+      - Steep, impassible cliff.+    properties: [known, unwalkable]+  - name: warhammer+    display:+      char: 'H'+      attr: silver+    description:+      - Can break hard objects+    properties: [known, portable]+  - name: granite mountain+    display:+      char: 'A'+      attr: snow+    description:+      - Impassible rock, resistant to drilling+    properties: [known, unwalkable]+  - name: granite boulder+    display:+      char: '@'+      attr: rock+    description:+      - Impassible rock, resistant to drilling+    properties: [known, unwalkable]+  - name: mountain pass+    display:+      char: '░'+    description:+      - Open pass through the mountain+    properties: [known]+  - name: rope+    display:+      char: 'L'+    description:+      - Can be used to traverse down a cliff.+    properties: [known, portable]+  - name: hemp+    display:+      char: 'h'+      attr: plant+    description:+      - Can be used to make rope+    properties: [known, portable, growable]+  - name: flimsy board+    display:+      char: 'b'+      attr: wood+    description:+      - Board made from a soft log. Has poor rigidity.+    properties: [known, portable]+  - name: soft log+    display:+      char: 'l'+      attr: wood+    description:+      - Log made from a palm tree. A bit flexible.+    properties: [known, portable]+  - name: coconut+    display:+      char: 'c'+      attr: wood+    description:+      - Spherical, buoyant husk+    properties: [known, portable]+  - name: floating boardwalk+    display:+      char: '▒'+      attr: wood+    description:+      - Allows for crossing a swampy bog+    properties: [known]+  - name: peat+    display:+      char: 'p'+      attr: wood+    description:+      - Burnable plant material+    properties: [known, portable]+  - name: peat bog+    display:+      char: 'b'+      attr: niceBog+    description:+      - Can harvest peat from this.+    properties: [known]+  - name: secret bog+    display:+      char: '8'+      attr: bog+    description:+      - Conceals treasure from millennia past+    properties: [known, unwalkable]+  - name: swampy bog+    display:+      char: 'B'+      attr: bog+    description:+      - Impassible swamp+    properties: [known, unwalkable]+  - name: glacier+    display:+      char: 'Z'+      attr: glacier+    description:+      - Thick ice.+    properties: [known, unwalkable]+  - name: crucible+    display:+      char: 'c'+    description:+      - An empty crucible. Can carry lava.+    properties: [known, portable]+  - name: lava-filled crucible+    display:+      char: 'C'+      attr: lavaBG+    description:+      - Crucible filled with lava+    properties: [known, portable]+  - name: quarry+    display:+      char: 'Q'+      attr: quarry+    description:+      - Drill to collect pieces of rock to fill a rubble skip.+    properties: [known]+  - name: left roof+    display:+      char: '/'+      attr: wood+    description:+      - Part of a roof+    properties: [known, unwalkable]+  - name: right roof+    display:+      char: '\'+      attr: wood+    description:+      - Part of a roof+    properties: [known, unwalkable]+  - name: chair+    display:+      char: 'h'+      attr: wood+    description:+      - Standard bachelor furnishing+    properties: [known]+  - name: wall+    display:+      char: '|'+      attr: wood+    description:+      - Part of a house+    properties: [known, unwalkable]+  - name: floor+    display:+      char: '-'+      attr: wood+    description:+      - Part of a house+    properties: [known, unwalkable]+  - name: door+    display:+      char: '|'+      attr: snow+    description:+      - Entry to a house+    properties: [known]+  - name: rubble skip+    display:+      char: 'r'+    description:+      - An empty container for rubble.+    properties: [known, portable]+  - 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]+  - name: causeway+    display:+      char: '▒'+    description:+      - Reclaimed land formed by filling shallow water with rubble.+    properties: [known]+  - name: empty water tank+    display:+      char: 'k'+    description:+      - Tank with nothing in it+    properties: [known, portable]+  - name: water-filled tank+    display:+      char: 'K'+      attr: blueBG+    description:+      - Tank filled with water+    properties: [known, portable]+  - name: obsidian path+    display:+      char: '`'+      attr: obsidian+    description:+      - Smooth, glassy volcanic rock+    properties: [known]+  - name: obsidian shard+    display:+      char: 'V'+      attr: obsidian+    description:+      - Dislodged fragment of obsidian+    properties: [known, portable]+  - name: palm tree+    display:+      char: 'P'+      attr: beach+    description:+      - Palm tree.+    properties: [known, portable, growable]+recipes:+  - in:+      - [8, clay]+      - [10, peat]+    out:+      - [1, crucible]+    required:+      - [1, peat furnace]+  - in:+      - [1, lava]+      - [1, crucible]+    out:+      - [1, lava-filled crucible]+      - [1, lava]+    required:+      - [1, oven mitts]+      - [1, drill]+  - in:+      - [1, jungle]+    out:+      - [1, path]+    required:+      - [1, machete]+      - [1, drill]+  - in:+      - [30, hemp]+    out:+      - [1, rope]+  - in:+      - [1, cliff]+      - [1, rope]+    out:+      - [1, mountain pass]+    required:+      - [1, drill]+  - in:+      - [1, palm tree]+    out:+      - [2, coconut]+      - [1, soft log]+  - in:+      - [1, soft log]+    out:+      - [2, flimsy board]+  - in:+      - [1, peat bog]+    out:+      - [1, peat]+    required:+      - [1, drill]+  - in:+      - [1, secret bog]+    out:+      - [1, warhammer]+      - [1, swampy bog]+    required:+      - [1, drill]+  - in:+      - [1, obsidian path]+    out:+      - [1, obsidian shard]+    required:+      - [1, warhammer]+      - [1, drill]+  - in:+      - [1, swampy bog]+      - [2, coconut]+      - [2, flimsy board]+    out:+      - [1, floating boardwalk]+    required:+      - [1, drill]+  - in:+      - [1, water-filled tank]+    out:+      - [1, empty water tank]+  - in:+      - [1, glacier]+      - [1, lava-filled crucible]+      - [1, empty water tank]+    out:+      - [1, crucible]+      - [1, water-filled tank]+    required:+      - [1, oven mitts]+      - [1, drill]+  - in:+      - [1, lava]+      - [1, water-filled tank]+    out:+      - [1, obsidian path]+      - [1, empty water tank]+    required:+      - [1, drill]+  - in:+      - [5, iron plate]+      - [2, rope]+    out:+      - [1, rubble skip]+  - in:+      - [1, rubble skip]+      - [1, quarry]+    out:+      - [1, rubble-filled skip]+      - [1, quarry]+    required:+      - [1, drill]+  - in:+      - [1, rubble-filled skip]+      - [1, water]+    out:+      - [1, causeway]+      - [1, rubble skip]+    required:+      - [1, drill]+known: [water, sand, flower, iron mine]+seed: 0+world:+  palette:+    '.': [blank]+    '/': [blank, left roof]+    '\': [blank, right roof]+    '|': [blank, wall]+    '-': [blank, floor]+    'e': [blank, pebble]+    'd': [blank, door]+    "Ω": [blank, chair, base]+    '@': [stone, granite boulder]+    'I': [ice]+    'B': [dirt, swampy bog]+    'q': [dirt, secret bog]+    'b': [dirt, peat bog]+    'C': [dirt, cliff]+    'c': [blank, clay]+    'h': [grass, hemp]+    'J': [dirt, jungle]+    'T': [blank, temple, flowercheck]+    't': [blank, empty water tank]+    'A': [stone, granite mountain]+    'i': [stone, iron mine]+    'M': [blank, map, platecheck]+    'm': [blank, machete]+    'L': [stone, lava]+    'G': [dirt, glacier]+    'Q': [stone, quarry]+    's': [dirt, sand]+    'w': [dirt, water]+    'P': [dirt, palm tree]+    'f': [blank, flower]+  upperleft: [0, 0]+  map: |-+    .............................................................+    .............................................................+    ................................................A............+    .........AA........A.....A.......A.............AAA......A....+    ....A...AAAA....A.AAA.@.AA......AA...A........AAAAA....AAA...+    ...AAA.AAAAAA@.AAAwww@wAAAA....AAAA.AAAeA....AAAAAAA..AAAAA..+    ..AAAAAwwwwwwwAAAAAwwwAAAAA...AAAAAA...AAA..AAAAAAAAA........+    .AAAAAAAwwwwwwwwwwwwwAAAAAA@@AA.......AAAA@.........@.A...@..+    ....Awwwwwsssswwwwwwwwwwwwww@.....A..AAAAAAA.........AAA....@+    ...AAAwwwsssPsswwwwwssswwwwww....AAACAAAA....A......AAAAA....+    ..AAAAAwwsssssswwwwsssswwwwwwww@AAAA........AAA....AAAAAAA.@.+    ......@wwwsssswwwwwssswwwwww@@@AAAAAA......AALAAACAAAAAAAAA.@+    .....Awwwwwwwwwwwwwwwwwwww@@@.AAAAAAAA...AAALLAAA..........@.+    ....AAwwwwwwwwwwwwwwwwwwww@..AAAAAAAAAA.AAAALAAAAA...m..A.@.@+    ...AAAAwwwwwwwwwwwwwwwww@@@JJJJJJJJ....AAAALLAAAAAA....AAA...+    ...AAAAAwwwwwwwww@@@@@@@@..JJJJJJJJ.T.AAAAALLAAAiiAA..AAAAA..+    ..AAAAAAAsssssssss.........JJJJJJJJ...JJJJJLLJJJ....AAAAAAA..+    .AAAAAAAAsssss..............JJJJJJJJJJJJJJLLJJJ.....AAAAAAAA.+    AAAAAAAAAA....................JJJJJJJJJ.LLL.JJ.....AAAAAAAAA.+    ......@@@.......................JJJJJJ.LLL@JJ.....AAAAAAAAAAA+    .....@@@@..@@@@@...................LLLLLL@@.............@@A.@+    ...@..@@LLLLLLL@@@@..............LLLLLLLL@................@A.+    .@LLLLLLLLLLLLLLLLLL.....LLLLLLLLLLLLL@@@@..................A+    LLL@LLLLLLLLLLLLLLLLLLLLLLLLLLL@@@@@@@@@@............AA@...A@+    .@LLLLLLLLLLLLLLLLLLLLLLLLL@@@@....@@@@@@@.........@@A@A@IIAA+    .LL@LL@@.........@@@LLLLLL@@..........@@@@@@@@@@AA@@A@@AIIA.@+    LL.................@@@@@@@@............GGGGGGGGGG@@@@IIIIIIA.+    ......hhhhhhhhh..........................GGGGGGGGGGGIIIIIIII@+    ./\...hhhhhhhhh..........................GGGGGGGG@@@IIIIIAIIA+    /--\..hhhhhhhhh..........................GGGGG@@@@@@A@IIA.@A.+    d..|..hhhhhhhhh..............BBBBBBBBB...GG@@@@@@@@@@@@A@.A.A+    ----..hhhhhhhhh............BBBBBBBBBBBBBB@@@@@@@@@@@@@@@@@@@@+    ........................BBBBBBBBBBBBBBBBBBBBB..@@@@@@@@@@@@@@+    ......................BBBBBBBBBBBBBBBBBBBBBBB.....@...@@@@@@@+    .......AA....AA......bBBBBBBBBBBBBBBBBBBBBBBB.....@.@.@..@@@@+    .......AA.QQ.AA......bbbbBBBBBBBBBBBBBBBBBBBBBBBB...@....@f@.+    .......AAAAAAAA.......bbbbBBBBBBBBBBBBBBBBBBBBBBBBBB@..@....@+    ........AAAAAA.........bbbbbBBBBBBBBBBBBBBBBBBBBBBBBB@@.@.@@.+    ................../\.....bbbbbbBBBBBBBBBBBBBBBBBBBBBBB.@..@.@+    ........ccc....../--\......bbbbbbbbBBBBBBBBBBBBBBBq@BB.@.@@.@+    ......cccccccc..t|ΩMd........bbbbbbbbbbBBBBBBBBBBB@.@.@.@@...+    ........cccc.....----........................................
data/scenarios/Challenges/bucket-brigade.yaml view
@@ -179,7 +179,8 @@ known: [boulder, lignite mine] seed: 0 world:-  default: [grass]+  dsl: |+    {grass}   palette:     'B': [dirt, null, base]     '.': [dirt]
data/scenarios/Challenges/chess_horse.yaml view
@@ -34,10 +34,11 @@       char: '♚' known: [water] world:-  default: [ice, water]+  dsl: |+    {ice, water}   palette:-    '.': [grass]-    '#': [ice]+    '.': [grass, erase]+    '#': [ice, erase]     '┌': [stone, upper left corner]     '┐': [stone, upper right corner]     '└': [stone, lower left corner]
+ data/scenarios/Challenges/gopher.yaml view
@@ -0,0 +1,158 @@+version: 1+name: Gopher+author: Karl Ostmo+description: |+  Dispatch a pesky gopher+creative: false+seed: 0+objectives:+  - id: defeat_gopher+    teaser: Defeat gopher+    goal:+      - |+        A gopher (G) is defiling your immaculate garden!+      - |+        He will burrow (o) underground awhile, then pop up+        anywhere within the rectangular grassy region+        to gloat atop his "mound" of dirt for a short time.+        `drill` the "mound" while he sits to drive him+        away. Eventually you should wear down his resolve!+    condition: |+      try {+        robotnamed "gopher";+        return false;+      } {+        return true;+      }+  - teaser: Recover equipment+    prerequisite: defeat_gopher+    hidden: true+    optional: true+    goal:+      - |+        Salvage any deployed robots to get your scanners back.+    condition: |+      as base {+        sCount <- count "scanner";+        return $ sCount >= 120;+      }+robots:+  - name: base+    loc: [-1, 1]+    display:+      attr: blue+    dir: [1, 0]+    devices:+      - ADT calculator+      - 3D printer+      - branch predictor+      - treads+      - clock+      - comparator+      - workbench+      - grabber+      - dictionary+      - lambda+      - logger+      - welder+      - hearing aid+      - scanner+      - strange loop+      - drill+    inventory:+      - [120, solar panel]+      - [120, strange loop]+      - [120, scanner]+      - [120, logger]+      - [120, lambda]+      - [120, dictionary]+      - [120, grabber]+      - [120, clock]+      - [120, comparator]+      - [120, ADT calculator]+      - [120, swivel]+      - [120, branch predictor]+      - [120, drill]+      - [120, rolex]+      - [120, flower]+  - name: gopher+    system: true+    dir: [0, 1]+    display:+      char: 'G'+      invisible: false+      attr: 'wood'+    inventory:+      - [50, mound]+      - [1, toolkit]+      - [1, serenity]+    program: |+      run "data/scenarios/Challenges/_gopher/gopher.sw"+entities:+  - name: mound+    display:+      char: 'M'+      attr: wood+    description:+      - An unsightly pile of dirt+    properties: [known]+  - name: serenity+    display:+      char: 's'+      attr: silver+    description:+      - Peace of mind after having driven away the gopher.+    properties: [known]+  - name: swivel+    display:+      char: 's'+      attr: gold+    capabilities: [turn]+    description:+      - Allows a robot to "turn" but not "move".+    properties: [known, portable]+  - name: uranium+    display:+      char: 'U'+      attr: silver+    description:+      - Unearthed by industrious gophers.+    properties: [known, portable]+recipes:+  - in:+      - [1, mound]+    out:+      - [1, uranium]+    required:+      - [1, drill]+solution: |+   run "scenarios/Challenges/_gopher/solution.sw"+known: []+world:+  upperleft: [-1, 1]+  offset: false+  palette:+    'x': [dirt]+    '.': [grass]+    'g': [dirt, null, gopher]+  map: |+    xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    x............................x+    xxxxxxxxxxxxxxxxxxxxxxxxxxxxxg
+ data/scenarios/Challenges/hackman.yaml view
@@ -0,0 +1,309 @@+version: 1+name: Hackman+author: Karl Ostmo+description: |+  Feed Hackman caffeine pellets+creative: false+attrs:+  - name: ghost1+    fg: "#ff0000"+  - name: ghost2+    fg: "#ffb8ff"+  - name: ghost3+    fg: "#00ffff"+  - name: ghost4+    fg: "#ffb852"+  - name: strawberry+    fg: "#ff0000"+objectives:+  - teaser: Get pellets+    goal:+      - |+        Pick up all of the caffeine "pellets" so that Hackman can write more code.+      - |+        Pay no mind to the colorful ghosts meandering about. That is, unless+        you are feeling generous with your "donuts"...+      - |+        Can you find all of the secret objectives?+    condition: |+      as base {+        pcount <- count "pellet";+        donut_count <- count "donut";+        return $ pcount >= 181;+      };+  - id: donut_given+    teaser: Give to ghost+    hidden: true+    optional: true+    goal:+      - |+        Give a ghost a donut.+    condition: |+      def anyHasPowerup = \n.+          let ghost_name = "ghost" ++ format n in+          ghost <- robotnamed ghost_name;+          hasPowerup <- as ghost {+              has "donut";+          };+          +          if hasPowerup {+              return true;+          } {+              if (n > 1) {+                  anyHasPowerup $ n - 1;+              } {+                  return false;+              }+          }+          end;++      anyHasPowerup 4;+  - teaser: Interloper+    hidden: true+    optional: true+    goal:+      - |+        Invade the ghost den+    condition: |+      loc <- as base {+        whereami;+      };+      return $ loc == (0, 0);+  - teaser: World wrap+    hidden: true+    optional: true+    goal:+      - |+        Be teleported+    condition: |+      r <- robotnamed "teleporter";+      loc <- as r {+        has "bit (0)"+      };+  - teaser: Balanced diet+    hidden: true+    optional: true+    goal:+      - |+        Get the strawberry+    condition: |+      as base {+        has "strawberry";+      };+  - teaser: Magnanimity+    hidden: true+    optional: true+    prerequisite: donut_given+    goal:+      - |+        Give all ghosts a donut.+    condition: |+      def allHasPowerup = \n.+          let ghost_name = "ghost" ++ format n in+          ghost <- robotnamed ghost_name;+          hasPowerup <- as ghost {+              has "donut";+          };+          +          if hasPowerup {+              if (n > 1) {+                  allHasPowerup $ n - 1;+              } {+                  return true;+              }+          } {+              return false;+          }+          end;++      allHasPowerup 4;+robots:+  - name: base+    display:+      orientationMap:+        east: 'c'+        north: 'u'+        west: 'ↄ'+        south: 'n'+      char: 'U'+      attr: gold+    dir: [1, 0]+    devices:+      - ADT calculator+      - antenna+      - bitcoin+      - branch predictor+      - clock+      - compass+      - comparator+      - counter+      - dictionary+      - drill+      - grabber+      - lambda+      - lodestone+      - logger+      - mirror+      - net+      - scanner+      - strange loop+      - treads+      - workbench+  - name: teleporter+    dir: [0, 1]+    system: true+    display:+      invisible: true+      char: 'T'+    program: |+      run "scenarios/Challenges/_hackman/teleporter.sw"+  - name: ghost1+    dir: [0, 1]+    system: true+    display:+      invisible: false+      char: '∩'+      attr: ghost1+    program: |+      run "scenarios/Challenges/_hackman/ghost.sw"+  - name: ghost2+    dir: [0, 1]+    system: true+    display:+      invisible: false+      char: '∩'+      attr: ghost2+    program: |+      run "scenarios/Challenges/_hackman/ghost.sw"+  - name: ghost3+    dir: [0, 1]+    system: true+    display:+      invisible: false+      char: '∩'+      attr: ghost3+    program: |+      run "scenarios/Challenges/_hackman/ghost.sw"+  - name: ghost4+    dir: [0, 1]+    system: true+    display:+      invisible: false+      char: '∩'+      attr: ghost4+    program: |+      run "scenarios/Challenges/_hackman/ghost.sw"+  - name: fruit_maker+    dir: [0, 1]+    system: true+    display:+      invisible: true+      char: 'f'+    inventory:+      - [1, strawberry]+    program: |+      run "scenarios/Challenges/_hackman/fruit_maker.sw"+entities:+  - name: pellet+    display:+      char: '•'+      attr: silver+    description:+      - A caffeine pellet.+      - Helps Hackman produce more code.+    properties: [known, portable]+  - name: donut+    display:+      char: 'o'+      attr: gold+    description:+      - Breakfast of champions.+      - Fancied by ghosts. Will you share?+    properties: [known, portable]+  - name: den key+    display:+      char: 'k'+      attr: gold+    description:+      - Opens a gate+    properties: [known, portable]+  - name: strawberry+    display:+      char: 'v'+      attr: strawberry+    description:+      - A tart berry+      - Possessing this fruit gives you great satisfaction.+    properties: [known, portable]+  - name: gate+    display:+      char: '='+    description:+      - A gate.+    properties: [known, unwalkable]+  - name: wall+    display:+      char: '▒'+    description:+      - A wall.+    properties: [known, unwalkable]+recipes:+  - in:+    - [181, "pellet"]+    out:+    - [1, "den key"]+  - in:+    - [1, "den key"]+    - [1, "gate"]+    out:+    - [1, "den key"]+    required:+    - [1, drill]+solution:+  run "scenarios/Challenges/_hackman/solution.sw"+known: []+seed: 0+world:+  palette:+    'B': [blank]+    'Ω': [blank, null, base]+    'f': [blank, null, fruit_maker]+    'a': [blank, null, ghost1]+    'b': [blank, null, ghost2]+    'c': [blank, null, ghost3]+    'd': [blank, null, ghost4]+    'T': [blank, null, teleporter]+    '.': [blank, pellet]+    '*': [blank, donut]+    'x': [blank, wall]+    '=': [blank, gate]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-11, 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
− data/scenarios/Challenges/hanoi-count.sw 
@@ -1,62 +0,0 @@-def repeat = \c. force c; repeat c end;--def i2e = \i.-  if (i == 2) { "two" } {-  if (i == 3) { "three" } {-  fail $ "Fatal error: There should be only 2 or 3 entities placed at any time: " ++ format i-  }}-end;--def cscan = \d.-  s <- scan d;-  if (s == inl ()) {return 0} {return 1}-end;--def count_column =-  i <- cscan north;-  j <- cscan down;-  k <- cscan south;-  // log "one column";-  // wait 8;-  // log (format i);-  // wait 8;-  // log (format j);-  // wait 8;-  // log (format k);-  // wait 8;-  return (i + j + k)-end;---repeat {-    sum <- as self {-        // left column-        teleport self (-2,-2);-        x <- count_column;-        // middle column-        teleport self (0,-2);-        y <- count_column;-        // right column-        teleport self (2,-2);-        z <- count_column;-        // DEBUG-        // log "all columns";-        // wait 8;-        // log (format x);-        // wait 8;-        // log (format y);-        // wait 8;-        // log (format z);-        return $ i2e (x + y + z)-    };-    //let sum = i2e (x + y + z) in-    teleport self (0,-6);-    counted <- scan down;-    //wait 8;-    //log (format counted);-    case counted (\e.-        fail $ "Fatal error: there should always be a count entity at (0,-6)! " ++ format e ++ " " ++ format counted-    ) (\e.-        if (e == sum) {} {swap sum; return ()}-    )-}
− data/scenarios/Challenges/hanoi-increasing.sw 
@@ -1,48 +0,0 @@-// if-//  0. all (but max 3) disks in my column are sorted-// then-//  - place "OK"-// else-//  - try to grab "OK"-def null = inl () end;-def repeat = \c. c; repeat c end;-def toI = \e.-  if (e == "one"   || e == "blocked one")   {1} {-  if (e == "two"   || e == "blocked two")   {2} {-  if (e == "three" || e == "blocked three") {3} {-  fail $ "There should be no other placeable entity: " ++ e-  }}}-end;-def f = \x.\y.-  case x (\_. false) (\i.-    case y (\_. false) (\j.-      let xi = toI i in-      let yj = toI j in-      xi > yj-    )-  )-end;--w <- whereami;-// the middle of the column-let a = (fst w, snd w + 3) in-repeat (-    o <- as self {-        teleport self a;-        x <- scan south;-        y <- scan down;-        z <- scan north;-        if (z == null) {-          if (y == null) {-            return true-          } {-            return $ f x y-          }-        } {-          return $ f x y && f y z-        }-    };-    try {-        if o {place "OK"} {grab; return ()}-    } {}-)
− data/scenarios/Challenges/hanoi-invariant.sw 
@@ -1,64 +0,0 @@-def repeat = \c. c; repeat c end;-def isUnlocked = \e. e == "one" || e == "two" || e == "three" end;-def unlock = \e.-  if (e == "blocked one")   {"one"}   {-  if (e == "blocked two")   {"two"}   {-  if (e == "blocked three") {"three"} {-  fail $ "Can not unlock: " ++ e-  }}}-end;--repeat (-me <- scan down;-case me (\_. return ()) (\e.-// if-//  0. I stand on unlocked X-//  1. place north of me is NOT empty-//     or-//     the count of all placed is NOT 3-// then-//  - lock X-if (isUnlocked e)-{-    northFullOrAllPlaced <- as self {-      mn <- scan north;-      case mn (\_.-        teleport self (0,-6);-        allPlaced <- ishere "three";-        return (not allPlaced)-      ) (\_.-        return true-      );-    };-    if northFullOrAllPlaced {-      swap ("blocked " ++ e); return ()-    } {}-}-// if-//  0. I stand on locked X-//  1. place north of me is empty-//  2. all disks are placed-//  3. other columns are sorted (check "OK")-// then-//  - unlock X-{-    mn <- scan north;-    case mn (\_.-      wait 16;-      allPlaced <- as self {-        teleport self (0,-6);-        ishere "three"-      };-      allSorted <- as self {-        teleport self (-2,-5);-        o1 <- ishere "OK";-        teleport self (0,-5);-        o2 <- ishere "OK";-        teleport self (2,-5);-        o3 <- ishere "OK";-        return (o1 && o2 && o3)-      };-      if (allPlaced && allSorted) {swap (unlock e); return ()} {}-    ) (\_. return ())-}-))
− data/scenarios/Challenges/hanoi-solution.sw 
@@ -1,64 +0,0 @@-def until = \p. \c. q <- p; if q {} {c; until p c} end;-def rep = \n. \c. if (n == 0) {} {c; rep (n-1) c} end;--def ifC = \p. \t. \e. res <- p; if res t e end;--def orC = \c1. \c2.-  b1 <- c1; b2 <- c2; return (b1 || b2)-end;--def somethingHere =-  res <- scan down;-  return (res != inl ())-end;--def fwdToThing = until blocked move end;--def fwdToBlank =-  move;-  until (orC blocked somethingHere) move;-  ifC somethingHere {turn back; move; turn back} {}-end;--def goBack = turn back; fwdToBlank; turn back end;--def getDisk =-  fwdToThing;-  d <- grab;-  goBack;-  return d-end;--def placeDisk = \d.-  fwdToBlank;-  place d;-  goBack-end;--def moveToCol = \w.\x.-  if (w < x) { turn east; rep (x - w) move }-  { if (w > x) { turn west; rep (w - x) move } {} };-  turn south-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-  = \n. \o. \a. \b. \c.-  if (n == 0) {return o}-  {-    o_new <- hanoi (n-1) o a c b;-    moveToCol o_new a;-    wait 8;-    d <- getDisk;-    moveToCol a c;-    placeDisk d;-    hanoi (n-1) c b a c;-  }-end;--hanoi 3 0 (-2) 0 2
data/scenarios/Challenges/hanoi.yaml view
@@ -17,7 +17,7 @@       z <- ishere "blocked three";       return (x && y && z) solution: |-  run "scenarios/Challenges/hanoi-solution.sw"+  run "scenarios/Challenges/_hanoi/hanoi-solution.sw" robots:   - name: base     dir: [0,-1]@@ -60,7 +60,7 @@       //  1. place north of me is NOT empty       // then       //  - lock X-      run "scenarios/Challenges/hanoi-invariant.sw"+      run "scenarios/Challenges/_hanoi/hanoi-invariant.sw"   - name: increasing     dir: [0,0]     system: true@@ -75,7 +75,7 @@       //  - place "OK"       // else       //  - try to grab "OK"-      run "scenarios/Challenges/hanoi-increasing.sw"+      run "scenarios/Challenges/_hanoi/hanoi-increasing.sw"   - name: count     dir: [0,0]     system: true@@ -88,7 +88,7 @@       // count all entities placed in columns       // the final count should be either 2 or 3       // place "two" or "three" at x=0 y=-6-      run "scenarios/Challenges/hanoi-count.sw"+      run "scenarios/Challenges/_hanoi/hanoi-count.sw" entities:   - name: bottom tee     display:@@ -155,7 +155,8 @@   - blocked two   - blocked three world:-  default: [grass, null]+  dsl: |+    {grass}   palette:     ',': [grass]     '_': [stone]
data/scenarios/Challenges/ice-cream.yaml view
@@ -6,7 +6,9 @@ creative: false seed: 0 objectives:-  - goal:+  - id: give_cone+    teaser: Give a cone+    goal:       - |         Congratulations on the grand opening of your new ice cream shop.         You have advertised: "All you can eat, for 1 bitcoin!"@@ -22,12 +24,14 @@     condition: |       customer <- robotnamed "customer";       as customer {has "cone"};-  - goal:+  - teaser: Complete the order+    goal:       - |         `give` the customer exactly what they request.       - |         Perhaps there is something else around the shop that can assist with         preparing the order...+    prerequisite: give_cone     condition: |       as base {         has "bitcoin";@@ -202,7 +206,8 @@       - [1, scoop] known: [] world:-  default: [grass]+  dsl: |+    {grass}   upperleft: [0, 0]   offset: false   palette:
+ data/scenarios/Challenges/lights-out.yaml view
@@ -0,0 +1,162 @@+version: 1+name: Lights Out+author: Karl Ostmo+description: |+  Turn off all of the lights+creative: false+attrs:+  - name: light-on+    fg: "#cccc22"+  - name: light-off+    fg: "#333355"+objectives:+  - teaser: Extinguish lights+    goal:+      - |+        `drill` a light to toggle it and its four direct neighbors+        between "off" and "on".+      - |+        The puzzle is won when all lights have been extinguished.+    condition: |+      def advanceRow =+          curLoc <- whereami;+          teleport self (0, snd curLoc - 1);+          end;++      def isRowDark = \n.+          if (n > 0) {+              onHere <- ishere "on";+              if onHere {+                  return false;+              } {+                  move;+                  isRowDark $ n - 1;+              }+          } {+              return true;+          }+          end;++      def areAllOff = \rowWidth. \n.+          if (n > 0) {+              rowDark <- isRowDark rowWidth;+              if rowDark {+                  advanceRow;+                  areAllOff rowWidth $ n - 1;+              } {+                  return false;+              }+          } {+              return true;+          }+          end;++      def check =+          setupComplete <- has "flower";+          if setupComplete {+              teleport self (0, 0);+              turn east;+              areAllOff 5 5;+          } {return false};+          end;++      j <- robotnamed "judge";+      as j {+        check;+      };+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - antenna+      - branch predictor+      - clock+      - comparator+      - compass+      - counter+      - dictionary+      - dozer blade+      - drill+      - hearing aid+      - lambda+      - logger+      - mirror+      - scanner+      - strange loop+      - string+      - treads+      - welder+      - workbench+  - name: judge+    system: true+    dir: [1, 0]+    display:+      invisible: true+    program: |+      run "scenarios/Challenges/_lights-out/assistant.sw";+solution: |+   run "scenarios/Challenges/_lights-out/solution.sw"+entities:+  - name: pending-off+    display:+      char: '*'+      attr: light-off+    description:+      - Light that is being turned off+    properties: [known]+  - name: pending-on+    display:+      char: '*'+      attr: light-on+    description:+      - Light that is being turned on+    properties: [known]+  - name: "off"+    display:+      char: 'x'+      attr: light-off+    description:+      - A light that is off+    properties: [known]+  - name: "on"+    display:+      char: 'o'+      attr: light-on+    description:+      - A light that is on+    properties: [known]+recipes:+  - in:+      - [1, "off"]+    out:+      - [1, "pending-on"]+    required:+      - [1, drill]+    time: 0+  - in:+      - [1, "on"]+    out:+      - [1, pending-off]+    required:+      - [1, drill]+    time: 0+known: []+world:+  upperleft: [-1, 1]+  offset: false+  palette:+    B: [blank, null, base]+    z: [blank, null, judge]+    '.': [blank]+    'x': [blank, "off"]+    'o': [blank, "on"]+  map: |+    B......+    .xxxxx.+    .xxxxx.+    .xxxxx.+    .xxxxx.+    .xxxxx.+    z......+
+ data/scenarios/Challenges/maypole.yaml view
@@ -0,0 +1,120 @@+version: 1+name: Maypole+author: Karl Ostmo+description: |+  Circle the maypole+creative: false+seed: 0+attrs:+  - name: maypole0+    fg: "#ff0000"+  - name: maypole1+    fg: "#ffff00"+  - name: maypole2+    fg: "#00ffff"+  - name: maypole3+    fg: "#00ff00"+objectives:+  - id: circle_maypole+    teaser: Around you go!+    goal:+      - |+        Go around the maypole several times counter-clockwise.+    condition: |+      monitor <- robotnamed "monitor";+      as monitor {has "dizzy"};+robots:+  - name: base+    dir: [0, 1]+    devices:+      - branch predictor+      - treads+      - antenna+      - calculator+      - clock+      - comparator+      - workbench+      - grabber+      - dictionary+      - lambda+      - logger+      - welder+      - hearing aid+      - scanner+      - strange loop+  - name: monitor+    system: true+    dir: [0, 1]+    display:+      invisible: true+    inventory:+      - [1, bitcoin]+      - [1, maypole 0]+      - [1, maypole 1]+      - [1, maypole 2]+      - [1, maypole 3]+    program: |+      run "scenarios/Challenges/_maypole/monitor.sw"+solution: |+   run "scenarios/Challenges/_maypole/solution.sw"+entities:+  - name: dizzy+    display:+      char: '@'+    description:+      - A disorienting vestibular affliction+    properties: [portable]+  - name: maypole+    display:+      char: 'M'+    description:+      - A tall, colorful pole.+    properties: [known, unwalkable]+  - name: maypole 0+    display:+      char: 'M'+      attr: maypole0+    description:+      - A tall, colorful pole.+    properties: [known, unwalkable]+  - name: maypole 1+    display:+      char: 'M'+      attr: maypole1+    description:+      - A tall, colorful pole.+    properties: [known, unwalkable]+  - name: maypole 2+    display:+      char: 'M'+      attr: maypole2+    description:+      - A tall, colorful pole.+    properties: [known, unwalkable]+  - name: maypole 3+    display:+      char: 'M'+      attr: maypole3+    description:+      - A tall, colorful pole.+    properties: [known, unwalkable]+known: [bitcoin]+world:+  dsl: |+    {grass}+  upperleft: [0, 0]+  offset: false+  palette:+    'B': [grass, null, base]+    '.': [grass]+    'M': [grass, maypole, monitor]+  map: |+    ................+    ................+    ................+    .......M........+    ................+    .........B......+    ................+    ................+
data/scenarios/Challenges/teleport.yaml view
@@ -56,15 +56,16 @@       ); known: [water, wavy water, flower, tree] world:-  default: [ice, water]+  dsl: |+    {ice, water}   palette:     ',': [ice, water]     ' ': [ice, water]     '~': [ice, wavy water]     '*': [grass, flower]     'T': [grass, tree]-    '.': [grass]-    '_': [stone]+    '.': [grass, erase]+    '_': [stone, erase]     '┌': [stone, upper left corner]     '┐': [stone, upper right corner]     '└': [stone, lower left corner]
data/scenarios/Challenges/wolf-goat-cabbage.yaml view
@@ -98,7 +98,6 @@ known: [water, boulder] seed: 0 world:-  default: [blank]   palette:     'A': [stone, boulder]     'B': [stone, boulder, base]
data/scenarios/Challenges/word-search.yaml view
@@ -6,16 +6,6 @@ seed: 2 creative: false objectives:-  - id: prepare_playfield-    teaser: Wait patiently-    goal:-      - |-        First, wait for the playfield to be set up,-        and then your path forward will be cleared.-      - |-        You can speed this process up with CTRL+x.-    condition: |-      as base {knows "capital C"};   - goal:       - Use the `drill` command (e.g. "drill down" when on top of the         intended letter) to mark the sequence of letters that@@ -25,7 +15,6 @@         leftward or rightward direction,         or vertically in either the upward or downward direction.         Diagonal appearances are not valid.-    prerequisite: prepare_playfield     condition: |       /**       Algorithm:@@ -360,7 +349,8 @@       - [1, highlighter] known: [boulder] world:-  default: [dirt]+  dsl: |+    {dirt}   upperleft: [0, 0]   offset: false   palette:
data/scenarios/Fun/GoL.yaml view
@@ -58,7 +58,8 @@         waitUntil (t <- time; return (mod t 0x20 == 0))       ) world:-  default: [ice]+  dsl: |+    {ice}   palette:     'o': [ice, rock, cell]     '.': [ice, null, cell]
data/scenarios/Fun/logo-burst.yaml view
@@ -56,7 +56,6 @@    known: [boulder, tree, water, wavy water] world:-  default: [blank]   upperleft: [0, 0]   offset: false   palette:
+ data/scenarios/Mechanics/00-ORDER.txt view
@@ -0,0 +1,1 @@+active-trapdoor.yaml
+ data/scenarios/Mechanics/_active-trapdoor/gate.sw view
@@ -0,0 +1,31 @@+/**+This mechanic operates by polling.+Note that the polling is not naturally "throttled" since+the 'whereami' command is intangible (has zero duration).+So we insert 'wait' commands to be performance-friendly.+*/+def waitAndGate = \myCoords. \armed.+  basePos <- as base {whereami};++  if (basePos == myCoords) {+    if armed {} {+      // Warn the player that they have tripped the trap+      say "ka-chunk"+    };+    // The trapdoor is now armed. Wait to spring it.+    wait 1; // Throttle the polling+    waitAndGate myCoords true;+  } {+    if (armed) {+      place "boulder";+      // recursion ends+    } {+      // Wait to arm the trapdoor+      wait 1; // Throttle the polling+      waitAndGate myCoords false+    };+  };+  end;++myPos <- whereami;+waitAndGate myPos false;
+ data/scenarios/Mechanics/_active-trapdoor/solution.sw view
@@ -0,0 +1,4 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++doN 10 move;+grab;
+ data/scenarios/Mechanics/active-trapdoor.yaml view
@@ -0,0 +1,80 @@+version: 1+name: Active trapdoor+author: Karl Ostmo+description: |+  This gate closes once you have passed.++  This is an "active" trapdoor in the sense that a system robot+  continuously monitors its status and operates it.+  It is in contrast with a sokoban-style trapdoor+  that is "passive" in its operation.+creative: false+objectives:+  - goal:+      - Grab the flower.+    condition: |+      as base {has "flower"}+robots:+  - name: base+    display:+      char: 'ω'+      attr: robot+    dir: [0, 1]+    devices:+      - treads+      - 3D printer+      - ADT calculator+      - branch predictor+      - clock+      - comparator+      - counter+      - dictionary+      - grabber+      - hearing aid+      - lambda+      - logger+      - mirror+      - net+      - scanner+      - strange loop+      - string+      - workbench+    inventory:+      - [1, treads]+  - name: gate+    system: true+    dir: [0, 1]+    display:+      invisible: true+    inventory:+      - [1, boulder]+    program: |+      run "scenarios/Mechanics/_active-trapdoor/gate.sw"+solution: |+  run "scenarios/Mechanics/_active-trapdoor/solution.sw"+known: [water, boulder, flower]+seed: 0+world:+  dsl: |+    {stone, water}+  upperleft: [0, 0]+  palette:+    '@': [stone, boulder]+    '.': [grass, erase]+    G: [stone, erase, gate]+    Ω: [grass, erase, base]+    f: [grass, flower]+  map: |+    .....+    ..f..+    .....+    @@.@@+    .@.@.+    .@.@.+    .@G@.+    .@.@.+    .@.@.+    @@.@@+    .....+    ..Ω..+    .....
data/scenarios/Speedruns/curry.yaml view
@@ -33,5 +33,7 @@       - [50, scanner]       - [5, toolkit] world:-  seed: null   offset: true+  scrollable: false+  dsl: |+    "classic"
data/scenarios/Speedruns/forester.yaml view
@@ -33,5 +33,7 @@       - [50, scanner]       - [5, toolkit] world:-  seed: null   offset: true+  scrollable: false+  dsl: |+    "classic"
data/scenarios/Speedruns/mithril.yaml view
@@ -33,5 +33,7 @@       - [50, scanner]       - [5, toolkit] world:-  seed: null   offset: true+  scrollable: false+  dsl: |+    "classic"
data/scenarios/Testing/00-ORDER.txt view
@@ -12,6 +12,7 @@ 562-lodestone.yaml 378-objectives.yaml 684-swap.yaml+687-watch-command.yaml 699-movement-fail 858-inventory 795-prerequisite@@ -22,4 +23,22 @@ 961-custom-capabilities.yaml 956-GPS.yaml 958-isempty.yaml+1007-use-command.yaml+1024-sand.yaml 1034-custom-attributes.yaml+1140-detect-command.yaml+1157-drill-return-value.yaml+1171-sniff-command.yaml+1171-chirp-command.yaml+1171-resonate-command.yaml+1207-scout-command.yaml+1218-stride-command.yaml+1234-push-command.yaml+1256-halt-command.yaml+1295-density-command.yaml+1138-structures+1320-world-DSL+1356-portals+144-subworlds+1379-single-world-portal-reorientation.yaml+1399-backup-command.yaml
+ data/scenarios/Testing/1007-use-command.yaml view
@@ -0,0 +1,81 @@+version: 1+name: The Use command+creative: false+description: Open a gate+objectives:+  - goal:+      - Grab the flower on the other side of the gate.+    condition: |+      as base {has "flower"}+solution: |+  move;+  k <- grab;+  equip k;+  use k forward;+  move;+  move;+  grab;+robots:+  - name: base+    dir: [1,0]+    display:+      char: Ω+      attr: robot+    devices:+      - ADT calculator+      - grabber+      - logger+      - 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]+recipes:+  - in:+      - [1, closed gate]+    out:+      - [1, open gate]+    required:+      - [1, gate key]+known: [flower]+world:+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '#': [grass, fence]+    '|': [grass, closed gate]+    '*': [grass, flower]+    'k': [grass, gate key]+  upperleft: [0, 0]+  map: |+   ......+   ..###.+   Ωk|*#.+   ..###.+   ......
+ data/scenarios/Testing/1024-sand.yaml view
@@ -0,0 +1,45 @@+version: 1+name: Sand from drilling+description: |+  Sand is no longer infinite, but can be obtained by drilling rocks,+  which occasionally drop from drilling in mines.+  https://github.com/swarm-game/swarm/pull/1024+objectives:+  - condition: |+      as base {n <- count "sand"; return (n >= 32)}+    goal:+      - Obtain 32 sand.+solution: |+  def forever = \c. c ; forever c end+  def while = \t. \b.+    x <- t;+    if x {b; while t b} {}+  end+  def drill_for_sand =+    move;+    drill down;+    turn back; move; turn back;+    while (has "rock") (+      place "rock"; drill down+    )+  end;++  forever drill_for_sand+robots:+  - name: base+    dir: [1,0]+    devices:+      - dictionary+      - logger+      - branch predictor+      - harvester+      - drill+      - solar panel+      - treads+world:+  palette:+    '>': [grass, null, base]+    'Å': [stone, copper mine]+  upperleft: [0,0]+  map: |+    >Å
data/scenarios/Testing/1034-custom-attributes.yaml view
@@ -22,8 +22,12 @@     fg: "#ff0000"     bg: ffff00   - name: cyanOnMagenta-    fg: 00ffff+    fg: "#00ffff     bg: "#ff00ff"+  - name: greenForeground+    fg: "#00ff00"+  - name: blueBackround+    bg: "#0000ff"   - name: italicAndUnderline     style:       - Italic@@ -82,6 +86,69 @@     description:       - c7     properties: [known]+  - name: color1f+    display:+      char: '█'+      attr: rainbow1+    description:+      - c1+    properties: [known]+  - name: color2f+    display:+      char: '█'+      attr: rainbow2+    description:+      - c2+    properties: [known]+  - name: color3f+    display:+      char: '█'+      attr: rainbow3+    description:+      - c3+    properties: [known]+  - name: color4f+    display:+      char: '█'+      attr: rainbow4+    description:+      - c4+    properties: [known]+  - name: color5f+    display:+      char: '█'+      attr: rainbow5+    description:+      - c5+    properties: [known]+  - name: color6f+    display:+      char: '█'+      attr: rainbow6+    description:+      - c6+    properties: [known]+  - name: color7f+    display:+      char: '█'+      attr: rainbow7+    description:+      - c7+    properties: [known]+  - name: greenForeground+    display:+      char: 'G'+      attr: greenForeground+    description:+      - Green foreground, no background defined+    properties: [known]+  - name: blueBackround+    display:+      char: 'B'+      attr: blueBackround+    description:+      - Blue background, no foreground defined+    properties: [known]   - name: redYellow     display:       char: 'R'@@ -112,7 +179,6 @@     properties: [known] robots: [] world:-  default: [blank]   palette:     '.': [blank]     '1': [blank, color1]@@ -122,13 +188,22 @@     '5': [blank, color5]     '6': [blank, color6]     '7': [blank, color7]+    'a': [blank, color1f]+    'b': [blank, color2f]+    'c': [blank, color3f]+    'd': [blank, color4f]+    'e': [blank, color5f]+    'f': [blank, color6f]+    'g': [blank, color7f]+    'y': [blank, blueBackround]+    'z': [blank, greenForeground]     'R': [blank, redYellow]     'C': [blank, cyanMagenta]     'I': [blank, italicUnderline]     'B': [blank, boldStrikethrough]   upperleft: [0, 0]   map: |--    .1234567..R.....II.-    .1234567..R........-    .1234567.....C..BB.-    .1234567.....C.....+    .1234567..Rzzy...IIy+    .1234567y.R.z.......+    .abcdefg......C..BBz+    .abcdefgyy.yy..Cz.z.
+ data/scenarios/Testing/1138-structures/00-ORDER.txt view
@@ -0,0 +1,3 @@+nested-structure.yaml+flip-and-rotate.yaml+sibling-precedence.yaml
+ data/scenarios/Testing/1138-structures/flip-and-rotate.yaml view
@@ -0,0 +1,87 @@+version: 1+name: Structure placement (flip, rotation, masking)+description: |+  Define a structure and place it in the map.+robots:+  - name: base+    loc: [11, 0]+    dir: [1, 0]+known: [flower, bit (0), bit (1)]+world:+  palette:+    '.': [grass]+    '*': [stone, flower]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  structures:+    - name: tetromino+      structure:+        mask: '.'+        palette:+          '0': [stone, bit (0)]+          '1': [stone, bit (1)]+        map: |+          10..+          10..+          10..+          10..+          1000+          1111+  placements:+    - src: tetromino+      offset: [3, -2]+    - src: tetromino+      offset: [9, -2]+      orient:+        up: east+    - src: tetromino+      offset: [17, -2]+      orient:+        up: south+    - src: tetromino+      offset: [23, -2]+      orient:+        up: west+    - src: tetromino+      offset: [3, -9]+      orient:+        up: north+        flip: true+    - src: tetromino+      offset: [9, -9]+      orient:+        up: east+        flip: true+    - src: tetromino+      offset: [17, -9]+      orient:+        up: south+        flip: true+    - src: tetromino+      offset: [23, -9]+      orient:+        up: west+        flip: true+  map: |+    ┌──────────────────────────────┐+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    └──────────────────────────────┘
+ data/scenarios/Testing/1138-structures/nested-structure.yaml view
@@ -0,0 +1,81 @@+version: 1+name: Structure placement (nested)+description: |+  Define a structure and place it in the map.+robots:+  - name: base+    loc: [11, 0]+    dir: [1, 0]+known: [tree, flower, bit (0), bit (1)]+world:+  palette:+    '.': [grass]+    '*': [stone, flower]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  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]+                '┌': [stone, upper left corner]+                '┐': [stone, upper right corner]+                '└': [stone, lower left corner]+                '┘': [stone, lower right corner]+              placements:+                - src: bitpair+                  offset: [1, 0]+              map: |+                ┌.┐+                └.┘+        placements:+          - src: minibox+            offset: [0, -1]+          - src: minibox+            offset: [3, -1]+        map: |+          TTTTTT+          T.T.T.+          .T.T.T+          TTTTTT+  placements:+    - src: bigbox+      offset: [1, -1]+    - src: bigbox+      offset: [7, -5]+    - src: bitpair+      offset: [1, -7]+    - src: bitpair+      offset: [2, -7]+    - src: bitpair+      offset: [3, -7]+  map: |+    ┌────────────┐+    │*..*..*..*..│+    │.*..*..*..*.│+    │..*..*..*..*│+    │*..*..*..*..│+    │.*..*..*..*.│+    │..*..*..*..*│+    │*..*..*..*..│+    │.*..*..*..*.│+    └────────────┘
+ data/scenarios/Testing/1138-structures/sibling-precedence.yaml view
@@ -0,0 +1,88 @@+version: 1+name: Structure placement (sibling precedence)+description: |+  Define a structure and place it in the map.+robots:+  - name: base+    loc: [11, 0]+    dir: [1, 0]+known: [water, sand]+world:+  palette:+    '.': [grass]+  upperleft: [-1, 1]+  structures:+    - name: huge rectangle+      structure:+        palette:+          'x': [blank, water]+        map: |+          xxxxxxxxxx+          xxxxxxxxxx+          xxxxxxxxxx+          xxxxxxxxxx+          xxxxxxxxxx+          xxxxxxxxxx+          xxxxxxxxxx+          xxxxxxxxxx+          xxxxxxxxxx+          xxxxxxxxxx+    - name: big rectangle+      structure:+        palette:+          'x': [blank, sand]+        map: |+          xxxxxxxx+          xxxxxxxx+          xxxxxxxx+          xxxxxxxx+          xxxxxxxx+          xxxxxxxx+          xxxxxxxx+          xxxxxxxx+    - name: medium rectangle+      structure:+        palette:+          'x': [dirt]+        map: |+          xxxxxx+          xxxxxx+          xxxxxx+          xxxxxx+          xxxxxx+          xxxxxx+    - name: small rectangle+      structure:+        palette:+          'x': [ice]+        map: |+          xxxx+          xxxx+          xxxx+          xxxx+    - name: tiny rectangle+      structure:+        palette:+          'x': [stone]+        map: |+          xx+          xx+  placements:+    - src: tiny rectangle+    - src: small rectangle+    - src: medium rectangle+    - src: big rectangle+    - src: huge rectangle+  map: |+    ............+    ............+    ............+    ............+    ............+    ............+    ............+    ............+    ............+    ............+    ............+    ............
+ data/scenarios/Testing/1140-detect-command.yaml view
@@ -0,0 +1,52 @@+version: 1+name: Detect test+creative: true+description: Locate a tree using the detector+objectives:+  - goal:+      - grab a tree.+    condition: |+      as base {has "tree"}+solution: |+  def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+  loc <- detect "tree" ((0, 0), (6, 4));+  case loc return (\delta.+    let xDelta = fst delta in+    let yDelta = snd delta in+    if (yDelta < 0) {turn south;} {};+    doN yDelta move; // y-movement+    if (xDelta < 0) {turn west;} {turn east};+    doN xDelta move; // x-movement+    grab;+    return ();+  );+robots:+  - name: base+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - string+      - grabber+      - compass+      - treads+      - ADT calculator+known: []+world:+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    'T': [grass, tree]+  upperleft: [-4, 4]+  map: |+   .........+   .........+   .........+   .........+   ......T..+   .........+   .........+   .Ω.......+   .........
+ data/scenarios/Testing/1157-drill-return-value.yaml view
@@ -0,0 +1,58 @@+version: 1+name: Drill return value test+description: Drill a custom recipe, use the return value.+objectives:+  - goal:+      - Drill the adjacent entity, place the result where you are.+    condition: |+      as base {ishere "gumball"};+solution: |+  out <- drill forward;+  case out return place;+robots:+  - name: base+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - grabber+      - drill+      - ADT calculator+known: []+world:+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    'x': [grass, gumball machine]+  upperleft: [-1, 2]+  map: |+   ...+   .x.+   .Ω.+   ...+entities:+  - name: gumball machine+    display:+      attr: red+      char: 'G'+    description:+    - Yields a gumball when drilled+    properties: [unwalkable, known]+  - name: gumball+    display:+      attr: blue+      char: 'o'+    description:+    - Dispensed from a gumball machine+    properties: [portable]+recipes:+  - in:+    - [1, gumball machine]+    out:+    - [1, gumball machine]+    - [1, gumball]+    required:+    - [1, drill]+    time: 1
+ data/scenarios/Testing/1171-chirp-command.yaml view
@@ -0,0 +1,47 @@+version: 1+name: Chirp test+creative: true+description: Locate a tree using chirp+objectives:+  - goal:+      - grab a tree.+    condition: |+      as base {has "tree"}+solution: |+  def takeStep = \item.+    direction <- chirp item;+    if (direction == down) {+      grab;+    } {+      turn direction;+      move;+      takeStep item;+    }+    end;++  takeStep "tree";+robots:+  - name: base+    dir: [0,-1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - string+      - grabber+      - treads+known: []+world:+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    'T': [grass, tree]+  upperleft: [0, 0]+  map: |+   .........+   ......T..+   .........+   .........+   .Ω.......+   .........
+ data/scenarios/Testing/1171-resonate-command.yaml view
@@ -0,0 +1,50 @@+version: 1+name: Resonate test+creative: true+description: Count trees in an area+objectives:+  - goal:+      - Place 7 trees.+    condition: |+      j <- robotnamed "judge";+      as j {+        c <- resonate "tree" ((0, 0), (8, -2));+        return $ c >= 7;+      };+solution: |+  def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+  doN 7 (place "tree"; move)+robots:+  - name: base+    dir: [1, 0]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - string+      - grabber+      - compass+      - treads+      - ADT calculator+    inventory:+      - [7, "tree"]+  - name: judge+    dir: [1, 0]+    system: true+    display:+      invisible: false+      char: J+known: []+world:+  dsl: |+    {blank, boulder}+  palette:+    'Ω': [grass, erase, base]+    'J': [grass, erase, judge]+    '.': [grass, erase]+  upperleft: [4, -1]+  map: |+   J........+   .Ω.......+   .........
+ data/scenarios/Testing/1171-sniff-command.yaml view
@@ -0,0 +1,56 @@+version: 1+name: Sniff test+creative: true+description: Locate a tree using sniff+objectives:+  - goal:+      - grab a tree.+    condition: |+      as base {has "tree"}+solution: |+  def homeIn = \item. \oldDistance.+    if (oldDistance > 0) {+      move;+      newDistance <- sniff item;+      d <- if (newDistance > oldDistance) {+        turn back;+        move;+        turn left;+        return oldDistance;+      } {+        return newDistance;+      };+      homeIn item d;+    } {+      grab;+    }+    end;++  let item = "tree" in+  initialDistance <- sniff item;+  homeIn item initialDistance;+robots:+  - name: base+    dir: [0,-1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - string+      - grabber+      - treads+known: []+world:+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    'T': [grass, tree]+  upperleft: [0, 0]+  map: |+   .........+   ......T..+   .........+   .........+   .Ω.......+   .........
+ data/scenarios/Testing/1207-scout-command.yaml view
@@ -0,0 +1,89 @@+version: 1+name: Scout test+creative: false+description: Locate a robot using scout+objectives:+  - goal:+      - Grab the flower in front of the exposed bot+    condition: |+      as base {has "flower"}+solution: |+  def search =+    found <- scout north;+    if found {} {+      move;+      search;+    };+    end;++  def grabFlower =+    here <- ishere "flower";+    if here {+      grab;+    } {+      move;+      grabFlower;+    };+    end;++  turn east;+  search;+  turn left;+  grabFlower+robots:+  - name: base+    dir: [0,-1]+    display:+      char: Ω+      attr: robot+    devices:+      - binoculars+      - branch predictor+      - compass+      - dictionary+      - grabber+      - logger+      - scanner+      - string+      - treads+  - name: bot+    dir: [0,1]+    system: true+    display:+      invisible: false+      char: b+      attr: robot+  - name: obscuredbot+    dir: [0,1]+    system: true+    display:+      invisible: false+      char: o+      attr: robot+  - name: invisiblebot+    dir: [0,1]+    system: true+    display:+      invisible: true+      char: i+      attr: robot+known: [tree, flower, boulder]+world:+  palette:+    'Ω': [grass, null, base]+    'b': [grass, null, bot]+    'o': [grass, null, obscuredbot]+    'i': [grass, null, invisiblebot]+    '.': [grass]+    '@': [grass, boulder]+    '*': [grass, flower]+    'T': [grass, tree]+  upperleft: [0, 0]+  map: |+   .........+   ..o.i.b..+   .........+   ..T...*..+   .........+   Ω.......@+   .........
+ data/scenarios/Testing/1218-stride-command.yaml view
@@ -0,0 +1,102 @@+version: 1+name: Stride test+creative: false+description: Move multiple cells at once+objectives:+  - goal:+      - Grab the tree, but not a flower+    condition: |+      as base {has "tree"}+    prerequisite:+        logic:+          not:+            id: grab_flower+  - id: grab_flower+    teaser: Grab flower+    goal:+      - Grab a flower+    optional: true+    condition: |+      as base {has "flower"}+solution: |+  stride 0;+  stride (-1);++  turn north;+  try {+    stride 5;+    grab;+    return ();+  } {+    log "Could not grab northern flower";+  };++  turn west;+  try {    +    stride 1;+  } {+    log "Could not stride west";+  };++  turn south;+  try {+    stride 5;+    grab;+    return ();+  } {+    log "Could not grab southern flower";+  };+  +  turn east;+  stride 5;+  grab;+robots:+  - name: base+    dir: [1, 0]+    display:+      char: Ω+      attr: robot+    devices:+      - branch predictor+      - calculator+      - compass+      - dictionary+      - grabber+      - logger+      - net+      - scanner+      - treads+      - turbocharger+entities:+- name: turbocharger+  display:+    attr: silver+    char: 't'+  description:+  - Allows one to "stride" across multiple cells+  properties: [known, portable]+  capabilities: [movemultiple]+known: [tree, flower, boulder, water]+world:+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '@': [grass, boulder]+    'T': [grass, tree]+    '*': [grass, flower]+    'w': [grass, water]+  upperleft: [0, 0]+  map: |+   ..............+   ......*.......+   ..............+   ......w.......+   ..............+   ...www........+   .*.wwwΩ....T..+   ...www@.......+   ..............+   ..............+   ..............+   ......*.......+   ..............
+ data/scenarios/Testing/1234-push-command.yaml view
@@ -0,0 +1,68 @@+version: 1+name: Push test+creative: false+description: Push items as in Sokoban+objectives:+  - goal:+      - Push a crate onto the stone pad+    condition: |+      j <- robotnamed "judge";+      as j {ishere "crate"}+solution: |+  push;+  turn left;+  move;+  turn right;+  move;+  move;+  turn right;+  push;+robots:+  - name: base+    dir: [1, 0]+    display:+      char: Ω+      attr: robot+    devices:+      - branch predictor+      - calculator+      - compass+      - dictionary+      - grabber+      - logger+      - net+      - scanner+      - treads+      - dozer blade+  - name: judge+    dir: [0, 1]+    system: true+    display:+      char: j+      attr: robot+      invisible: true+entities:+- name: crate+  display:+    attr: wood+    char: '▪'+  description:+  - Pushable crate+  properties: [known, portable, unwalkable]+known: [tree, flower, boulder, water]+world:+  palette:+    'Ω': [grass, null, base]+    'j': [stone, null, judge]+    '.': [grass]+    '@': [grass, boulder]+    'w': [grass, water]+    '*': [grass, flower]+    'x': [grass, crate]+  upperleft: [0, 0]+  map: |+   ..............+   ......w.......+   .....@Ωx.x....+   ......*..j....+   ......*.......
+ data/scenarios/Testing/1256-halt-command.yaml view
@@ -0,0 +1,56 @@+version: 1+name: Halting test+creative: false+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!+    condition: |+      as base {has "flower"}+solution: |+  mr <- meet;+  case mr (\_. return ()) (\r. halt r; turn west; move; salvage )+robots:+  - name: base+    dir: [0,-1]+    display:+      char: Ω+      attr: robot+    devices:+      - compass+      - dictionary+      - grabber+      - toolkit+      - logger+      - tank treads+      - antenna+      - ADT calculator+      - halting oracle+  - name: infinitebot+    dir: [0,1]+    display:+      invisible: false+    devices:+      - strange loop+      - dictionary+      - treads+    inventory:+      - [1, flower]+    program: |+      def forever = \c. c ; forever c end;+      forever ( turn right )+world:+  palette:+    'Ω': [grass, null, base]+    '^': [grass, null, infinitebot]+    '.': [grass]+  upperleft: [0, 0]+  map: |+   .........+   .........+   .........+   ...^Ω....+   .........+   .........+   .........
+ data/scenarios/Testing/1295-density-command.yaml view
@@ -0,0 +1,50 @@+version: 1+name: Density test+creative: true+description: Count entities in an area+objectives:+  - goal:+      - Pick up 3 entities.+    condition: |+      j <- robotnamed "judge";+      as j {+        c <- density ((0, 0), (3, 3));+        return $ c <= 13;+      };+solution: |+  def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+  doN 3 (move; grab);+robots:+  - name: base+    dir: [1, 0]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - string+      - grabber+      - compass+      - treads+      - ADT calculator+  - name: judge+    dir: [1, 0]+    system: true+    display:+      invisible: false+      char: J+known: []+world:+  dsl: |+    {blank, boulder}+  palette:+    'Ω': [grass, tree, base]+    'J': [grass, tree, judge]+    '.': [grass, tree]+    '*': [grass, flower]+  upperleft: [76, -89]+  map: |+   *.*.+   Ω*.*+   *.*.+   J*.*
+ data/scenarios/Testing/1320-world-DSL/00-ORDER.txt view
@@ -0,0 +1,3 @@+constant.yaml+erase.yaml+override.yaml
+ data/scenarios/Testing/1320-world-DSL/constant.yaml view
@@ -0,0 +1,23 @@+version: 1+name: Constant (uniform) world description+description: |+  Test that we can describe a uniform world by giving a+  single cell value.+objectives:+  - condition: |+      as base { n <- count "tree"; return (n >= 4) }+    goal:+    - Get 4 trees+solution: |+  grab; move; grab; move; grab; move; grab+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - treads+      - grabber+world:+  dsl: |+    {terrain: ice} <> {entity: tree}
+ data/scenarios/Testing/1320-world-DSL/erase.yaml view
@@ -0,0 +1,30 @@+version: 1+name: Overlay with erasure+description: |+  Test that we can erase entities when overlaying+objectives:+  - condition: |+      as base { n <- count "tree"; return (n == 0) }+    goal:+    - Get rid of your trees.+solution: |+  place "tree"; move; move;+  place "tree"; move; move;+  place "tree"; move; move;+  place "tree"+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - treads+      - grabber+    inventory:+      - [4, tree]+world:+  dsl: |+    overlay+    [ {terrain: ice} <> {entity: tree}+    , if (x + y) % 2 == 0 then {erase} else {blank}+    ]
+ data/scenarios/Testing/1320-world-DSL/override.yaml view
@@ -0,0 +1,25 @@+version: 1+name: Overlay with overriding+description: |+  Test that later entities override earlier ones when overlaying+objectives:+  - condition: |+      as base { n <- count "tree"; return (n == 1) }+    goal:+    - Get a tree.+solution: |+  grab+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - treads+      - grabber+world:+  dsl: |+    overlay+    [ {terrain: ice} <> {entity: rock}+    , {entity: tree}+    ]
+ data/scenarios/Testing/1356-portals/00-ORDER.txt view
@@ -0,0 +1,3 @@+automatic-waypoint-patrol.yaml+portals-and-waypoints.yaml+portals-flip-and-rotate.yaml
+ data/scenarios/Testing/1356-portals/_automatic-waypoint-patrol/program.sw view
@@ -0,0 +1,49 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+def abs = \n. if (n < 0) {-n} {n} end;++def mapTuple = \f. \t.+    (f $ fst t, f $ snd t)+    end;++def sumTuples = \t1. \t2.+    (fst t1 + fst t2, snd t1 + snd t2);+    end;++def negateTuple = \t.+    mapTuple (\x. -x) t;+    end;++def getRelativeLocation = \absCurrentLoc. \absDestLoc.+    let negatedLoc = negateTuple absCurrentLoc in+    return $ sumTuples negatedLoc absDestLoc;+    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 goToLocation = \currentLoc. \absoluteDestination.+    relativeDestination <- getRelativeLocation currentLoc absoluteDestination;+    moveTuple relativeDestination;+    end;++def visitNextWaypoint = \nextWpIdx.+    loc <- whereami;+    nextWaypointQuery <- waypoint "wp" nextWpIdx;+    goToLocation loc $ snd nextWaypointQuery;++    visitNextWaypoint $ nextWpIdx + 1;+    end;++def go =+    waypointQuery <- waypoint "wp" 0;+    teleport self $ snd waypointQuery;+    visitNextWaypoint 1;+    end;++go;
+ data/scenarios/Testing/1356-portals/_portals-flip-and-rotate/solution.sw view
@@ -0,0 +1,61 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def abs = \n. if (n < 0) {-n} {n} end;++def mapTuple = \f. \t.+    (f $ fst t, f $ snd t)+    end;++def sumTuples = \t1. \t2.+    (fst t1 + fst t2, snd t1 + snd t2);+    end;++def negateTuple = \t.+    mapTuple (\x. -x) t;+    end;++def getRelativeLocation = \absCurrentLoc. \absDestLoc.+    let negatedLoc = negateTuple absCurrentLoc in+    return $ sumTuples negatedLoc absDestLoc;+    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 goToLocation = \currentLoc. \absoluteDestination.+    relativeDestination <- getRelativeLocation currentLoc absoluteDestination;+    moveTuple relativeDestination;+    end;++def goToBottom =+    turn south; doN 14 move;+    end;++def go =+    goToLocation (0, 0) (3, -2);+    goToLocation (0, 0) (12, -2);+    goToLocation (0, 0) (18, -5);+    goToLocation (0, 0) (23, -3);++    goToBottom;+    goToLocation (0, -14) (3, -12);+    goToBottom;+    goToLocation (0, -14) (9, -9);+    goToBottom;+    goToLocation (0, -14) (18, -9);+    goToBottom;+    goToLocation (0, -14) (26, -10);++    turn east;+    doN 29 move;+    goToBottom;+    grab;+    end;++go;
+ data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml view
@@ -0,0 +1,72 @@+version: 1+name: Querying waypoints+description: |+  Demonstrate patrolling between waypoints+creative: true+robots:+  - name: base+    loc: [0, 0]+    dir: [1, 0]+  - name: patroller+    loc: [5, -4]+    dir: [1, 0]+    display:+      invisible: false+      attr: robot    +    program: |+      run "scenarios/Testing/1356-portals/_automatic-waypoint-patrol/program.sw"+known: [flower, boulder]+world:+  upperleft: [-1, 1]+  palette:+    '.': [grass]+    '*': [stone, flower]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  structures:+    - name: bigbox+      structure:+        palette:+          '.': [dirt]+          '@': [dirt, boulder]+          'w':+            cell: [dirt]+            waypoint:+              name: wp+        map: |+          @@@+          @w.+          @.@+  placements:+    - src: bigbox+      offset: [2, -2]+      orient:+        up: north+    - src: bigbox+      offset: [8, -2]+      orient:+        up: east+    - src: bigbox+      offset: [8, -6]+      orient:+        up: south+    - src: bigbox+      offset: [2, -6]+      orient:+        up: west+  map: |+    ┌───────────┐+    │*..*..*..*.│+    │.*..*..*..*│+    │..*..*..*..│+    │*..*..*..*.│+    │.*..*..*..*│+    │..*..*..*..│+    │*..*..*..*.│+    │.*..*..*..*│+    │..*..*..*..│+    └───────────┘
+ data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml view
@@ -0,0 +1,114 @@+version: 1+name: Waypoints for nested structures+description: |+  Demonstrate behavior of waypoints across structure overlays+creative: true+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    loc: [0, 4]+    dir: [1, 0]+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]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  structures:+    - name: bitpair+      structure:+        palette:+          'p': [stone, telepad exit]+          '1': [stone, bit (1)]+        map: |+          1+          p+        waypoints:+          - name: bitpair_bottom+            loc: [0, -1]+    - name: minibox+      structure:+        palette:+          '.': [stone]+          's': [stone, sand]+          'P': [stone, telepad entrance]+        placements:+          - src: bitpair+            offset: [1, 0]+        waypoints:+          - name: minibox_corner+            loc: [0, 0]+        map: |+          P.s+          s.s+    - name: bigbox+      structure:+        palette:+          '.': [stone]+          'T': [stone, tree]+          'w':+            cell: [dirt, telepad entrance]+            waypoint:+              name: bigbox_middle+        map: |+          TTTTTT+          T.TwT.+          .T.T.T+          TTTTTT+  placements:+    - src: bigbox+      offset: [1, -1]+    - src: bigbox+      offset: [7, -5]+    - src: minibox+      offset: [1, -7]+  waypoints:+    - name: meadow+      loc: [12, -1]+  portals:+    - entrance: bigbox_middle+      exitInfo:+        exit: bitpair_bottom+    - entrance: minibox_corner+      exitInfo:+        exit: meadow+  map: |+    ┌────────────┐+    │*..*..*..*.p│+    │.*..*..*..*.│+    │..*..*..*..*│+    │*..*..*..*..│+    │.*..*..*..*.│+    │..*..*..*..*│+    │*..*..*..*..│+    │.*..*..*..*.│+    └────────────┘
+ data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml view
@@ -0,0 +1,142 @@+version: 1+name: Portals with substructure flip and rotation+description: |+  Validate proper flip/rotate of portal waypoints+objectives:+  - goal:+    - |+      `grab` the "bitcoin"+    condition: |+      as base {has "bitcoin"}+solution: |+  run "scenarios/Testing/1356-portals/_portals-flip-and-rotate/solution.sw"+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+known: [flower, bit (0), bit (1), bitcoin]+world:+  palette:+    '.': [grass]+    '*': [stone, flower]+    'b': [stone, bitcoin]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+    'p':+      cell: [dirt, telepad exit, base]+      waypoint:+        name: portal_out+  upperleft: [-1, 1]+  structures:+    - name: tetromino+      structure:+        mask: '.'+        palette:+          '0': [stone, bit (0)]+          '1': [stone, bit (1)]+          'P':+            cell: [dirt, telepad entrance]+            waypoint:+              name: portal_in+        map: |+          10..+          1P..+          10..+          10..+          1000+          1111+  placements:+    - src: tetromino+      offset: [3, -2]+    - src: tetromino+      offset: [9, -2]+      orient:+        up: east+    - src: tetromino+      offset: [17, -2]+      orient:+        up: south+    - src: tetromino+      offset: [23, -2]+      orient:+        up: west+    - src: tetromino+      offset: [3, -9]+      orient:+        up: north+        flip: true+    - src: tetromino+      offset: [9, -9]+      orient:+        up: east+        flip: true+    - src: tetromino+      offset: [17, -9]+      orient:+        up: south+        flip: true+    - src: tetromino+      offset: [23, -9]+      orient:+        up: west+        flip: true+  portals:+    - entrance: portal_in+      exitInfo:+        exit: portal_out+  map: |+    ┌──────────────────────────────┐+    │p..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..*│+    │*..*..*..*..*..*..*..*..*..*..│+    │.*..*..*..*..*..*..*..*..*..*.│+    │..*..*..*..*..*..*..*..*..*..b│+    └──────────────────────────────┘
+ data/scenarios/Testing/1379-single-world-portal-reorientation.yaml view
@@ -0,0 +1,101 @@+version: 1+name: Portal reorientation within a single subworld+description: |+  Turning without turning+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+objectives:+  - goal:+    - |+      `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;+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+robots:+  - name: base+    dir: [0, 1]+    devices:+      - branch predictor+      - calculator+      - comparator+      - dictionary+      - grabber+      - lambda+      - logger+      - strange loop+      - treads+  - name: judge+    dir: [1, 0]+    system: true+    display:+      char: 'J'+      invisible: true+known: [flower]+world:+  name: root+  default: [blank]+  palette:+    '.': [grass]+    'f': [grass, flower]+    'g': [ice, null, judge]+    'B': [grass, null, base]+    '0':+      cell: [grass, telepad entrance]+      waypoint:+        name: wp0+    '1':+      cell: [grass, telepad entrance]+      waypoint:+        name: wp1+    '2':+      cell: [grass, telepad entrance]+      waypoint:+        name: wp2+    '3':+      cell: [grass, telepad entrance]+      waypoint:+        name: wp3+  upperleft: [-1, 1]+  portals:+    - entrance: wp0+      exitInfo:+        exit: wp0+      reorient: right+    - entrance: wp1+      exitInfo:+        exit: wp1+      reorient: right+    - entrance: wp2+      exitInfo:+        exit: wp2+      reorient: right+    - entrance: wp3+      exitInfo:+        exit: wp3+      reorient: right+  map: |+    .........+    .1.....2.+    .........+    .B.......+    .f.......+    .g.......+    .........+    .0.....3.+    .........
+ data/scenarios/Testing/1399-backup-command.yaml view
@@ -0,0 +1,30 @@+version: 1+name: Demo backup command+description: |+  Locomote backwards without access to the turn command+objectives:+  - goal:+    - |+      `grab` the "flower".+    condition: |+      as base {has "flower"}+solution: |+    backup; backup; grab;+robots:+  - name: base+    dir: [0, 1]+    devices:+      - tape drive+      - grabber+known: [flower]+world:+  default: [blank]+  palette:+    '.': [grass]+    'f': [grass, flower]+    'B': [grass, null, base]+  upperleft: [-1, 1]+  map: |+    .B.+    ...+    .f.
+ data/scenarios/Testing/144-subworlds/00-ORDER.txt view
@@ -0,0 +1,5 @@+basic-subworld.yaml+subworld-shared-structures.yaml+subworld-mapped-robots.yaml+subworld-located-robots.yaml+spatial-consistency-enforcement.yaml
+ data/scenarios/Testing/144-subworlds/_basic-subworld/solution.sw view
@@ -0,0 +1,7 @@++def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++doN 8 move;+f <- grab;+doN 7 move;+place f;
+ data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw view
@@ -0,0 +1,10 @@++def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++doN 3 move;+f <- grab;++doN 5 move;+r <- meet;+case r return $ \j. give j f;+
+ data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw view
@@ -0,0 +1,52 @@++def getRobotNumber = \n.+    r <- robotnumbered n;+    if (r == self) {+        return n;+    } {getRobotNumber $ n + 1};+    end;++def amLowestRecursive = \targetName. \idx.+    r <- robotnumbered idx;+    thisName <- as r {whoami};+    if (thisName == targetName) {+        return $ r == self;+    } {amLowestRecursive targetName $ idx + 1};+    end;++/**+Iterates through robots by increasing index.+If we encounter a robot, fetched by index,+with the same name as me, but I am not that robot,+then we return false.+*/+def amFirstOfMyName =+    myName <- whoami;+    amLowestRecursive myName 0;+    end;++def waitToGiveThing = \thing.+    r <- meet;+    case r (\_. wait 1; waitToGiveThing thing) $ \b. give b thing;+    end;++def waitToGive =+    let thing = "bitcoin" in+    create thing;+    waitToGiveThing thing;+    end;++def waitToReceive =+    noop;+    end;++def go =+    myNumber <- getRobotNumber 0;+    log $ "My number: " ++ format myNumber;+    amFirst <- amFirstOfMyName;+    log $ "Am first with this name? " ++ format amFirst;++    if amFirst {waitToReceive} {waitToGive};+    end;++go;
+ data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw view
@@ -0,0 +1,8 @@++def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++doN 16 move;++r <- meet;+case r return $ \j. give j "bitcoin";+
+ data/scenarios/Testing/144-subworlds/basic-subworld.yaml view
@@ -0,0 +1,108 @@+version: 1+name: Subworlds demo+description: |+  Surface and underground with portals.+objectives:+  - goal:+    - |+      `place` the "flower" on the white cell.+    condition: |+      j <- robotnamed "judge";+      as j {ishere "flower"}+solution: |+  run "scenarios/Testing/144-subworlds/_basic-subworld/solution.sw"+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+  - name: judge+    dir: [1, 0]+    system: true+    display:+      char: 'J'+      invisible: true+known: [flower, boulder]+subworlds:+  - name: underground+    default: [blank]+    palette:+      '.': [dirt]+      'f': [dirt, flower]+      'b': [dirt, boulder]+      'p':+        cell: [dirt, telepad exit]+        waypoint:+          name: portal_out2+      'P':+        cell: [dirt, telepad entrance]+        waypoint:+          name: portal_in2+    portals:+      - entrance: portal_in2+        exitInfo:+          exit: portal_out1+          subworldName: root+    upperleft: [-1, 1]+    map: |+      b..b..b..b+      .p..f...P.+      b..b..b..b+world:+  name: root+  default: [blank]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    't': [ice, null, judge]+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: portal_out1+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: portal_in1+  upperleft: [-1, 1]+  portals:+    - entrance: portal_in1+      exitInfo:+        exit: portal_out2+        subworldName: underground+  map: |+    ..........+    .p.Bt...P.+    ..........
+ data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml view
@@ -0,0 +1,95 @@+version: 1+name: Subworld spatial consistency enforcement+description: |+  Portals annotated to enforce spatial consistency between subworlds+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+known: [boulder]+subworlds:+  - name: underground+    default: [blank]+    palette:+      '.': [dirt]+      'b': [dirt, boulder]+      'p':+        cell: [dirt, telepad exit]+        waypoint:+          name: portal_out2+      'P':+        cell: [dirt, telepad entrance]+        waypoint:+          name: portal_in2+    portals:+      - entrance: portal_in2+        exitInfo:+          exit: portal_out1+          subworldName: root+        consistent: true+        reorient: back+    upperleft: [-1, 1]+    map: |+      b..b..b..b+      .P......p.+      b..b..b..b+world:+  name: root+  default: [blank]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: portal_out1+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: portal_in1+  upperleft: [-1, 1]+  portals:+    - entrance: portal_in1+      exitInfo:+        exit: portal_out2+        subworldName: underground+      consistent: true+      reorient: back+  map: |+    ..........+    .p.B....P.+    ..........
+ data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml view
@@ -0,0 +1,116 @@+version: 1+name: Subworld robots (explicit location)+description: |+  Demonstrate that system robots can be placed in any subworld.+objectives:+  - goal:+    - |+      `give` the "flower" to the robot underground.+    condition: |+      j <- robotnamed "judge";+      as j {has "flower"}+solution: |+  run "scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw"+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    loc:+      subworld: root+      loc: [2, 0]+    devices:+      - ADT calculator+      - antenna+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+  - name: judge+    dir: [1, 0]+    loc:+      subworld: underground+      loc: [4, 0]+    system: true+    display:+      char: 'J'+      invisible: false+known: [flower, boulder]+subworlds:+  - name: underground+    default: [blank]+    palette:+      '.': [dirt]+      'b': [dirt, boulder]+      't': [grass, null, judge]+      'p':+        cell: [dirt, telepad exit]+        waypoint:+          name: portal_out2+      'P':+        cell: [dirt, telepad entrance]+        waypoint:+          name: portal_in2+    portals:+      - entrance: portal_in2+        exitInfo:+          exit: portal_out1+          subworldName: root+    upperleft: [-1, 1]+    map: |+      b..b..b..b+      .p......P.+      b..b..b..b+world:+  name: root+  default: [blank]+  palette:+    '.': [grass]+    'f': [grass, flower]+    'B': [grass, null, base]+    't': [grass, null, judge]+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: portal_out1+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: portal_in1+  upperleft: [-1, 1]+  portals:+    - entrance: portal_in1+      exitInfo:+        exit: portal_out2+        subworldName: underground+  map: |+    ..........+    .p....f.P.+    ..........
+ data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml view
@@ -0,0 +1,116 @@+version: 1+name: Subworld robots (map placement)+description: |+  Demonstrate that system robots can be placed in any subworld.++  Also demonstrates tiebreaking logic for robot numbering based+  on subworld.+objectives:+  - goal:+    - |+      `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"}+solution: |+  run "scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw"+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - antenna+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+  - name: judge+    dir: [1, 0]+    system: true+    display:+      char: 'J'+      invisible: false+    program: |+      run "scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw";+known: [boulder]+subworlds:+  - name: underground+    default: [blank]+    palette:+      '.': [dirt]+      'b': [dirt, boulder]+      't': [grass, null, judge]+      'p':+        cell: [dirt, telepad exit]+        waypoint:+          name: portal_out2+      'P':+        cell: [dirt, telepad entrance]+        waypoint:+          name: portal_in2+    portals:+      - entrance: portal_in2+        exitInfo:+          exit: portal_out1+          subworldName: root+    upperleft: [-1, 1]+    map: |+      b..b..b..b+      .p.t....P.+      b..b..b..b+world:+  name: root+  default: [blank]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    't': [grass, null, judge]+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: portal_out1+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: portal_in1+  upperleft: [-1, 1]+  portals:+    - entrance: portal_in1+      exitInfo:+        exit: portal_out2+        subworldName: underground+  map: |+    ..........+    .p.B..t.P.+    ..........
+ data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml view
@@ -0,0 +1,193 @@+version: 1+name: Subworld shared structures+description: |+  Traverse floors of the tower+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    loc: [0, 0]+    devices:+      - ADT calculator+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+known: [flower]+structures:+  - name: minibox+    structure:+      palette:+        '.': [stone]+        'd': [dirt]+        'f': [stone, flower]+        'p':+          cell: [grass, telepad exit]+          waypoint:+            name: portal_out+        'P':+          cell: [grass, telepad entrance]+          waypoint:+            name: portal_in+      map: |+        p....+        .ddd.+        .d.d.+        .ddd.+        ....P+  - name: flowers+    structure:+      mask: '.'+      palette:+        'f': [stone, flower]+      map: |+        f.f+        .f.+        f.f+subworlds:+  - name: floor1+    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+    portals:+      - entrance: portal_in+        exitInfo:+          exit: portal_out+          subworldName: floor2+    upperleft: [0, 0]+    map: |+      .....+      .....+      .....+      .....+      .....+  - name: floor2+    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+    portals:+      - entrance: portal_in+        exitInfo:+          exit: portal_out+          subworldName: floor3+    upperleft: [0, 0]+    map: |+      .....+      .....+      .....+      .....+      .....+  - name: floor3+    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+    portals:+      - entrance: portal_in+        exitInfo:+          exit: portal_out+          subworldName: root+    upperleft: [0, 0]+    map: |+      .....+      .....+      .....+      .....+      .....+world:+  name: root+  default: [blank]+  palette:+    '.': [grass]+  upperleft: [0, 0]+  placements:+    - src: flowers+      offset: [0, -2]+    - src: minibox+      offset: [0, 0]+  portals:+    - entrance: portal_in+      exitInfo:+        exit: portal_out+        subworldName: floor1+  map: |+    .....+    .....+    .....+    .....+    .....
data/scenarios/Testing/201-require/201-require-device-creative.yaml view
@@ -25,7 +25,6 @@       - logger known: [water] world:-  default: [blank, null]   palette:     '.': [grass]     '~': [dirt, water]
data/scenarios/Testing/201-require/201-require-device-creative1.yaml view
@@ -26,7 +26,6 @@     inventory:       - [1, boat] world:-  default: [blank, null]   palette:     '.': [grass]     '~': [dirt, knownwater]
data/scenarios/Testing/201-require/201-require-device.yaml view
@@ -28,7 +28,6 @@       - [1, treads] known: [water] world:-  default: [blank, null]   palette:     '.': [grass]     '~': [dirt, water]
data/scenarios/Testing/201-require/201-require-entities-def.yaml view
@@ -30,7 +30,6 @@       - [1, grabber]       - [1, logger] world:-  default: [blank, null]   palette:     '.': [grass]     '┌': [stone, upper left corner]
data/scenarios/Testing/201-require/201-require-entities.yaml view
@@ -28,7 +28,6 @@       - [1, grabber]       - [1, logger] world:-  default: [blank, null]   palette:     '.': [grass]     '┌': [stone, upper left corner]
data/scenarios/Testing/201-require/533-reprogram-simple.yaml view
@@ -46,7 +46,6 @@       - [50, rock] known: [water] world:-  default: [blank, null]   palette:     '.': [grass]     '~': [dirt, water]
data/scenarios/Testing/201-require/533-reprogram.yaml view
@@ -46,7 +46,6 @@       - [50, rock] known: [water] world:-  default: [blank, null]   palette:     '.': [grass]     '~': [dirt, water]
data/scenarios/Testing/373-drill.yaml view
@@ -40,10 +40,11 @@       - [5, grabber] known: [water, wavy water] world:-  default: [ice, water]+  dsl: |+    {ice, water}   palette:-    'Ω': [grass, null, base]-    '.': [grass]+    'Ω': [grass, erase, base]+    '.': [grass, erase]     ' ': [ice, water]     '~': [ice, wavy water]     'L': [grass, Linux]
data/scenarios/Testing/378-objectives.yaml view
@@ -46,7 +46,6 @@       - [10, solar panel]       - [0, harvester] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Testing/394-build-drill.yaml view
@@ -12,8 +12,8 @@ # When testing, add `s <- build {...}; n <- as s {whoami}; log n` solution: |   def forever = \c. c ; forever c end;-  def unblock = try {drill forward} {} end;-  def push = unblock; move end;+  def unblock = try {drill forward; return ()} {} end;+  def doPush = unblock; move end;   log "Hi, I am base";   r <- build {     wait 2;@@ -21,7 +21,7 @@     forever (       build {         log "Hi, I am pusher";-        forever push+        forever doPush       };       log "- robot built"     )@@ -41,7 +41,6 @@     inventory:       - [1, detonator] # used to mark win world:-  default: [blank]   palette:     '.': [grass]     'M': [stone, mountain]
data/scenarios/Testing/397-wrong-missing.yaml view
@@ -28,7 +28,6 @@       - [1, treads]       - [1, solar panel] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Testing/428-drowning-destroy.yaml view
@@ -35,7 +35,6 @@     program: "move" known: [water] world:-  default: [blank]   palette:     '.': [grass]     ' ': [ice, water]
data/scenarios/Testing/475-wait-one.yaml view
@@ -32,7 +32,6 @@     program: |       log "I shall sleep"; wait 1; log "I have awoken" world:-  default: [blank]   palette:     '.': [grass]     '┌': [stone, upper left corner]
data/scenarios/Testing/479-atomic-race.yaml view
@@ -77,7 +77,6 @@       - You win!     properties: [known, portable] world:-  default: [blank]   palette:     '.': [grass]   upperleft: [0,0]
data/scenarios/Testing/479-atomic.yaml view
@@ -59,7 +59,6 @@     properties: [known, portable, growable]     growth: [1,2] world:-  default: [blank]   palette:     '.': [grass]   upperleft: [0,0]
data/scenarios/Testing/490-harvest.yaml view
@@ -26,7 +26,6 @@       - grabber       - boat world:-  default: [blank]   palette:     '.': [grass]     'T': [stone, tree]
data/scenarios/Testing/504-teleport-self.yaml view
@@ -23,7 +23,6 @@     inventory:     - [1, tree] world:-  default: [blank]   palette:     '.': [grass]     '┌': [stone, upper left corner]
data/scenarios/Testing/508-capability-subset.yaml view
@@ -37,9 +37,10 @@       - [1, ADT calculator] known: [water] world:-  default: [ice, water]+  dsl: |+    {ice, water}   palette:-    '.': [grass]+    '.': [grass, erase]     ' ': [ice, water]     '┌': [stone, upper left corner]     '┐': [stone, upper right corner]
data/scenarios/Testing/555-teleport-location.yaml view
@@ -24,4 +24,5 @@     inventory:       - [1, rock] world:-  default: [grass, null]+  dsl: |+    {grass}
data/scenarios/Testing/562-lodestone.yaml view
@@ -42,9 +42,10 @@       - [0, bit (1)] known: [water, wavy water] world:-  default: [ice, water]+  dsl: |+    {ice, water}   palette:-    '.': [grass]+    '.': [grass, erase]     ' ': [ice, water]     '~': [ice, wavy water]     'L': [grass, Linux]@@ -58,7 +59,7 @@     'A': [stone, magnetic vein]     'o': [stone, lodestone]     '0': [grass, bit (0)]-    'B': [grass, null, base]+    'B': [grass, erase, base]   upperleft: [-1, 1]   map: |     ┌─────┐                                                                ~~
data/scenarios/Testing/684-swap.yaml view
@@ -45,7 +45,6 @@         )       ) world:-  default: [blank]   palette:     '┌': [stone, upper left corner]     '┐': [stone, upper right corner]
+ data/scenarios/Testing/687-watch-command.yaml view
@@ -0,0 +1,77 @@+version: 1+name: Watch command test+creative: true+description: Wake from wait upon entity placement+objectives:+  - goal:+      - grab a tree before the competitor steals it.+    condition: |+      as base {has "tree"}+    prerequisite:+      not: stolen+  - id: stolen+    goal:+      - Competitor steals a tree+    condition: |+      competitor <- robotnamed "competitor";+      as competitor {has "tree"}+solution: |+  watch forward;+  wait 80;+  move;+  grab;+robots:+  - name: base+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - string+      - grabber+      - treads+  - name: competitor+    dir: [0, -1]+    display:+      char: b+      attr: robot+    devices:+      - logger+      - string+      - grabber+      - treads+    program: |+      wait 70;+      move;+      grab;+      turn back;+      move;+  - name: planter+    dir: [1, 0]+    display:+      char: p+      attr: robot+    inventory:+      - [10, tree]+    devices:+      - logger+      - string+      - grabber+      - treads+    program: |+      def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+      doN 7 (move; wait 4; place "tree";);+known: []+world:+  palette:+    'Ω': [grass, null, base]+    p : [grass, null, planter]+    b : [grass, null, competitor]+    '.': [grass]+    'T': [grass, tree]+  upperleft: [0, 0]+  map: |+   ......b...+   .p........+   ......Ω...
data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml view
@@ -29,7 +29,6 @@     program: |       try {move} {say "Fatal error: two was unable to move into a boulder even though it is system robot!"} world:-  default: [blank]   palette:     '@': [stone, boulder]     'B': [grass, null, base]
data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml view
@@ -35,7 +35,6 @@     program: |       try {move} {say "Fatal error: three was unable to move into water even though it is system robot!"} world:-  default: [blank]   palette:     '~': [stone, water]     'B': [grass, null, base]
data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml view
@@ -33,7 +33,6 @@     dir: [0,-1]     system: true world:-  default: [blank]   palette:     '@': [stone, boulder]     'B': [grass, null, base]
data/scenarios/Testing/710-multi-robot.yaml view
@@ -23,7 +23,6 @@ solution: |   move;move;move; move;move;move; move;move;move; world:-  default: [blank]   palette:     '.': [blank]     # FIRST ROOM
data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml view
@@ -42,7 +42,6 @@       - [2, board]       - [5, rock] world:-  default: [blank]   palette:     'x': [grass, null, base]   upperleft: [0, 0]
data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml view
@@ -34,7 +34,6 @@       - [2, board]       - [5, rock] world:-  default: [blank]   palette:     'x': [grass, null, base]   upperleft: [0, 0]
data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml view
@@ -53,7 +53,6 @@       - [2, board]       - [5, rock] world:-  default: [blank]   palette:     'x': [grass, flower, base]   upperleft: [0, 0]
data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml view
@@ -41,7 +41,6 @@       - [2, board]       - [5, rock] world:-  default: [blank]   palette:     'x': [grass, flower, base]   upperleft: [0, 0]
data/scenarios/Testing/858-inventory/858-counting-objective.yaml view
@@ -26,7 +26,6 @@   grab; known: [tree] world:-  default: [blank]   palette:     'B': [grass, null, base]     'w': [grass, tree]
data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml view
@@ -25,7 +25,6 @@   place "tree"; known: [tree] world:-  default: [blank]   palette:     'B': [grass, null, base]     'w': [grass]
data/scenarios/Testing/858-inventory/858-possession-objective.yaml view
@@ -23,7 +23,6 @@   grab; known: [tree] world:-  default: [blank]   palette:     'B': [grass, null, base]     'w': [grass, tree]
data/scenarios/Testing/920-meet.yaml view
@@ -32,7 +32,6 @@   - name: other     dir: [1,0] world:-  default: [blank]   palette:     '.': [grass]     'Ω': [grass, null]
data/scenarios/Testing/955-heading.yaml view
@@ -17,7 +17,6 @@       - treads       - compass world:-  default: [blank]   palette:     '^': [grass, null, base]     '.': [grass]
data/scenarios/Testing/956-GPS.yaml view
@@ -47,7 +47,6 @@       y <- random 11;       teleport base (x-5, y-5) world:-  default: [blank]   palette:     '.': [grass]   upperleft: [-5, 5]
data/scenarios/Testing/958-isempty.yaml view
@@ -39,7 +39,6 @@     - A thing that everyone needs!     properties: [portable] world:-  default: [blank]   palette:     '.': [grass]     '>': [grass, tree, base]
data/scenarios/Testing/961-custom-capabilities.yaml view
@@ -32,7 +32,6 @@       - [1, wheels]       - [1, solar panel] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
+ data/scenarios/Testing/_Validation/1221-duplicate-entities.yaml view
@@ -0,0 +1,22 @@+version: 1+name: |+  Duplicate entities+description: |+  This should be rejected by the parser.+entities:+  - name: scooter+    display:+      char: 'M'+    description:+      - My scooter+  - name: scooter+    display:+      char: 'Y'+    description:+      - Your scooter+world:+  palette:+    'x': [grass, null, base]+  upperleft: [0, 0]+  map: |+    x
+ data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml view
@@ -0,0 +1,66 @@+version: 1+name: Reject multi-exit portal+description: |+  Portals must have only a single exit+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+known: [tree]+world:+  upperleft: [-1, 1]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: inportal+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: outportal1+    'q':+      cell: [grass, telepad exit]+      waypoint:+        name: outportal2+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  portals:+    - entrance: inportal+      exitInfo:+        exit: outportal1+    - entrance: inportal+      exitInfo:+        exit: outportal2+  map: |+    ┌────────┐+    │....B..q│+    │.p......│+    │....P...│+    └────────┘
+ data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml view
@@ -0,0 +1,59 @@+version: 1+name: Reject overlapping portal entrances+description: |+  Two portals must not share the same entrance location+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+known: [tree]+world:+  upperleft: [1, -1]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: inportal+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: outportal+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  portals:+    - entrance: inportal+      exitInfo:+        exit: outportal+  map: |+    ┌────────┐+    │....B..p│+    │.p......│+    │....P...│+    └────────┘
+ data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml view
@@ -0,0 +1,42 @@+version: 1+name: Waypoint uniqueness enforcement+description: |+  Waypoints can optionally be required to be unique+attrs:+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+known: [tree]+world:+  upperleft: [1, -1]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: outportal+        unique: True+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  map: |+    ┌────────┐+    │....B..p│+    │.p......│+    │........│+    └────────┘
+ data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml view
@@ -0,0 +1,93 @@+version: 1+name: Subworld spatial consistency enforcement+description: |+  Portals annotated to enforce spatial consistency between subworlds+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+known: [boulder]+subworlds:+  - name: underground+    default: [blank]+    palette:+      '.': [dirt]+      'b': [dirt, boulder]+      'p':+        cell: [dirt, telepad exit]+        waypoint:+          name: portal_out2+      'P':+        cell: [dirt, telepad entrance]+        waypoint:+          name: portal_in2+    portals:+      - entrance: portal_in2+        exitInfo:+          exit: portal_out1+          subworldName: root+        consistent: true+    upperleft: [-1, 1]+    map: |+      b..b..b..b+      .P.....p..+      b..b..b..b+world:+  name: root+  default: [blank]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: portal_out1+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: portal_in1+  upperleft: [-1, 1]+  portals:+    - entrance: portal_in1+      exitInfo:+        exit: portal_out2+        subworldName: underground+      consistent: true+  map: |+    ..........+    .p.B....P.+    ..........
+ data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml view
@@ -0,0 +1,87 @@+version: 1+name: Subworld uniqueness (default name)+description: |+  Has two unnamed subworlds, which fail uniqueness+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+  - name: judge+    dir: [1, 0]+    system: true+    display:+      char: 'J'+      invisible: true+known: [flower, boulder]+subworlds:+  - default: [blank]+    palette:+      '.': [dirt]+      'f': [dirt, flower]+      'b': [dirt, boulder]+      'p':+        cell: [dirt, telepad exit]+        waypoint:+          name: portal_out2+      'P':+        cell: [dirt, telepad entrance]+        waypoint:+          name: portal_in2+    upperleft: [-1, 1]+    map: |+      b..b..b..b+      .p..f...P.+      b..b..b..b+world:+  default: [blank]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    't': [ice, null, judge]+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: portal_out1+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: portal_in1+  upperleft: [-1, 1]+  map: |+    ..........+    .p.Bt...P.+    ..........
+ data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml view
@@ -0,0 +1,89 @@+version: 1+name: Subworld uniqueness (explicit name)+description: |+  Has two identically-named subworlds+attrs:+  - name: portal_in+    fg: "#ff9a00"+    bg: "#ff5d00"+  - name: portal_out+    fg: "#00a2ff"+    bg: "#0065ff"+entities:+  - name: telepad entrance+    display:+      attr: portal_in+      char: "o"+    description:+    - Portal entrance+    properties: [known]+  - name: telepad exit+    display:+      attr: portal_out+      char: "o"+    description:+    - Portal exit+    properties: [known]+robots:+  - name: base+    dir: [1, 0]+    devices:+      - ADT calculator+      - branch predictor+      - comparator+      - compass+      - dictionary+      - GPS receiver+      - grabber+      - lambda+      - lodestone+      - logger+      - strange loop+      - treads+  - name: judge+    dir: [1, 0]+    system: true+    display:+      char: 'J'+      invisible: true+known: [flower, boulder]+subworlds:+  - name: foo+    default: [blank]+    palette:+      '.': [dirt]+      'f': [dirt, flower]+      'b': [dirt, boulder]+      'p':+        cell: [dirt, telepad exit]+        waypoint:+          name: portal_out2+      'P':+        cell: [dirt, telepad entrance]+        waypoint:+          name: portal_in2+    upperleft: [-1, 1]+    map: |+      b..b..b..b+      .p..f...P.+      b..b..b..b+world:+  name: foo+  default: [blank]+  palette:+    '.': [grass]+    'B': [grass, null, base]+    't': [ice, null, judge]+    'p':+      cell: [grass, telepad exit]+      waypoint:+        name: portal_out1+    'P':+      cell: [grass, telepad entrance]+      waypoint:+        name: portal_in1+  upperleft: [-1, 1]+  map: |+    ..........+    .p.Bt...P.+    ..........
data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml view
@@ -30,7 +30,6 @@       - [2, board]       - [5, rock] world:-  default: [blank]   palette:     'x': [grass, null, base]   upperleft: [0, 0]
data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml view
@@ -30,7 +30,6 @@       - [2, board]       - [5, rock] world:-  default: [blank]   palette:     'x': [grass, flower, base]   upperleft: [0, 0]
data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml view
@@ -23,7 +23,6 @@     inventory:       - [5, rock] world:-  default: [blank]   palette:     'x': [grass, null, base]   upperleft: [0, 0]
data/scenarios/Tutorials/00-ORDER.txt view
@@ -10,6 +10,7 @@ bind2.yaml crash.yaml scan.yaml+give.yaml def.yaml lambda.yaml require.yaml
data/scenarios/Tutorials/backstory.yaml view
@@ -28,10 +28,12 @@         the menu at any time to jump around between tutorials or pick         up again where you left off.       - |-        When you're ready for your first challenge, close this dialog with Esc or Ctrl-G,-        and type at the prompt:+        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:       - |+        ```         say "Ready!"+        ```     condition: |       try {         l <- robotNamed "listener";@@ -48,9 +50,11 @@       - |         When you're ready for your first tutorial challenge, type at the prompt:       - |+        ```         say "Ready!"+        ```       - |-        To open the full goal text again, you can hit Ctrl-G.+        To open the full goal text again, you can hit **Ctrl+G**.     properties: [known, portable] robots:   - name: base@@ -90,3 +94,6 @@ seed: 0 world:   offset: true+  scrollable: false+  dsl: |+    "classic"
− data/scenarios/Tutorials/bind2-solution.sw 
@@ -1,11 +0,0 @@-build {-    move; move;-    turn right;-    move; move; move; move; move; move;-    x <- grab;-    turn left;-    move;-    turn left;-    move; move;-    place x;-}
data/scenarios/Tutorials/bind2.yaml view
@@ -13,8 +13,8 @@       - |         Build a robot to retrieve and restore the mystery artifact to its proper place!       - |-        Note: If you find yourself stuck, you can select "Start over" from-        the "Quit" (CTRL+q) dialog.+        **NOTE:** If you find yourself stuck, you can select "Start over" from+        the "Quit" (**Ctrl+Q**) dialog.     condition: |       try {         p <- robotnamed "floorspot";@@ -29,23 +29,25 @@       - |         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`, 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`, returning it does not convey any information.-        Thus, the type of `move` is `cmd unit`.+        `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`, 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+        To use the result of a command later, you need _bind notation_, which         consists of a variable name and a leftwards-pointing arrow         before the command.  For example:       - |+        ```         move; t <- grab; place t+        ```       - |         In the above example, the result returned by `grab` is assigned-        to the variable name `t`, which can then be used later.+        to the variable name `t`{=snippet}, which can then be used later.         This is useful, for example, if you do not care what you         grabbed and just want to move it to another cell, or if you         are not sure of the name of the thing being grabbed.@@ -60,7 +62,17 @@       } { return false }     prerequisite: grab_artifact solution: |-  run "data/scenarios/Tutorials/bind2-solution.sw"+  build {+    move; move;+    turn right;+    move; move; move; move; move; move;+    x <- grab;+    turn left;+    move;+    turn left;+    move; move;+    place x;+  } entities:   - name: Hastur     display:@@ -88,7 +100,6 @@   - name: pedestal     system: true world:-  default: [blank]   palette:     '.': [blank, null]     'Ω': [blank, null, base]
data/scenarios/Tutorials/build.yaml view
@@ -11,14 +11,14 @@         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}`,-        where in place of `COMMANDS` you write the sequence+      - 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" and place it next-        to the water.+        Build a robot to harvest the `flower`{=entity} and place it next+        to the `water`{=entity}.       - |-        TIP: Newly built robots start out facing the same+        **TIP:** Newly built robots start out facing the same         direction as their parent, which in the tutorials will always be north.     condition: |       try {@@ -51,7 +51,6 @@       - [10, treads] known: [water] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/conditionals.yaml view
@@ -5,17 +5,17 @@ objectives:   - goal:       - |-        The 4x4 gray square contains 4 `very small rock`s --- so+        The 4x4 gray square contains 4 `very small rock`{=entity}s --- so         small they cannot be seen!  Your goal is to collect all of         them and bring them back to your base; you win when you have         all 4.  There is one rock in each row and column, but         otherwise you can't be sure where they are.  Your best bet is-        to sweep over the entire 4x4 square and pick up a `very small-        rock` any time you detect one.+        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`, can be used-        for detecting the presence of a specific item such as a `very small rock`.-        What we need is a way to take the `bool` output from `ishere`+        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`         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.)@@ -24,29 +24,33 @@         conditional expressions.  However, `if` is not special syntax;         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         argument, depending on whether the boolean expression is true or false, respectively.       - |-        The type variable `a` can stand for any type; `{a}`-        indicates a *delayed* expression of type `a`.  Normally,+        The type variable `a`{=type} can stand for any type; `{a}`{=type}+        indicates a *delayed* expression of type `a`{=type}.  Normally,         function arguments are evaluated strictly before the function         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}`, we just surround a value of type `int`+        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`.+        must also be in curly braces: the type of `build`+        is `{cmd a} -> cmd robot`{=type}.       - |-        TIP: Note that `if` requires a `bool`, not a `cmd bool`!  So you cannot directly say-        `if (ishere "very small rock") {...} {...}`.  Instead you can write `b <- ishere "very small rock"; if b {...} {...}`.  You might enjoy writing your own function of-        type `cmd bool -> {cmd a} -> {cmd a} -> cmd a` to encapsulate this pattern.+        **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.       - |-        TIP: the two branches of an `if` must have the same type. In particular,-        `if ... {grab} {}` is not-        allowed, because `{grab}` has type `{cmd text}` whereas `{}` has type `{cmd unit}`.+        **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}.         In this case `{grab; return ()}` has the right type.     condition: |       try {@@ -94,7 +98,6 @@       - A small rock.  It is so small, it is practically invisible.     properties: [portable] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/craft.yaml view
@@ -9,17 +9,17 @@ objectives:   - goal:       - Robots can use the `make` command to make things, as long as-        they have a `workbench` and the proper ingredients.  For-        example, `make "circuit"` will make a circuit.-      - Your base has a few trees in its inventory. Select them to see the+        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", so you will have to make-        some "branch"es first.+      - 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+        **NOTE:** when used after opening quotes in the REPL, the Tab key can cycle through         possible completions of a name. E.g., type:       - |-        > make "br[Tab][Tab]+        `> make "br[Tab][Tab]`{=snippet}     condition: |       try {         as base {has "branch predictor"}@@ -38,7 +38,6 @@     inventory:       - [10, tree] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '┌': [stone, upper left corner]
− data/scenarios/Tutorials/crash-solution.sw 
@@ -1,8 +0,0 @@-crasher <- build {-    turn east; move; move; move; log "bye"; move-};-wait 32;-salvager <- build {-    log "I will bring home the Win!";-    turn east; move; move; move; salvage; turn back; move; move; give base "Win"-};
data/scenarios/Tutorials/crash.yaml view
@@ -4,22 +4,26 @@   Learn how to view built robots and debug them. objectives:   - goal:-      - Before you send your robots far away you need to learn how+      - Before you send your robots far away from the `base` you need to learn how         to figure out what went wrong with them if they crash.       - |         In this challenge, you should start by         sending a robot to walk four steps straight east into the mountain,-        crashing deliberately.  However, you must make sure it has a `logger`,+        crashing deliberately.  However, you must make sure it has a `logger`{=entity},         so we can see what command failed.  The simplest way to ensure         that is to have it execute the `log` command; `build` will         ensure it has the devices it needs to execute its commands.         For example:       - |+        ```         build {log "Hi!"; turn east; move; move; move; log "3"; move; log "OK"}-      - After the robot crashes, execute `view it0` (or whichever-        `itN` variable corresponds to the result of the `build`+        ```+      - |+        `wait` for the robot to crash, then execute `view it0`{=snippet} (or whichever+        `itN`{=snippet} variable corresponds to the result of the `build`         command) to see how far it got. Further instructions should-        appear in the crashed robot's log.+        appear in the crashed robot's log and `give` you an opportunity to `salvage`+        the situation...     condition: |       try {         as base {has "Win"}@@ -33,7 +37,14 @@       - If you have this, you win!     properties: [known, portable] solution: |-  run "scenarios/Tutorials/crash-solution.sw"+  crasher <- build {+      turn east; move; move; move; log "bye"; move+  };+  wait 32;+  salvager <- build {+      log "I will bring home the Win!";+      turn east; move; move; move; salvage; turn back; move; move; give base "Win"+  }; robots:   - name: base     dir: [0,1]@@ -69,7 +80,6 @@       run "scenarios/Tutorials/crash-secret.sw" known: [water, tree, mountain] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '!': [grass, null, secret]
data/scenarios/Tutorials/def.yaml view
@@ -4,30 +4,32 @@   Learn how to define new commands. objectives:   - goal:-      - Your goal is to build a robot to fetch the flower growing in the+      - 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 in its inventory.+        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` device+        `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-      - defines a new command `m4`, with type `cmd unit`, as four consecutive `move` commands.+        ```+      - 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 is at (16,4), which+        **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,         its contents and coordinates are shown in the lower left.       - |-        TIP: the type annotation in a definition is optional.  You could also write+        **TIP:** the type annotation in a definition is optional.  You could also write         `def m4 = move; move; move; move end`, and Swarm would infer-        the type of `m4`.+        the type of `m4`{=snippet}.       - |-        TIP: writing function definitions at the prompt is annoying.-        You can also put definitions in a `.sw` file and load it+        **TIP:** writing function definitions at the prompt is annoying.+        You can also put definitions in a `.sw`{=path} file and load it         with the `run` command. Check out         https://github.com/swarm-game/swarm/tree/main/editors         for help setting up an external editor with things like@@ -69,7 +71,6 @@       - [0, flower] known: [boulder] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/equip.yaml view
@@ -9,16 +9,18 @@         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.+        to gain the `build` capability.         Try typing `build {}` - you should get an error telling you that you-        need to equip a "3D printer".+        need to equip a `3D printer`{=entity}.       - |-        Fortunately, there is a 3D printer lying nearby.  Go `grab` it, then-        equip it with `equip "3D printer"`.+        Fortunately, there is a `3D printer`{=entity} lying nearby.  Go `grab` it, then+        `equip` it with `equip "3D printer"`.       - |         You win by building your first robot:       - |+        ```         build {}+        ```     condition: |       try {         _ <- robotNumbered 1;@@ -40,7 +42,6 @@       - [10, logger] known: [3D printer, water] world:-  default: [blank]   palette:     '>': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/farming.yaml view
@@ -6,25 +6,30 @@   - id: get_many_lambdas     teaser: Get 256 lambdas     goal:-      - Lambdas are an essential item for building robots, but they+      - |+        `lambda`{=entity}s are an essential item for building robots, but they         are somewhat rare in the wild.  Therefore, it makes sense to farm         them in order to create a reliable supply.       - |         In this scenario, you are a bit farther along: in particular,-        you now have a few `harvester`s, a few `lambda`s, a few `logger`s,-        some `branch predictor`s which+        you now have a few `harvester`{=entity}s, a few `lambda`{=entity}s, a few `logger`{=entity}s,+        some `branch predictor`{=entity}s which         allow robots to evaluate conditional expressions, and some-        `strange loops` which enable recursive functions.  For example,+        `strange loop`{=entity}s which enable recursive functions.  For example,         one simple, useful recursive function is       - |+        ```         def forever = \c. c ; forever c end-      - Your goal is to acquire 256 lambdas.  Of course, in order to+        ```+      - |+        Your goal is to acquire 256 `lambda`{=entity}s.  Of course, in order to         accomplish this in a reasonable amount of time, it makes sense to plant-        a field of lambdas and then program one or more robots to+        a field of `lambda`{=entity}s and then program one or more robots to         harvest them in an automated way.-      - "TIP: the `ishere` command can be used to test for the presence of a-        (fully-grown) lambda, and the `has` command can be used to test whether-        a robot has a lambda in its inventory."+      - |+        **TIP:** the `ishere` command can be used to test for the presence of a+        (fully-grown) `lambda`{=entity}, and the `has` command can be used to test whether+        a robot has a `lambda`{=entity} in its inventory.     condition: |       try {         as base {@@ -39,7 +44,7 @@         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`.+        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@@ -87,3 +92,6 @@ seed: 0 world:   offset: true+  scrollable: false+  dsl: |+    "classic"
+ data/scenarios/Tutorials/give.yaml view
@@ -0,0 +1,75 @@+version: 1+name: Give+description: |+  Learn how to give items to other robots.+objectives:+  - goal:+      - |+        Robots can transfer items between them using the `give`+        command. This command takes two arguments: the target+        robot, and the name of the item to give.  The target robot+        is often the special `base` robot, but could be any robot.+      - In this scenario, you will need to collect the items scattered+        around your `base`, by `build`ing one or more robots to+        collect them and then `give` them to you.+    condition: |+      as base {+          bd <- has "board";+          b0 <- has "bit (0)";+          lx <- has "LaTeX";+          co <- has "copper ore";+          return $ bd && b0 && lx && co;+      };+solution: |+  build {+    turn back; move; turn right; move; move; move; grab;+    turn right; move; move; turn right; move; grab;+    move; move; move; move; turn right; move; grab;+    turn left; move; move; turn right; move; move; grab;+    turn right; move; move; move; move; turn right; move; move;+    give base "LaTeX";+    give base "board";+    give base "copper ore";+    give base "bit (0)";+  }+robots:+  - name: base+    dir: [0,1]+    heavy: true+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+    inventory:+      - [10, logger]+      - [10, compass]+      - [10, grabber]+      - [10, scanner]+      - [10, treads]+      - [10, solar panel]+known: [board, LaTeX, bit (0), copper ore]+world:+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    'w': [grass, board]+    '$': [grass, LaTeX]+    '0': [grass, bit (0)]+    'C': [grass, copper ore]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 3]+  map: |+    ┌─────────┐+    │.........│+    │..w......│+    │....Ω.0..│+    │.$.......│+    │........C│+    └─────────┘
data/scenarios/Tutorials/grab.yaml view
@@ -4,12 +4,12 @@   Learn how to interact with the world by grabbing entities. objectives:   - goal:-      - Previously you learned how to make new things (like a branch predictor) from ingredients.+      - 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 trees ahead of your robot; `move` to each one and `grab` it.+      - 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+        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 {@@ -35,7 +35,6 @@     inventory:       - [0, tree] world:-  default: [blank]   palette:     '>': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/lambda.yaml view
@@ -5,21 +5,23 @@ objectives:   - goal:       - Your goal in this challenge is to send a robot to grab the-        flower in the lower right (you don't need to bring it back).+        `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         the path that repeat four times; it seems like it could be really useful to have         a function to repeat a command four times.       - |-        To write a function, you use lambda syntax: in general, `\x. blah` is the-        function which takes an input (locally called `x`) and returns-        `blah` as its output (`blah` can of course refer to `x`). For example:+        To write a function, you use lambda syntax. As a simple example, `\x. x + 1` is the+        function which takes an input (locally called `x`{=snippet}) and returns+        one more than `x`{=snippet}. As another example:       - |+        ```         def x4 : cmd unit -> cmd unit = \c. c; c; c; c end-      - That is, `x4` is defined as the function which takes a command, called `c`,-        as input, and returns the command-        `c; c; c; c` which consists of executing `c` 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);@@ -58,7 +60,6 @@       - [0, boulder]       - [0, flower] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/move.yaml view
@@ -9,10 +9,10 @@       - 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.-      - Note that you can chain commands with semicolon, `;`.+        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.+        using **Ctrl+G**.     condition: |       r <- robotNamed "check1";       loc <- as r {has "Win"};@@ -23,13 +23,15 @@       - |         Previously you could move twice by chaining the move command:       - |+        ```         move; move+        ```       - To reuse that command without having to retype it press the upward         arrow on your keyboard. This will allow you to select previous commands.       - Ahead of you is a six steps long corridor. Move to its end, i.e. the-        coordinates (8,0) marked with the second purple flower.+        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.+        using **Ctrl+G**.     condition: |       r <- robotNamed "check2";       loc <- as r {has "Win"};@@ -39,22 +41,24 @@     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` device to read about the details.+      - 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` 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.+        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+        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 `;`, for example:+        Remember, you can chain commands with `;`{=snippet}, for example:       - |-        `move;move;move;move`+        ```+        move;move;move;move+        ```       - You can open this popup window at any time to remind yourself of the goal-        using Ctrl-G.+        using **Ctrl+G**.     condition: |       r <- robotNamed "check3";       loc <- as r {has "Win"};@@ -62,10 +66,10 @@   - 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.+        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.+        using **Ctrl+G**.     condition: |       r <- robotNamed "check4";       loc <- as r {has "Win"};@@ -91,7 +95,6 @@ known:   - flower world:-  default: [blank]   palette:     '.': [blank]     '*': [blank, flower]
data/scenarios/Tutorials/place.yaml view
@@ -11,21 +11,28 @@   - 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") ahead of you.  You could `grab`-        it as before, but you now have a new device called a `harvester`.+      - 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, `place "spruce"; harvest` will-        plant a new spruce seed.-      - Your goal is to collect 6 spruce trees.  You can speed this up+      - |+        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+        you can write:+        ```+        place "spruce"; harvest+        ```+      - 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-        `def t = move; place "spruce"; harvest; end` after which you only need to type `t`-        instead of retyping the whole command or searching in your command history.+        **TIP:** You can get a sneak peak at a feature we will explain later and type:+        ```+        def t = move; place "spruce"; harvest; end+        ```+        after which you only need to type `t`{=snippet} instead of retyping the whole+        command or searching in your command history.     condition: |       try {         t <- as base {count "spruce"};@@ -71,7 +78,6 @@     inventory:       - [0, spruce] world:-  default: [blank]   palette:     '>': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/require.yaml view
@@ -6,19 +6,20 @@   - 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`+        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`.+        them to `move`.  (To see what the `build` command will equip,+        you can type `requirements <e>`{=snippet} where `<e>`{=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`+        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 will be-        equipped on the new robot even though it does not execute any-        commands that use a 3D printer.+        `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` flower in its inventory.-      - "Hint: robots will drown in the water unless they have a `boat` device+        `periwinkle`{=entity} flower in its inventory.+      - "Hint: robots will drown in the `water`{=entity} unless they have a `boat`{=entity} device         equipped!"     condition: |       try {@@ -59,7 +60,6 @@       - [10, compass] known: [water] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/requireinv.yaml view
@@ -5,19 +5,20 @@ objectives:   - goal:       - In the previous tutorial challenge, you learned how to use-        `require` to require specific devices to be equipped.+        `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 <int> <name>` to require a certain number of copies of+        `require <int> <name>`{=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 flowers in its inventory.+        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 rocks!+        with `rock`{=entity}s!       - |         Remember that you can define commands to simplify your task, for example:-      - |-        `def PR = move; place "rock" end`+        ```+        def PR = move; place "rock" end+        ```     condition: |       def repeat = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} end;       def ifC = \test. \then. \else. b <- test; if b then else end;@@ -62,7 +63,6 @@       - [16, lambda]       - [100, rock] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/scan.yaml view
@@ -6,12 +6,12 @@   - 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` device.-      - Send one or more robots to move next to some of the unknown entities (marked as ?),+        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` in your inventory.+        the description of the `scanner`{=entity} in your inventory.     condition: |       try {         bm <- as base {knows "mountain"};@@ -45,7 +45,6 @@       - [10, treads]       - [10, solar panel] world:-  default: [blank]   palette:     'Ω': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/type-errors.yaml view
@@ -6,18 +6,18 @@   - goal:       - |         Let's see what happens when you enter something that does not type check.-        Try typing `turn 1` at the REPL prompt.  Clearly this is nonsense, and-        the expression will be highlighted in red.  To see what the error is, hit Enter.+        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**.         A box will pop up with a type (or parser) error.       - "Some other type errors for you to try:"       - |-        `turn move`+        `turn move`{=snippet}       - |-        `place tree` (without double quotes around "tree")+        `place tree`{=snippet} (without double quotes around `tree`{=snippet})       - |-        `move move`+        `move move`{=snippet}       - The last expression might give the most confusing error.-        Obviously we are just missing a `;` separating the two `move`+        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.@@ -49,7 +49,6 @@     inventory:       - [1, Win] world:-  default: [blank]   palette:     '>': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/types.yaml view
@@ -11,24 +11,24 @@         REPL prompt (you do not need to execute it).  If the expression type checks,         its type will be displayed in gray text at the top right of the window.       - For example, if you try typing `move`, you can see that it has-        type `cmd unit`, which means that `move` is a command which-        returns a value of the unit type (also written `()`).-      - As another example, you can see that `turn` has type `dir -> cmd unit`,+        type `cmd unit`{=type}, which means that `move` is a command which+        returns a value of the `unit`{=type} type (also written `()`).+      - 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+        `north`       - |-        move; move+        `move; move`       - |-        grab+        `grab`       - |-        make+        `make`       - |-        3+        `3`       - |-        "tree"+        `"tree"`       - Once you are done experimenting, execute `place "Win"` to finish this challenge and         move on to the next.     condition: |@@ -58,7 +58,6 @@     inventory:       - [1, Win] world:-  default: [blank]   palette:     '>': [grass, null, base]     '.': [grass]
data/scenarios/Tutorials/world101.yaml view
@@ -16,13 +16,13 @@         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` file+      - 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 trees. You can-        remind yourself of the available commands using F4.+      - 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"};@@ -43,15 +43,15 @@       - Now that you have a harvester, 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+      - "**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`, so you can+      - 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+      - "**TIP:** remember that you can click on cells in the world to see their         coordinates."     condition: |       try { as base {has "lambda"} } {return false}@@ -84,3 +84,6 @@ seed: 0 world:   offset: true+  scrollable: false+  dsl: |+    "classic"
+ data/scenarios/Vignettes/00-ORDER.txt view
@@ -0,0 +1,1 @@+roadway.yaml
+ data/scenarios/Vignettes/_roadway/coordinator.sw view
@@ -0,0 +1,55 @@+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+  returning the function's output value.+*/+def atLocation = \newLoc. \f.+    prevLoc <- whereami;+    teleport self newLoc;+    retval <- f;+    teleport self prevLoc;+    return retval;+    end;++def swapItem = \ent.+  create ent;+  emptyHere <- isempty;+  if emptyHere {} {grab; return ()};+  place ent;+  end;++def setRedPixel =+  instant $ (+    swapItem "pixel (R)";+  );+  end;++def setGreenPixel =+  instant $ (+    swapItem "pixel (G)";+  );+  end;++def changeToRed =+  say "Red light";+  make "bit (0)";+  setRedPixel;+  atLocation (17, 2) setGreenPixel;+  wait 50;+  end;++def changeToGreen =+  say "Green light";+  make "bit (1)";+  setGreenPixel;+  atLocation (17, 2) setRedPixel;+  wait 100;+  end;++def alternate =+  changeToGreen;+  changeToRed;+  end;++forever alternate;
+ data/scenarios/Vignettes/_roadway/drone.sw view
@@ -0,0 +1,200 @@+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 max = \a. \b.+    if (a > b) {a} {b};+    end;++def mapTuple = \f. \t.+    (f $ fst t, f $ snd t)+    end;++// modulus function (%)+def mod : int -> int -> int = \i.\m.+    i - m * (i / m)+end++def abs = \n. if (n < 0) {-n} {n} end++def isEven = \n.+    mod n 2 == 0;+    end++/*+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.+    let topCorner = (-18, 30) in+    absloc <- whereami;+    let loc = sumTuples absloc $ mapTuple (\x. -x) topCorner in+    let xloc = abs $ fst loc in+    let idx = xloc / 2 in++    let yloc = abs (snd loc) in+    +    randoffset <- random 5;+    let baseoffset = 10 * idx in+    let offset = randoffset + baseoffset in+    let isLongitudinal = not $ isEven yloc in+    let locdir = if isLongitudinal {+        if (isEven xloc) {+            (south, (lanes.xSouth, extents.yMax - offset))+        } {+            (north, (lanes.xNorth, extents.yMin + offset))+        }+    } {+        if (isEven xloc) {+            (east, (extents.xMin + offset, lanes.yEast))+        } {+            (west, (extents.xMax - offset, lanes.yWest))+        }+    } in+    turn $ fst locdir;+    teleport self $ snd locdir;+    return (isLongitudinal, idx);+    end;++def isGreenLight = \isLongitudinal.+    r <- robotnamed "stoplight";+    isGreen <- as r {has "bit (1)"};+    return $ isLongitudinal != isGreen;+    end;++def getCanMove :+    [xWest : int, xEast : int, ySouth : int, yNorth : int]+    -> bool+    -> cmd bool+    = \stoplines. \hasGreenLight.++    d <- heading;+    loc <- whereami;+    let atStopLine = if (d == north) {+        snd loc == stoplines.yNorth;+    } $ elif (d == south) {+        snd loc == stoplines.ySouth;+    } $ elif (d == east) {+        fst loc == stoplines.xEast;+    } $ else {+        // west+        fst loc == stoplines.xWest;+    } in++    eitherNeighbor <- meet;+    // TODO: Make sure we only consider the neighbor directly in front of us.+    neighborIsStopped <- case eitherNeighbor+        (\_. return false)+        (\r. as r {has "bit (0)"}); // zero-bit means stopped++    return $ hasGreenLight || not (atStopLine || neighborIsStopped);+    end;++def doTunnelWrap : [xMin : int, xMax : int, yMin : int, yMax : int] -> cmd bool = \extents.+    myloc <- whereami;+    didWrap <- if (fst myloc < extents.xMin) {+        teleport self (extents.xMax, snd myloc);+        return true;+    } $ elif (fst myloc > extents.xMax) {+        teleport self (extents.xMin, snd myloc);+        return true;+    } $ elif (snd myloc < extents.yMin) {+        teleport self (fst myloc, extents.yMax);+        return true;+    } $ elif (snd myloc > extents.yMax) {+        teleport self (fst myloc, extents.yMin);+        return true;+    } $ else {+        return false;+    };+    return didWrap;+    end;++def moveWithWrap :+       [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;+    canMove <- getCanMove stoplines hasGreenLight;++    wentThroughTunnel <- if canMove {+        move;+        doTunnelWrap extents;+    } {+        return false;+    };++    try {+        // Makes the "stopped" state queryable by other robots+        if canMove {make "bit (1)"} {make "bit (0)"}+    } {};++    return (canMove, wentThroughTunnel);+    end;++def getNewDelayState :+    bool+    -> [moveDelay : int, transitionCountdown : int]+    -> [moveDelay : int, transitionCountdown : int]+    = \canGo. \delayState.+    if (not canGo) {+        // reset to max delay and pause the countdown at max+        [moveDelay=5, transitionCountdown=2];+    } $ elif (delayState.moveDelay <= 0) {+        // unchanged+        delayState+    } $ elif (delayState.transitionCountdown > 0) {+        // decrement countdown+        [moveDelay=delayState.moveDelay, transitionCountdown=delayState.transitionCountdown - 1];+    } $ else {+        // Decrement the delay and reset the countdown.+        [moveDelay=max 0 $ delayState.moveDelay - 1, transitionCountdown=2];+    }+    end;++/**+Initially we wait several ticks between movements.+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+        = \idx. \isLongitudinal. \stoplines. \extents. \delayState.++    wait delayState.moveDelay;++    result <- instant $ moveWithWrap stoplines extents isLongitudinal;+    let canGo = fst result in+    let wentThroughTunnel = snd result in+    if wentThroughTunnel {+        r <- random 50;+        wait $ idx * 10 + r;+    } {};++    let newDelay = getNewDelayState canGo delayState in+    advance idx isLongitudinal stoplines extents newDelay;+    end;++def go =+    let extents = [xMin = -12, xMax=53, yMin = -15, yMax = 26] in+    let lanes = [yWest = 7, yEast = 5, xSouth = 20, xNorth = 22] in+    let stoplines = [xWest = 24, xEast = 17, ySouth = 9, yNorth = 2] in+    result <- instant $ init extents lanes;+    let isLongitudinal = fst result in+    let idx = snd result in+    advance idx isLongitudinal stoplines extents [moveDelay=5, transitionCountdown=2];+    end;++go;
+ data/scenarios/Vignettes/roadway.yaml view
@@ -0,0 +1,218 @@+creative: true+description: Commuting robots meet at an intersection+entities: []+name: Traffic simulation+robots:+  # We include a base robot to stabilize the screen at a fixed position.+  - name: base+    display:+      char: Ω+      attr: robot+    dir: [1, 0]+    loc: [10, 3]+    devices:+      - logger+      - hearing aid+      - treads+  - name: drone+    system: true+    display:+      invisible: false+    dir: [1, 0]+    devices:+      - lodestone+    inventory:+      - [1, bit (0)]+    program: |+      run "data/scenarios/Vignettes/_roadway/drone.sw"+  - name: stoplight+    system: true+    display:+      invisible: true+    dir: [0, 1]+    loc: [24, 9]+    devices:+      - lodestone+    inventory:+      - [1, bit (0)]+    program: |+      run "data/scenarios/Vignettes/_roadway/coordinator.sw"+version: 1+world:+  palette:+    '.': [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+  placements:+    - src: tunnel+      offset: [3, -21]+      orient:+        up: west+    - src: tunnel+      offset: [71, -21]+      orient:+        up: east+    - src: road segment+      offset: [6, -22]+      orient:+        up: south+        flip: true+    - src: road segment+      offset: [12, -22]+      orient:+        up: south+        flip: true+    - src: road segment+      offset: [18, -22]+      orient:+        up: south+        flip: true+    - src: road segment+      offset: [24, -22]+      orient:+        up: south+        flip: true+    - src: road segment+      offset: [30, -22]+      orient:+        up: south+        flip: true+    - src: intersection+      offset: [36, -22]+    - src: road segment+      offset: [42, -22]+    - src: road segment+      offset: [48, -22]+    - src: road segment+      offset: [54, -22]+    - src: road segment+      offset: [60, -22]+    - src: road segment+      offset: [66, -22]+    - src: road segment+      offset: [36, -28]+      orient:+        up: east+    - src: road segment+      offset: [36, -34]+      orient:+        up: east+    - src: road segment+      offset: [36, -40]+      orient:+        up: east+    - src: road segment+      offset: [36, -16]+      orient:+        up: west+        flip: true+    - src: road segment+      offset: [36, -10]+      orient:+        up: west+        flip: true+    - src: road segment+      offset: [36, -4]+      orient:+        up: west+        flip: true+  upperleft:+  - -18+  - 30+  map: |+    dddddddddd....................................................................+    dddddddd......................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................+    ..............................................................................
data/scenarios/blank.yaml view
@@ -11,4 +11,5 @@       char: Ω       attr: robot world:-  default: [grass]+  dsl: |+    {grass}
data/scenarios/classic.yaml view
@@ -29,5 +29,7 @@       - [50, clock]       - [5, toolkit] world:-  seed: null   offset: true+  scrollable: false+  dsl: |+    "classic"
data/scenarios/creative.yaml view
@@ -12,5 +12,6 @@       char: Ω       attr: robot world:-  seed: null   offset: true+  dsl: |+    "classic"
+ data/test/language-snippets/code-size/double-move-def-with-invocation.sw view
@@ -0,0 +1,3 @@+def doMove = move; move; end;++doMove;
+ data/test/language-snippets/code-size/double-move-let-with-invocation.sw view
@@ -0,0 +1,2 @@+let doMove = move; move in+doMove;
+ data/test/language-snippets/code-size/single-def-two-args-recursive-with-invocation.sw view
@@ -0,0 +1,3 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++doN 10 move;
+ data/test/language-snippets/code-size/single-def-two-args-recursive.sw view
@@ -0,0 +1,1 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
+ data/test/language-snippets/code-size/single-move-bare.sw view
@@ -0,0 +1,1 @@+move;
+ data/test/language-snippets/code-size/single-move-def-with-invocation.sw view
@@ -0,0 +1,3 @@+def doMove = move; end;++doMove;
+ data/test/language-snippets/code-size/single-move-def.sw view
@@ -0,0 +1,1 @@+def doMove = move; end
+ data/test/language-snippets/code-size/single-move-let-with-invocation.sw view
@@ -0,0 +1,2 @@+let doMove = move in+doMove;
+ data/worlds/classic.world view
@@ -0,0 +1,119 @@+/* See README.md for a thorough description of the world DSL.  Some+   comments are provided below to help explain the language by+   example. */++let+    /* pn0, pn1, pn2 are Perlin noise functions, which+       associate a floating-point value to every coordinate+       in a way that is random yet continuous (i.e. nearby+       coordinates have close floating-point values).  We use+       these to determine "biomes".  The four parameters+       represent seed, octaves, scale, and persistence. For+       an explanation of how these parameters affect+       the resulting noise function, see+       https://libnoise.sourceforge.net/glossary/index.html#perlinnoise++       'seed' is a special constant which holds the value of the seed used+       for world generation (whether chosen by the user, chosen randomly, etc.)+    */+    pn0 = perlin seed 6 0.05 0.6,+    pn1 = perlin (seed + 1) 6 0.05 0.6,+    pn2 = perlin (seed + 2) 6 0.05 0.6,++    // cl is another Perlin noise function that we use to generate+    // "clumps" of things inside biomes+    cl  = perlin seed 4 0.08 0.5,++    /* We now define some Boolean variables for determining which+       biome we are in.  Note that implicitly, as with everything+       in this world description DSL, these are actually+       parameterized over coordinates --- that is, we can get a different+       Boolean value associated to each coordinate.+    */+    big = pn0 > 0.0,  // 'big' is true for coordinates where pn0 > 0.0, and false otherwise+    hard = pn1 > 0.0, // etc.+    artificial = pn2 > 0.0,+    small = not big,+    soft = not hard,+    natural = not artificial+in+/* The world is built up by a series of layers, with each layer thought of as a function+   from coordinates to cell values.  The first layer is bottommost.+   The layers are combined coordinatewise according to the semigroup operation for+   cells.++   'mask b e' takes the value of 'e' where 'b' is true, and is empty elsewhere.++   '{x1, x2, ...}' specifies the value of a cell with a list of contents.  A cell+   can have at most one terrain value, and at most one entity, which are disambiguated+   by name (though one can also write e.g. '{entity: tree}' or '{terrain: dirt}' to+   disambiguate).++   'hash' is a special variable which takes on the value of a murmur3 hash applied+   to the coordinates; it can be used to obtain non-coherent randomness (i.e.+   random values such that nearby values are not correlated).++   'x' and 'y' are special variables which always take on the x- or y-value of the+   coordinates.+*/+overlay+[ mask (big && hard && artificial)+    (if (cl > 0.85) then {stone, copper ore} else {stone})+, mask (big && hard && natural)+  ( overlay+    [ {grass}  // grass by default+    // clumps of forest with LaTeX sprinkled in+    , mask (cl > 0.0) (if (hash % 30 == 1) then {dirt, LaTeX} else {dirt, tree})+    // random boulders scattered around+    , mask (hash % 30 == 0) {stone, boulder}+    // mountains in the middle of forests+    , mask (cl > 0.5) {stone, mountain}+    ]+  )+, mask (small && hard && natural)+  ( overlay+    [ {stone}+    , mask (hash % 10 == 0) {stone, rock}+    , mask (hash % 100 == 0) {stone, lodestone}+    ]+  )+, mask (big && soft && natural)+  ( overlay+    [ {dirt, water}+    , mask ((x + y) % 2 == 0) {dirt, wavy water}+    , mask (abs pn1 < 0.1) {dirt, sand}+    ]+  )+, mask (small && soft && natural)+  ( overlay+    [ {grass}+    , mask (hash % 20 == 10) {grass, cotton}+    , mask (hash % 20 == 0)  {grass, flower}+    ]+  )+, mask (small && soft && artificial)+  ( overlay+    [ {grass}+    , mask (hash % 10 == 0)+        (if (x + y) % 2 == 0 then {grass, bit (0)} else {grass, bit (1)})+    ]+  )+, mask (big && soft && artificial)+  ( overlay+    [ {dirt}+    , mask (cl > 0.5) {grass}+    , mask (hash % 5000 == 0) {dirt, Linux}+    ]+  )+, mask (small && hard && artificial)+  ( overlay+    [ {stone}+    , mask (hash % 50 == 0)+        let i = (x - y) % 3 in+        if (i == 0) then {stone, pixel (R)}+        else if (i == 1) then {stone, pixel (G)}+        else {stone, pixel (B)}+    , mask (hash % 120 == 1) {stone, lambda}+    ]+  )+]
editors/emacs/swarm-mode.el view
@@ -47,12 +47,16 @@                "split"                "charat"                "tochar"+               "key"              ))              (x-commands '(                "noop"                "wait"                "selfdestruct"                "move"+               "backup"+               "push"+               "stride"                "turn"                "grab"                "harvest"@@ -65,6 +69,7 @@                "equipped"                "count"                "drill"+               "use"                "build"                "salvage"                "reprogram"@@ -74,8 +79,18 @@                "view"                "appear"                "create"+               "halt"                "time"+               "scout"                "whereami"+               "waypoint"+               "detect"+               "resonate"+               "density"+               "sniff"+               "chirp"+               "watch"+               "surveil"                "heading"                "blocked"                "scan"@@ -92,20 +107,22 @@                "try"                "swap"                "atomic"+               "instant"+               "installkeyhandler"                "teleport"                "as"                "robotnamed"                "robotnumbered"                "knows"-               "north"-               "south"                "east"+               "north"                "west"+               "south"+               "down"+               "forward"                "left"-               "right"                "back"-               "forward"-               "down"+               "right"              ))              (x-types '("int" "text" "dir" "bool" "cmd" "void" "unit" "actor"))
editors/vscode/syntaxes/swarm.tmLanguage.json view
@@ -30,7 +30,7 @@ 				{ 				"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",+				"end": "\\s*in\\b", 				"beginCaptures": { 					"1": {"name": "entity.name.function"}, 					"3": {"name": "entity.name.type"}@@ -58,7 +58,7 @@ 				}, 				{ 				"name": "keyword.other",-				"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|noop|wait|selfdestruct|move|turn|grab|harvest|place|give|equip|unequip|make|has|equipped|count|drill|build|salvage|reprogram|say|listen|log|view|appear|create|time|whereami|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|teleport|as|robotnamed|robotnumbered|knows)\\b"+				"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|push|stride|turn|grab|harvest|place|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" 				} 			] 			},@@ -89,7 +89,7 @@ 			"patterns": [ 				{ 				"name": "variable.language.dir",-				"match": "\\b(?i)(north|south|east|west|left|right|back|forward|down)\\b"+				"match": "\\b(?i)(east|north|west|south|down|forward|left|back|right|)\\b" 				}, 				{ 				"name": "variable.parameter",
+ example/multi-key-handler.sw view
@@ -0,0 +1,20 @@+// Proof of concept illustrating the possibility of key+// handlers that process multi-key sequences.++def cons : a * b -> (a -> b) -> (a -> b) = \p. \k. \a.+  if (a == fst p) {snd p} {k a}+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.+  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 =+  cons (key "a", installKeyHandler "" (handlerB {handlerA})) nil+end
+ example/pilotmode.sw view
@@ -0,0 +1,26 @@+def cons : a * b -> (a -> b) -> (a -> b) = \p. \k. \a.+  if (a == fst p) {snd p} {k a}+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 =+  cons (key "Up",      move) $+  cons (key "Down",    turn back) $+  cons (key "Left",    turn left) $+  cons (key "Right",   turn right) $+  cons (key "S-Up",    turn north) $+  cons (key "S-Down",  turn south) $+  cons (key "S-Left",  turn west) $+  cons (key "S-Right", turn east) $+  cons (key "Del",     selfdestruct) $+  cons (key "g",       res <- grab; log res) $+  cons (key "h",       res <- harvest; log res) $+  cons (key "d",       res <- drill forward; case res (\_. return ()) log) $+  cons (key "s",       res <- scan forward; case res (\_. return ()) log) $+  cons (key "b",       b <- blocked; if b {log "blocked"} {log "not blocked"}) $+  cons (key "u",       upload base) $+  nil+end
+ src/Control/Carrier/Accum/FixedStrict.hs view
@@ -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 #-}
− src/Data/BoolExpr.hs 
@@ -1,337 +0,0 @@-{--Copyright (c) 2008, 2009, Nicolas Pouillard-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of the copyright holders nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoDeriveAnyClass #-}------------------------------------------------------------------------------------------------------------------------------------------------ |--- Module    : Data.BoolExpr--- Copyright : (c) Nicolas Pouillard 2008,2009--- License   : BSD3------ Maintainer: Nicolas Pouillard <nicolas.pouillard@gmail.com>--- Stability : provisional--- Portability:------ Boolean expressions and various representations.-module Data.BoolExpr (-  -- * A boolean class-  Boolean (..),--  -- * Boolean trees-  BoolExpr (..),-  reduceBoolExpr,-  evalBoolExpr,--  -- * Boolean evaluation semantic-  Eval (..),-  runEvalId,--  -- * Signed constants-  Signed (..),-  negateSigned,-  evalSigned,-  constants,-  negateConstant,--  -- * Conjunctive Normal Form-  CNF (..),-  Conj (..),-  boolTreeToCNF,--  -- * Disjunctive Normal Form-  Disj (..),-  DNF (..),-  boolTreeToDNF,--  -- * Other transformations-  dualize,-  fromBoolExpr,-  pushNotInwards,-)-where--import Control.Monad (ap)-import Data.Aeson-import Data.Char (toLower)-import Data.Traversable-import GHC.Generics (Generic)---- | Signed values are either positive or negative.-data Signed a = Positive a | Negative a-  deriving (Eq, Ord, Generic, Show, Read)--instance Functor Signed where-  fmap f (Positive x) = Positive (f x)-  fmap f (Negative x) = Negative (f x)--instance Traversable Signed where-  traverse f (Positive x) = Positive <$> f x-  traverse f (Negative x) = Negative <$> f x--instance Foldable Signed where-  foldMap = foldMapDefault--instance Applicative Signed where-  pure = Positive-  (<*>) = ap--instance Monad Signed where-  Positive x >>= f = f x-  Negative x >>= f = negateSigned $ f x--infix 9 /\-infix 9 \/---- | A boolean type class.-class Boolean f where-  (/\) :: f a -> f a -> f a-  (\/) :: f a -> f a -> f a-  bNot :: f a -> f a-  bTrue :: f a-  bFalse :: f a-  bConst :: Signed a -> f a---- | Syntax of boolean expressions parameterized over a--- set of leaves, named constants.-data BoolExpr a-  = BAnd (BoolExpr a) (BoolExpr a)-  | BOr (BoolExpr a) (BoolExpr a)-  | BNot (BoolExpr a)-  | BTrue-  | BFalse-  | BConst (Signed a)-  deriving (Eq, Ord, Generic, Show {-! derive : Arbitrary !-})--encodingOptions :: Options-encodingOptions =-  defaultOptions-    { sumEncoding = ObjectWithSingleField-    , constructorTagModifier = map toLower-    }--instance (ToJSON a) => ToJSON (Signed a) where-  toJSON = genericToJSON encodingOptions--instance (ToJSON a) => ToJSON (BoolExpr a) where-  toJSON = genericToJSON encodingOptions--instance (ToJSON a) => ToJSON (DNF a) where-  toJSON = genericToJSON encodingOptions--instance (ToJSON a) => ToJSON (CNF a) where-  toJSON = genericToJSON encodingOptions--instance (ToJSON a) => ToJSON (Conj a) where-  toJSON = genericToJSON encodingOptions--instance (ToJSON a) => ToJSON (Disj a) where-  toJSON = genericToJSON encodingOptions--instance Functor BoolExpr where-  fmap f (BAnd a b) = BAnd (fmap f a) (fmap f b)-  fmap f (BOr a b) = BOr (fmap f a) (fmap f b)-  fmap f (BNot t) = BNot (fmap f t)-  fmap _ BTrue = BTrue-  fmap _ BFalse = BFalse-  fmap f (BConst x) = BConst (fmap f x)--instance Traversable BoolExpr where-  traverse f (BAnd a b) = BAnd <$> traverse f a <*> traverse f b-  traverse f (BOr a b) = BOr <$> traverse f a <*> traverse f b-  traverse f (BNot t) = BNot <$> traverse f t-  traverse _ BTrue = pure BTrue-  traverse _ BFalse = pure BFalse-  traverse f (BConst x) = BConst <$> traverse f x--instance Foldable BoolExpr where-  foldMap = foldMapDefault--instance Boolean BoolExpr where-  (/\) = BAnd-  (\/) = BOr-  bNot = BNot-  bTrue = BTrue-  bFalse = BFalse-  bConst = BConst--newtype Eval b a = Eval {runEval :: (a -> b) -> b}--runEvalId :: Eval a a -> a-runEvalId e = runEval e id--instance b ~ Bool => Boolean (Eval b) where-  (/\) = liftE2 (&&)-  (\/) = liftE2 (||)-  bNot = liftE not-  bTrue = Eval $ const True-  bFalse = Eval $ const False-  bConst = Eval . flip evalSigned--liftE :: (b -> b) -> Eval b a -> Eval b a-liftE f (Eval x) = Eval (f . x)--liftE2 :: (b -> b -> b) -> Eval b a -> Eval b a -> Eval b a-liftE2 f (Eval x) (Eval y) = Eval (\e -> f (x e) (y e))---- | Turns a boolean tree into any boolean type.-fromBoolExpr :: Boolean f => BoolExpr a -> f a-fromBoolExpr (BAnd l r) = fromBoolExpr l /\ fromBoolExpr r-fromBoolExpr (BOr l r) = fromBoolExpr l \/ fromBoolExpr r-fromBoolExpr (BNot t) = bNot $ fromBoolExpr t-fromBoolExpr BTrue = bTrue-fromBoolExpr BFalse = bFalse-fromBoolExpr (BConst c) = bConst c----- | Disjunction of atoms ('a')-newtype Disj a = Disj {unDisj :: [a]}-  deriving (Show, Generic, Functor, Semigroup, Monoid)----- | Conjunction of atoms ('a')-newtype Conj a = Conj {unConj :: [a]}-  deriving (Show, Generic, Functor, Semigroup, Monoid)----- | Conjunctive Normal Form-newtype CNF a = CNF {unCNF :: Conj (Disj (Signed a))}-  deriving (Show, Generic, Semigroup, Monoid)----- | Disjunctive Normal Form-newtype DNF a = DNF {unDNF :: Disj (Conj (Signed a))}-  deriving (Show, Generic, Semigroup, Monoid)--instance Functor CNF where-  fmap f (CNF x) = CNF (fmap (fmap (fmap f)) x)--instance Boolean CNF where-  l /\ r = l `mappend` r-  l \/ r =-    CNF $-      Conj-        [ x `mappend` y | x <- unConj $ unCNF l, y <- unConj $ unCNF r-        ]-  bNot = error "bNot on CNF"-  bTrue = CNF $ Conj []-  bFalse = CNF $ Conj [Disj []]-  bConst x = CNF $ Conj [Disj [x]]--instance Functor DNF where-  fmap f (DNF x) = DNF (fmap (fmap (fmap f)) x)--instance Boolean DNF where-  l /\ r =-    DNF $-      Disj-        [ x `mappend` y | x <- unDisj $ unDNF l, y <- unDisj $ unDNF r-        ]-  l \/ r = l `mappend` r-  bNot = error "bNot on CNF"-  bTrue = DNF $ Disj [Conj []]-  bFalse = DNF $ Disj []-  bConst x = DNF $ Disj [Conj [x]]---- | Reduce a boolean tree annotated by booleans to a single boolean.-reduceBoolExpr :: BoolExpr Bool -> Bool-reduceBoolExpr = evalBoolExpr id---- Given a evaluation function of constants, returns an evaluation--- function over boolean trees.------ Note that since 'BoolExpr' is a functor, one can simply use--- 'reduceBoolExpr':------ @--- evalBoolExpr f = reduceBoolExpr . fmap (f$)--- @-evalBoolExpr :: (a -> Bool) -> (BoolExpr a -> Bool)-evalBoolExpr env expr = runEval (fromBoolExpr expr) env---- | Returns constants used in a given boolean tree, these--- constants are returned signed depending one how many--- negations stands over a given constant.-constants :: BoolExpr a -> [Signed a]-constants = go True- where-  go sign (BAnd a b) = go sign a ++ go sign b-  go sign (BOr a b) = go sign a ++ go sign b-  go sign (BNot t) = go (not sign) t-  go _ BTrue = []-  go _ BFalse = []-  go sign (BConst x) = [if sign then x else negateSigned x]--dualize :: Boolean f => BoolExpr a -> f a-dualize (BAnd l r) = dualize l \/ dualize r-dualize (BOr l r) = dualize l /\ dualize r-dualize BTrue = bFalse-dualize BFalse = bTrue-dualize (BConst c) = negateConstant c-dualize (BNot e) = fromBoolExpr e---- When dualize is used by pushNotInwards not BNot remain,--- hence it makes sense to assert that dualize does not--- have to work on BNot. However `dualize` can be freely--- used as a fancy `bNot`.--- dualize (BNot _)   = error "dualize: impossible"---- | Push the negations inwards as much as possible.--- The resulting boolean tree no longer use negations.-pushNotInwards :: Boolean f => BoolExpr a -> f a-pushNotInwards (BAnd l r) = pushNotInwards l /\ pushNotInwards r-pushNotInwards (BOr l r) = pushNotInwards l \/ pushNotInwards r-pushNotInwards (BNot t) = dualize $ pushNotInwards t-pushNotInwards BTrue = bTrue-pushNotInwards BFalse = bFalse-pushNotInwards (BConst c) = bConst c---- | Convert a boolean tree to a conjunctive normal form.-boolTreeToCNF :: BoolExpr a -> CNF a-boolTreeToCNF = pushNotInwards---- | Convert a boolean tree to a disjunctive normal form.-boolTreeToDNF :: BoolExpr a -> DNF a-boolTreeToDNF = pushNotInwards--evalSigned :: (a -> Bool) -> Signed a -> Bool-evalSigned f (Positive x) = f x-evalSigned f (Negative x) = not $ f x--negateSigned :: Signed a -> Signed a-negateSigned (Positive x) = Negative x-negateSigned (Negative x) = Positive x--negateConstant :: Boolean f => Signed a -> f a-negateConstant = bConst . negateSigned
src/Data/BoolExpr/Simplify.hs view
@@ -1,4 +1,7 @@--- | Simplification logic for boolean expressions that is not+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Simplification logic for boolean expressions that is not -- provided in the 'boolexpr' package. module Data.BoolExpr.Simplify (   cannotBeTrue,@@ -24,11 +27,11 @@  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+  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)) =
src/Swarm/App.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}  -- |--- Module      :  Swarm.App--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Main entry point for the Swarm application.@@ -12,14 +8,20 @@  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.Except+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.Game.Robot (ErrorLevel (..), LogSource (ErrorTrace, Said))+import Swarm.Language.Pretty (prettyText)+import Swarm.ReadableIORef (mkReadonly) import Swarm.TUI.Controller import Swarm.TUI.Model import Swarm.TUI.Model.StateUpdate@@ -46,9 +48,9 @@ --   some communication channels, and runs the UI. appMain :: AppOpts -> IO () appMain opts = do-  res <- runExceptT $ initAppState opts+  res <- runM . runThrow $ initAppState opts   case res of-    Left errMsg -> T.hPutStrLn stderr errMsg+    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@@ -74,9 +76,15 @@         upRel <- getNewerReleaseVersion (repoGitInfo opts)         writeBChan chan (UpstreamVersion upRel) -      -- Start the web service with a reference to the game state+      -- 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) appStateRef+      eport <-+        Swarm.Web.startWebThread+          (userWebPort opts)+          (mkReadonly appStateRef)+          chan        let logP p = logEvent Said ("Web API", -2) ("started on :" <> T.pack (show p))       let logE e = logEvent (ErrorTrace Error) ("Web API", -2) (T.pack e)@@ -107,23 +115,17 @@ demoWeb = do   let demoPort = 8080   res <--    runExceptT $-      initAppState $-        AppOpts-          { userSeed = Nothing-          , userScenario = demoScenario-          , scriptToRun = Nothing-          , autoPlay = False-          , cheatMode = False-          , colorMode = Nothing-          , userWebPort = Nothing-          , repoGitInfo = Nothing-          }+    runM . runThrow $ initAppState (defaultAppOpts {userScenario = demoScenario})   case res of-    Left errMsg -> T.putStrLn errMsg+    Left err -> T.putStrLn (prettyText @SystemFailure err)     Right s -> do       appStateRef <- newIORef s-      webMain Nothing demoPort appStateRef+      chan <- newBChan 5+      webMain+        Nothing+        demoPort+        (mkReadonly appStateRef)+        chan  where   demoScenario = Just "./data/scenarios/Testing/475-wait-one.yaml"
+ src/Swarm/Constant.hs view
@@ -0,0 +1,23 @@+{-# 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++-- By convention, all URL constants include trailing slashes+-- when applicable.++swarmRepoUrl :: Text+swarmRepoUrl = "https://github.com/swarm-game/swarm/"++wikiUrl :: Text+wikiUrl = swarmRepoUrl <> "wiki/"++wikiCheatSheet :: Text+wikiCheatSheet = wikiUrl <> "Commands-Cheat-Sheet"
+ src/Swarm/Doc/Gen.hs view
@@ -0,0 +1,587 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+module Swarm.Doc.Gen (+  generateDocs,+  GenerateDocs (..),+  EditorType (..),+  SheetType (..),++  -- ** Formatted keyword lists+  keywordsCommands,+  keywordsDirections,+  operatorNames,+  builtinFunctionList,+  editorList,++  -- ** Wiki pages+  PageAddress (..),+  commandsPage,+  capabilityPage,+  noPageAddresses,+) where++import Control.Effect.Lift+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)+import Data.Sequence (Seq)+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.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)+import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight)+import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory)+import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)+import Swarm.Game.World.Gen (extractEntities)+import Swarm.Game.World.Load (loadWorlds)+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 (ignoreWarnings, simpleErrorHandle)+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.+--+-- ----------------------------------------------------------------------------++data GenerateDocs where+  -- | Entity dependencies by recipes.+  RecipeGraph :: GenerateDocs+  -- | Keyword lists for editors.+  EditorKeywords :: Maybe EditorType -> GenerateDocs+  -- | List of special key names recognized by 'key' command+  SpecialKeyNames :: GenerateDocs+  CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs+  -- | List command introductions by tutorial+  TutorialCoverage :: GenerateDocs+  deriving (Eq, Show)++data EditorType = Emacs | VSCode+  deriving (Eq, Show, Enum, Bounded)++data SheetType = Entities | Commands | Capabilities | Recipes+  deriving (Eq, Show, Enum, Bounded)++data PageAddress = PageAddress+  { entityAddress :: Text+  , commandsAddress :: Text+  , capabilityAddress :: Text+  , recipesAddress :: Text+  }+  deriving (Eq, Show)++noPageAddresses :: PageAddress+noPageAddresses = PageAddress "" "" "" ""++generateDocs :: GenerateDocs -> IO ()+generateDocs = \case+  RecipeGraph -> generateRecipe >>= putStrLn+  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+  TutorialCoverage -> renderTutorialProgression >>= putStrLn . T.unpack++-- ----------------------------------------------------------------------------+-- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED+-- ----------------------------------------------------------------------------++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++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 "|"++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++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+-- ----------------------------------------------------------------------------++wrap :: Char -> Text -> Text+wrap c = T.cons c . flip T.snoc c++codeQuote :: Text -> Text+codeQuote = wrap '`'++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++addLink :: Text -> Text -> Text+addLink l t = T.concat ["[", t, "](", l, ")"]++tshow :: (Show a) => a -> Text+tshow = T.pack . show++-- ---------+-- 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 recipeRequirements r)+    , tshow $ view recipeTime r+    , tshow $ view recipeWeight r+    ]+ where+  formatCE (c, e) = T.unwords [tshow c, linkEntity $ view entityName e]+  linkEntity t =+    if T.null entityAddress+      then t+      else addLink (entityAddress <> "#" <> T.replace " " "-" t) t++recipeTable :: PageAddress -> [Recipe Entity] -> Text+recipeTable a rs = T.unlines $ header <> map (listToRow mw) recipeRows+ where+  mw = maxWidths (recipeHeader : recipeRows)+  recipeRows = map (recipeRow a) rs+  header = [listToRow mw recipeHeader, separatingLine mw]++recipePage :: PageAddress -> [Recipe Entity] -> Text+recipePage = recipeTable++-- ----------------------------------------------------------------------------+-- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES+-- ----------------------------------------------------------------------------++generateRecipe :: IO String+generateRecipe = simpleErrorHandle $ do+  entities <- loadEntities+  recipes <- loadRecipes entities+  worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities+  classic <- fst <$> loadScenario "data/scenarios/classic.yaml" entities worlds+  return . Dot.showDot $ recipesToDot classic (worlds ! "classic") entities recipes++recipesToDot :: Scenario -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot ()+recipesToDot classic 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 classic+      inv = startingInventory classic+      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 ..] (tail levels)+  let invisibleLine = zipWithM_ (.~>.)+  tls <- mapM (const hiddenNode) levels+  bls <- mapM (const hiddenNode) levels+  invisibleLine tls bls+  invisibleLine bls (tail 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 ^. recipeRequirements, 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 ^. recipeRequirements), 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)++startingHelper :: Scenario -> Robot+startingHelper = instantiateRobot 0 . head . view scenarioRobots++startingDevices :: Scenario -> Set Entity+startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . startingHelper++startingInventory :: Scenario -> Map Entity Int+startingInventory = Map.fromList . map swap . E.elems . view robotInventory . startingHelper++-- | 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")]
+ src/Swarm/Doc/Pedagogy.hs view
@@ -0,0 +1,243 @@+{-# 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 (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 $ 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++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
− src/Swarm/DocGen.hs 
@@ -1,585 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Swarm.DocGen (-  generateDocs,-  GenerateDocs (..),-  EditorType (..),-  SheetType (..),--  -- ** Formatted keyword lists-  keywordsCommands,-  keywordsDirections,-  operatorNames,-  builtinFunctionList,-  editorList,--  -- ** Wiki pages-  PageAddress (..),-  commandsPage,-  capabilityPage,-  noPageAddresses,-) where--import Control.Arrow (left)-import Control.Lens (view, (^.))-import Control.Lens.Combinators (to)-import Control.Monad (zipWithM, zipWithM_, (<=<))-import Control.Monad.Except (ExceptT, liftIO, runExceptT)-import Data.Bifunctor (Bifunctor (bimap))-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)-import Data.Set (Set)-import Data.Set qualified as Set-import Data.Text (Text, unpack)-import Data.Text qualified as T-import Data.Text.IO qualified as T-import Data.Tuple (swap)-import Data.Yaml (decodeFileEither)-import Data.Yaml.Aeson (prettyPrintParseException)-import Swarm.Game.Display (displayChar)-import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)-import Swarm.Game.Entity qualified as E-import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight)-import Swarm.Game.Robot (equippedDevices, instantiateRobot, robotInventory)-import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)-import Swarm.Game.WorldGen (testWorld2Entites)-import Swarm.Language.Capability (Capability)-import Swarm.Language.Capability qualified as Capability-import Swarm.Language.Pretty (prettyText)-import Swarm.Language.Syntax (Const (..))-import Swarm.Language.Syntax qualified as Syntax-import Swarm.Language.Typecheck (inferConst)-import Swarm.Util (getDataFileNameSafe, isRightOr, listEnums, quote)-import Text.Dot (Dot, NodeId, (.->.))-import Text.Dot qualified as Dot-import Witch (from)---- ============================================================================--- MAIN ENTRYPOINT TO CLI DOCUMENTATION GENERATOR--- ============================================================================------ These are the exported functions used by the executable.------ ------------------------------------------------------------------------------data GenerateDocs where-  -- | Entity dependencies by recipes.-  RecipeGraph :: GenerateDocs-  -- | Keyword lists for editors.-  EditorKeywords :: Maybe EditorType -> GenerateDocs-  CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs-  deriving (Eq, Show)--data EditorType = Emacs | VSCode-  deriving (Eq, Show, Enum, Bounded)--data SheetType = Entities | Commands | Capabilities | Recipes-  deriving (Eq, Show, Enum, Bounded)--data PageAddress = PageAddress-  { entityAddress :: Text-  , commandsAddress :: Text-  , capabilityAddress :: Text-  , recipesAddress :: Text-  }-  deriving (Eq, Show)--noPageAddresses :: PageAddress-noPageAddresses = PageAddress "" "" "" ""--generateDocs :: GenerateDocs -> IO ()-generateDocs = \case-  RecipeGraph -> generateRecipe >>= putStrLn-  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-  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 >>= guardRight "load entities"-        liftIO $ T.putStrLn $ capabilityPage address entities-      Entities -> simpleErrorHandle $ do-        let loadEntityList fp = left (from . prettyPrintParseException) <$> decodeFileEither fp-        let f = "entities.yaml"-        Just fileName <- liftIO $ getDataFileNameSafe f-        entities <- liftIO (loadEntityList fileName) >>= guardRight "load entities"-        liftIO $ T.putStrLn $ entitiesPage address entities-      Recipes -> simpleErrorHandle $ do-        entities <- loadEntities >>= guardRight "load entities"-        recipes <- loadRecipes entities >>= guardRight "load recipes"-        liftIO $ T.putStrLn $ recipePage address recipes---- ------------------------------------------------------------------------------- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED--- ------------------------------------------------------------------------------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--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 "|"--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.dirSyntax . Syntax.dirInfo) Syntax.allDirs--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 TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE--- ------------------------------------------------------------------------------wrap :: Char -> Text -> Text-wrap c = T.cons c . flip T.snoc c--codeQuote :: Text -> Text-codeQuote = wrap '`'--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--addLink :: Text -> Text -> Text-addLink l t = T.concat ["[", t, "](", l, ")"]--tshow :: Show a => a -> Text-tshow = T.pack . show---- ------------ 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"]-      <> [T.intercalate "\n\n" $ 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 recipeRequirements r)-    , tshow $ view recipeTime r-    , tshow $ view recipeWeight r-    ]- where-  formatCE (c, e) = T.unwords [tshow c, linkEntity $ view entityName e]-  linkEntity t =-    if T.null entityAddress-      then t-      else addLink (entityAddress <> "#" <> T.replace " " "-" t) t--recipeTable :: PageAddress -> [Recipe Entity] -> Text-recipeTable a rs = T.unlines $ header <> map (listToRow mw) recipeRows- where-  mw = maxWidths (recipeHeader : recipeRows)-  recipeRows = map (recipeRow a) rs-  header = [listToRow mw recipeHeader, separatingLine mw]--recipePage :: PageAddress -> [Recipe Entity] -> Text-recipePage = recipeTable---- ------------------------------------------------------------------------------- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES--- ------------------------------------------------------------------------------generateRecipe :: IO String-generateRecipe = simpleErrorHandle $ do-  entities <- loadEntities >>= guardRight "load entities"-  recipes <- loadRecipes entities >>= guardRight "load recipes"-  classic <- classicScenario-  return . Dot.showDot $ recipesToDot classic entities recipes--recipesToDot :: Scenario -> EntityMap -> [Recipe Entity] -> Dot ()-recipesToDot classic 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 classic-      inv = startingInventory classic-      worldEntites = Set.map (safeGetEntity $ entitiesByName emap) testWorld2Entites-      levels = recipeLevels recipes (Set.unions [worldEntites, 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) (toList testWorld2Entites)-  -- ---------------------------------------------------------------------------  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 worldEntites-  ls <- zipWithM subLevel [1 ..] (tail levels)-  let invisibleLine = zipWithM_ (.~>.)-  tls <- mapM (const hiddenNode) levels-  bls <- mapM (const hiddenNode) levels-  invisibleLine tls bls-  invisibleLine bls (tail 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 ^. recipeRequirements, 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 ^. recipeRequirements), 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)---- | Get classic scenario to figure out starting entities.-classicScenario :: ExceptT Text IO Scenario-classicScenario = do-  entities <- loadEntities >>= guardRight "load entities"-  fst <$> loadScenario "data/scenarios/classic.yaml" entities--startingDevices :: Scenario -> Set Entity-startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . instantiateRobot 0 . head . view scenarioRobots--startingInventory :: Scenario -> Map Entity Int-startingInventory = Map.fromList . map swap . E.elems . view robotInventory . instantiateRobot 0 . head . view scenarioRobots---- | 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")]---- ------------------------------------------------------------------------------- UTILITY--- ------------------------------------------------------------------------------both :: Bifunctor p => (a -> d) -> p a a -> p d d-both f = bimap f f--guardRight :: Text -> Either Text a -> ExceptT Text IO a-guardRight what i = i `isRightOr` (\e -> "Failed to " <> what <> ": " <> e)--simpleErrorHandle :: ExceptT Text IO a -> IO a-simpleErrorHandle = either (fail . unpack) pure <=< runExceptT
+ src/Swarm/Game/Achievement/Attainment.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Metadata about achievements that the player has obtained+module Swarm.Game.Achievement.Attainment 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++data Attainment = Attainment+  { _achievement :: CategorizedAchievement+  , _maybeScenarioPath :: Maybe FilePath+  -- ^ from which scenario was it obtained?+  , _obtainedAt :: ZonedTime+  }+  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 = tail -- drops leading underscore+    }
+ src/Swarm/Game/Achievement/Definitions.hs view
@@ -0,0 +1,94 @@+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Definitions of all possible achievements.+module Swarm.Game.Achievement.Definitions where++import Data.Aeson+import Data.Text (Text)+import GHC.Generics (Generic)+import Swarm.Util++data ExpectedEffort+  = Trivial+  | Easy+  | Moderate+  | Gruelling+  deriving (Eq, Ord, Show, Bounded, Enum, Generic, FromJSON, ToJSON)++data Quotation = Quotation+  { attribution :: Text+  , content :: Text+  }+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++data FlavorText+  = Freeform Text+  | FTQuotation Quotation+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++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 :: Text+  -- ^ Precisely what must be done to obtain this achievement.+  , effort :: ExpectedEffort+  , 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)++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+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+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)++instance FromJSON GameplayAchievement+instance ToJSON GameplayAchievement++listAchievements :: [CategorizedAchievement]+listAchievements =+  map GlobalAchievement listEnums+    <> map GameplayAchievement listEnums
+ src/Swarm/Game/Achievement/Description.hs view
@@ -0,0 +1,86 @@+{-# 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++describe :: CategorizedAchievement -> AchievementInfo+describe (GlobalAchievement CompletedSingleTutorial) =+  AchievementInfo+    "Welcome Freshmen"+    (Just $ Freeform "School is in session!")+    "Complete one of the tutorials."+    Easy+    False+describe (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+describe (GlobalAchievement LookedAtAboutScreen) =+  AchievementInfo+    "About time!"+    Nothing+    "View the About screen."+    Trivial+    True+describe (GameplayAchievement CraftedBitcoin) =+  -- Bitcoin is the deepest level of the recipes+  -- hierarchy.+  AchievementInfo+    "Master of Your Craft"+    Nothing+    "Make a Bitcoin"+    Moderate+    True+describe (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+describe (GameplayAchievement AttemptSelfDestructBase) =+  AchievementInfo+    "Call of the Void"+    (Just $ Freeform "What does that big red button do?")+    "Attempt to self-destruct your base."+    Easy+    True+describe (GameplayAchievement DestroyedBase) =+  AchievementInfo+    "That Could Have Gone Better"+    (Just $ Freeform "Boom.")+    "Actually destroy your base."+    Moderate+    True+describe (GameplayAchievement LoseScenario) =+  AchievementInfo+    "Silver Lining"+    (Just $ Freeform "Here's your consolation prize.")+    "Lose at a scenario."+    Easy+    True+describe (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
+ src/Swarm/Game/Achievement/Persistence.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Load/save logic for achievements.+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, warn)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath ((</>))++-- | Get path to swarm achievements, optionally creating necessary+--   directories.+getSwarmAchievementsPath :: Bool -> IO FilePath+getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement"++-- | Load saved info about achievements from XDG data directory.+-- Returns a tuple of warnings and 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+      warn $ AssetNotLoaded Achievement "." $ DoesNotExist Directory+      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
src/Swarm/Game/CESK.hs view
@@ -3,10 +3,6 @@ {-# LANGUAGE PatternSynonyms #-}  -- |--- Module      :  Swarm.Game.CESK--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- The Swarm interpreter uses a technique known as a@@ -82,6 +78,8 @@    -- ** Extracting information   finalValue,+  TickNumber (..),+  addTicks, ) where  import Control.Lens ((^.))@@ -90,7 +88,7 @@ import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IM import GHC.Generics (Generic)-import Prettyprinter (Doc, Pretty (..), hsep, (<+>))+import Prettyprinter (Doc, Pretty (..), encloseSep, hsep, (<+>)) import Swarm.Game.Entity (Count, Entity) import Swarm.Game.Exception import Swarm.Game.World (WorldUpdate (..))@@ -103,6 +101,15 @@ import Swarm.Language.Types import Swarm.Language.Value as V +newtype TickNumber = TickNumber {getTickNumber :: Integer}+  deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON)++addTicks :: Integer -> TickNumber -> TickNumber+addTicks i (TickNumber n) = TickNumber $ n + i++instance Pretty TickNumber where+  pretty (TickNumber i) = pretty i+ ------------------------------------------------------------ -- Frames and continuations ------------------------------------------------------------@@ -173,6 +180,12 @@     --   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.@@ -267,7 +280,7 @@     Up Exn Store Cont   | -- | The machine is waiting for the game to reach a certain time     --   to resume its execution.-    Waiting Integer CESK+    Waiting TickNumber CESK   deriving (Eq, Show, Generic, FromJSON, ToJSON)  -- | Is the CESK machine in a final (finished) state?  If so, extract@@ -372,6 +385,14 @@ 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
src/Swarm/Game/Display.hs view
@@ -5,16 +5,13 @@ -- Orphan Hashable instances needed to derive Hashable Display  -- |--- Module      :  Swarm.Game.Display--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- 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@@ -27,7 +24,6 @@    -- ** Rendering   displayChar,-  renderDisplay,   hidden,    -- ** Construction@@ -36,33 +32,55 @@   defaultRobotDisplay, ) where -import Brick (AttrName, Widget, str, withAttr) 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.TUI.Attr (entityAttr, robotAttr, worldPrefix) 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 --- Some orphan instances we need to be able to derive a Hashable--- instance for Display-instance Hashable AttrName+-- | 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 :: AttrName+  , _displayAttr :: Attribute   , _displayPriority :: Priority   , _invisible :: Bool   }@@ -74,7 +92,7 @@     | _invisible d2 = d1     | otherwise = maxOn _displayPriority d1 d2 -makeLensesWith (lensRules & generateSignatures .~ False) ''Display+makeLensesNoSigs ''Display  -- | The default character to use for display. defaultChar :: Lens' Display Char@@ -90,7 +108,7 @@ curOrientation :: Lens' Display (Maybe Direction)  -- | The attribute to use for display.-displayAttr :: Lens' Display AttrName+displayAttr :: Lens' Display Attribute  -- | This entity's display priority. Higher priorities are drawn --   on top of lower.@@ -112,7 +130,7 @@       Display c         <$> v .:? "orientationMap" .!= dOM         <*> v .:? "curOrientation" .!= (defD ^. curOrientation)-        <*> (fmap (worldPrefix <>) <$> v .:? "attr") .!= (defD ^. displayAttr)+        <*> (v .:? "attr") .!= (defD ^. displayAttr)         <*> v .:? "priority" .!= (defD ^. displayPriority)         <*> v .:? "invisible" .!= (defD ^. invisible) @@ -132,10 +150,6 @@   DAbsolute d <- disp ^. curOrientation   M.lookup d (disp ^. orientationMap) --- | Render a display as a UI widget.-renderDisplay :: Display -> Widget n-renderDisplay disp = withAttr (disp ^. displayAttr) $ str [displayChar disp]- -- | Modify a display to use a @?@ character for entities that are --   hidden/unknown. hidden :: Display -> Display@@ -143,7 +157,7 @@  -- | The default way to display some terrain using the given character --   and attribute, with priority 0.-defaultTerrainDisplay :: Char -> AttrName -> Display+defaultTerrainDisplay :: Char -> Attribute -> Display defaultTerrainDisplay c attr =   defaultEntityDisplay c     & displayPriority .~ 0@@ -157,7 +171,7 @@     { _defaultChar = c     , _orientationMap = M.empty     , _curOrientation = Nothing-    , _displayAttr = entityAttr+    , _displayAttr = AEntity     , _displayPriority = 1     , _invisible = False     }@@ -180,7 +194,7 @@           , (DNorth, '^')           ]     , _curOrientation = Nothing-    , _displayAttr = robotAttr+    , _displayAttr = ARobot     , _displayPriority = 10     , _invisible = False     }
src/Swarm/Game/Entity.hs view
@@ -2,10 +2,6 @@ {-# LANGUAGE TypeFamilies #-}  -- |--- Module      :  Swarm.Game.Entity--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- An 'Entity' represents an object that exists in the world.  Each@@ -82,10 +78,14 @@   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.IO.Class-import Data.Bifunctor (bimap, first)+import Control.Monad ((<=<))+import Data.Bifunctor (first) import Data.Char (toLower) import Data.Function (on) import Data.Hashable@@ -105,9 +105,14 @@ 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.Util (binTuples, dataNotFound, getDataFileNameSafe, plural, reflow, (?))-import Swarm.Util.Location+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@@ -124,6 +129,8 @@     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   | -- | Regenerates infinitely when grabbed or harvested.@@ -143,7 +150,7 @@     tryRead :: Text -> Parser EntityProperty     tryRead t = case readMaybe . from . T.toTitle $ t of       Just c -> return c-      Nothing -> fail $ "Unknown entity property " ++ from t+      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@@ -209,7 +216,7 @@   -- ^ 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 :: [Text]+  , _entityDescription :: Document Syntax   -- ^ A longer-form description. Each 'Text' value is one   --   paragraph.   , _entityOrientation :: Maybe Heading@@ -241,7 +248,7 @@       `hashWithSalt` disp       `hashWithSalt` nm       `hashWithSalt` pl-      `hashWithSalt` descr+      `hashWithSalt` docToText descr       `hashWithSalt` orient       `hashWithSalt` grow       `hashWithSalt` yld@@ -270,7 +277,7 @@   -- | Entity name   Text ->   -- | Entity description-  [Text] ->+  Document Syntax ->   -- | Properties   [EntityProperty] ->   -- | Capabilities@@ -311,12 +318,18 @@ -- | 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 :: [Entity] -> EntityMap-buildEntityMap es =-  EntityMap-    { entitiesByName = M.fromList . map (view entityName &&& id) $ es-    , entitiesByCap = M.fromListWith (<>) . concatMap (\e -> map (,[e]) (Set.toList $ e ^. entityCapabilities)) $ es-    }+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@@ -329,7 +342,7 @@               <$> v .: "display"               <*> v .: "name"               <*> v .:? "plural"-              <*> (map reflow <$> (v .: "description"))+              <*> (v .: "description")               <*> v .:? "orientation"               <*> v .:? "growth"               <*> v .:? "yields"@@ -343,7 +356,7 @@ instance FromJSONE EntityMap Entity where   parseJSONE = withTextE "entity name" $ \name ->     E $ \em -> case lookupEntityName name em of-      Nothing -> fail $ "Unknown entity: " ++ from @Text name+      Nothing -> failT ["Unknown entity:", name]       Just e -> return e  instance ToJSON Entity where@@ -361,14 +374,18 @@         ++ ["capabilities" .= (e ^. entityCapabilities) | not . null $ e ^. entityCapabilities]  -- | Load entities from a data file called @entities.yaml@, producing---   either an 'EntityMap' or a pretty-printed parse error.-loadEntities :: MonadIO m => m (Either Text EntityMap)-loadEntities = liftIO $ do-  let f = "entities.yaml"-  mayFileName <- getDataFileNameSafe f-  case mayFileName of-    Nothing -> Left <$> dataNotFound f-    Just fileName -> bimap (from . prettyPrintParseException) buildEntityMap <$> decodeFileEither fileName+--   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@@ -417,7 +434,7 @@  -- | A longer, free-form description of the entity.  Each 'Text' value --   represents a paragraph.-entityDescription :: Lens' Entity [Text]+entityDescription :: Lens' Entity (Document Syntax) entityDescription = hashedLens _entityDescription (\e x -> e {_entityDescription = x})  -- | The direction this entity is facing (if it has one).
src/Swarm/Game/Exception.hs view
@@ -2,10 +2,6 @@ {-# LANGUAGE OverloadedStrings #-}  -- |--- Module      :  Swarm.Game.Exception--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Runtime exceptions for the Swarm language interpreter.@@ -26,12 +22,13 @@ 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.TUI.Model.Achievement.Definitions import Swarm.Util import Witch (from) @@ -86,7 +83,7 @@     T.unlines       [ "Fatal error: " <> t       , "Please report this as a bug at"-      , "<https://github.com/swarm-game/swarm/issues/new>."+      , "<" <> swarmRepoUrl <> "issues/new>."       ]   InfiniteLoop -> "Infinite loop detected!"   (CmdFailed c t _) -> T.concat [prettyText c, ": ", t]@@ -105,9 +102,14 @@ -- | Pretty print the incapable exception with an actionable suggestion --   on how to fix it. ----- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" [] [] [CAppear]--- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" [] [] [CAppear]--- >>> m = buildEntityMap [w,r]+-- >>> 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)@@ -145,7 +147,7 @@         [ "Missing the " <> capMsg <> " for:"         , squote $ prettyText tm         , "but no device yet provides it. See"-        , "https://github.com/swarm-game/swarm/issues/26"+        , swarmRepoUrl <> "issues/26"         ]   | not (S.null caps) =       unlinesExText
+ src/Swarm/Game/Failure.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- A data type to represent system 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++data AssetData = AppAsset | NameGeneration | Entities | Recipes | Worlds | Scenarios | Script+  deriving (Eq, Show)++data Asset = Achievement | Data AssetData | History | Save+  deriving (Eq, Show)++data Entry = Directory | File+  deriving (Eq, Show)++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.++data OrderFileWarning+  = NoOrderFile+  | MissingFiles (NonEmpty FilePath)+  | DanglingFiles (NonEmpty FilePath)+  deriving (Eq, Show)++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 = const . 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
+ src/Swarm/Game/Location.hs view
@@ -0,0 +1,213 @@+{-# 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,+  nearestDirection,+  fromDirection,+  isCardinal,+  north,+  south,+  east,+  west,++  -- ** utility functions+  manhattan,+  euclidean,+  getElemsInArea,++  -- ** reexports 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++-- | A 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 '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 'Coords'.+type Location = Point V2 Int32++-- | A convenient way to pattern-match on '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.+--+--   '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 'Location's is a 'Heading' (via '.-.').+--   * A 'Location' plus a 'Heading' is another 'Location' (via '.^+').+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 :: 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 Direction+cardinalDirs =+  M.fromList $ map (toHeading &&& DAbsolute) 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 :: Heading -> Maybe Direction+toDirection v = M.lookup v cardinalDirs++-- | Example:+--      DWest `relativeTo` DSouth == DRight+relativeTo :: AbsoluteDir -> AbsoluteDir -> PlanarRelativeDir+relativeTo targetDir referenceDir =+  toEnum indexDiff+ where+  enumCount = length (Util.listEnums :: [AbsoluteDir])+  indexDiff = ((-) `on` fromEnum) targetDir referenceDir `mod` enumCount++-- | Logic adapted from:+-- https://gamedev.stackexchange.com/questions/49290/#comment213403_49300+nearestDirection :: Heading -> AbsoluteDir+nearestDirection coord =+  orderedDirs !! index+ where+  angle :: Double+  angle = unangle (fmap fromIntegral coord) / (2 * pi)++  index = round (fromIntegral enumCount * angle) `mod` enumCount+  orderedDirs = Util.listEnums+  enumCount = length orderedDirs++-- | 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 in 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
src/Swarm/Game/Log.hs view
@@ -2,10 +2,6 @@ {-# LANGUAGE TemplateHaskell #-}  -- |--- Module      :  Swarm.Game.Log--- Copyright   :  Ondřej Šebek--- Maintainer  :  ondras98@icloud.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A data type to represent in-game logs by robots.@@ -24,6 +20,7 @@    -- * Robot log entries   LogEntry (..),+  LogLocation (..),   leText,   leSource,   leRobotName,@@ -36,7 +33,9 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import GHC.Generics (Generic)-import Swarm.Util.Location (Location)+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.@@ -53,9 +52,12 @@     ErrorTrace ErrorLevel   deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) +data LogLocation a = Omnipresent | Located a+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)+ -- | An entry in a robot's log. data LogEntry = LogEntry-  { _leTime :: Integer+  { _leTime :: TickNumber   -- ^ The time at which the entry was created.   --   Note that this is the first field we sort on.   , _leSource :: LogSource@@ -64,7 +66,7 @@   -- ^ The name of the robot that generated the entry.   , _leRobotID :: Int   -- ^ The ID of the robot that generated the entry.-  , _leLocation :: Location+  , _leLocation :: LogLocation (Cosmic Location)   -- ^ Location of the robot at log entry creation.   , _leText :: Text   -- ^ The text of the log entry.
src/Swarm/Game/Recipe.hs view
@@ -2,10 +2,6 @@ {-# LANGUAGE TemplateHaskell #-}  -- |--- Module      :  Swarm.Game.Recipe--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A recipe represents some kind of process for transforming@@ -35,7 +31,12 @@   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)@@ -46,14 +47,13 @@ import Data.Text qualified as T import Data.Yaml import GHC.Generics (Generic)-import Witch--import Control.Algebra (Has)-import Control.Carrier.Lift (Lift, sendIO)-import Control.Carrier.Throw.Either (runThrow, throwError) import Swarm.Game.Entity as E-import Swarm.Util+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@@ -77,7 +77,7 @@ deriving instance ToJSON (Recipe Entity) deriving instance FromJSON (Recipe Entity) -makeLensesWith (lensRules & generateSignatures .~ False) ''Recipe+makeLensesNoSigs ''Recipe  -- | The inputs to a recipe. recipeInputs :: Lens' (Recipe e) (IngredientList e)@@ -115,11 +115,19 @@ instance FromJSON (Recipe Text) where   parseJSON = withObject "Recipe" $ \v ->     Recipe-      <$> v .: "in"-      <*> v .: "out"-      <*> v .:? "required" .!= []-      <*> v .:? "time" .!= 1-      <*> v .:? "weight" .!= 1+      <$> 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'@@ -139,17 +147,23 @@  -- | Given an already loaded 'EntityMap', try to load a list of --   recipes from the data file @recipes.yaml@.-loadRecipes :: (Has (Lift IO) sig m) => EntityMap -> m (Either Text [Recipe Entity])-loadRecipes em = runThrow $ do-  let f = "recipes.yaml"-  mayFileName <- sendIO $ getDataFileNameSafe f-  case mayFileName of-    Nothing -> sendIO (dataNotFound f) >>= throwError-    Just fileName -> do-      res <- sendIO $ decodeFileEither @[Recipe Text] fileName-      textRecipes <- res `isRightOr` (from @String @Text . prettyPrintParseException)-      resolveRecipes em textRecipes-        `isSuccessOr` (T.append "Unknown entities in recipe(s): " . T.intercalate ", ")+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"  ------------------------------------------------------------
+ src/Swarm/Game/ResourceLoading.hs view
@@ -0,0 +1,128 @@+{-# 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.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++-- | 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
src/Swarm/Game/Robot.hs view
@@ -7,10 +7,6 @@ {-# LANGUAGE ViewPatterns #-}  -- |--- Module      :  Swarm.Game.Robot--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A data type to represent robots.@@ -72,6 +68,7 @@   -- ** Query   robotKnows,   isActive,+  wantsToStep,   waitingUntil,   getResult, @@ -82,6 +79,7 @@ import Control.Lens hiding (contains) import Data.Aeson (FromJSON, ToJSON) import Data.Hashable (hashWithSalt)+import Data.Kind qualified import Data.Maybe (fromMaybe, isNothing) import Data.Sequence (Seq) import Data.Sequence qualified as Seq@@ -90,18 +88,23 @@ 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.Log+import Swarm.Game.Universe import Swarm.Language.Capability (Capability) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Requirement (ReqCtx)-import Swarm.Language.Syntax (toDirection)+import Swarm.Language.Syntax (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.Util.Location+import Swarm.Util.Lens (makeLensesExcluding) import Swarm.Util.Yaml import System.Clock (TimeSpec) @@ -166,12 +169,12 @@  -- | 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) :: * where-  RobotLocation 'TemplateRobot = Maybe Location-  RobotLocation 'ConcreteRobot = 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) :: * where+type family RobotID (phase :: RobotPhase) :: Data.Kind.Type where   RobotID 'TemplateRobot = ()   RobotID 'ConcreteRobot = RID @@ -208,14 +211,7 @@ -- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ -- for the approach used here with lenses. -let exclude = ['_robotCapabilities, '_equippedDevices, '_robotLog]- in makeLensesWith-      ( lensRules-          & generateSignatures .~ False-          & lensField . mapped . mapped %~ \fn n ->-            if n `elem` exclude then [] else fn n-      )-      ''RobotR+makeLensesExcluding ['_robotCapabilities, '_equippedDevices, '_robotLog] ''RobotR  -- | A template robot, i.e. a template robot record without a unique ID number, --   and possibly without a location.@@ -224,6 +220,9 @@ -- | A concrete robot, with a unique ID number and a specific location. type Robot = RobotR 'ConcreteRobot +instance ToSample Robot where+  toSamples _ = SD.noSamples+ -- 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.@@ -274,19 +273,19 @@ --   a getter, since when changing a robot's location we must remember --   to update the 'robotsByLocation' map as well.  You can use the --   'updateRobotLocation' function for this purpose.-robotLocation :: Getter Robot Location+robotLocation :: Getter Robot (Cosmic Location)  -- | Set a robot's location.  This is unsafe and should never be --   called directly except by the 'updateRobotLocation' function. --   The reason is that we need to make sure the 'robotsByLocation' --   map stays in sync.-unsafeSetRobotLocation :: Location -> Robot -> Robot+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 --   'robotsByLocation' map to keep up-to-date.-trobotLocation :: Lens' TRobot (Maybe Location)+trobotLocation :: Lens' TRobot (Maybe (Cosmic Location)) trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l})  -- | Which way the robot is currently facing.@@ -317,7 +316,7 @@ instantiateRobot i r =   r     { _robotID = i-    , _robotLocation = fromMaybe zero (_robotLocation r)+    , _robotLocation = fromMaybe defaultCosmicLocation $ _robotLocation r     }  -- | The ID number of the robot's parent, that is, the robot that@@ -447,7 +446,7 @@   -- | Name of the robot.   Text ->   -- | Description of the robot.-  [Text] ->+  Document Syntax ->   -- | Initial location.   RobotLocation phase ->   -- | Initial heading/direction.@@ -504,7 +503,7 @@      mkRobot () Nothing       <$> liftE (v .: "name")-      <*> liftE (v .:? "description" .!= [])+      <*> liftE (v .:? "description" .!= mempty)       <*> liftE (v .:? "loc")       <*> liftE (v .:? "dir" .!= zero)       <*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay)@@ -523,8 +522,16 @@ {-# 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 Integer+waitingUntil :: Robot -> Maybe TickNumber waitingUntil robot =   case _machine robot of     Waiting time _ -> Just time@@ -535,5 +542,5 @@ {-# INLINE getResult #-} getResult = finalValue . view machine -hearingDistance :: Num i => i+hearingDistance :: (Num i) => i hearingDistance = 32
src/Swarm/Game/Scenario.hs view
@@ -6,10 +6,6 @@ {-# LANGUAGE TemplateHaskell #-}  -- |--- Module      :  Swarm.Game.Scenario--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Scenarios are standalone worlds with specific starting and winning@@ -24,7 +20,7 @@   IndexedTRobot,    -- * Scenario-  Scenario,+  Scenario (..),    -- ** Fields   scenarioVersion,@@ -37,7 +33,8 @@   scenarioEntities,   scenarioRecipes,   scenarioKnown,-  scenarioWorld,+  scenarioWorlds,+  scenarioNavigation,   scenarioRobots,   scenarioObjectives,   scenarioSolution,@@ -49,31 +46,43 @@   getScenarioPath, ) where -import Control.Algebra (Has)-import Control.Carrier.Lift (Lift, sendIO)-import Control.Carrier.Throw.Either (Throw, throwError)-import Control.Lens hiding (from, (<.>))-import Control.Monad (filterM)+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.Text (Text) import Data.Text qualified as T-import Data.Yaml as Y 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.Cell 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.WorldDescription+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.Typecheck (WorldMap) import Swarm.Language.Pipeline (ProcessedTerm)-import Swarm.Util (getDataFileNameSafe)+import Swarm.Language.Pretty (prettyText)+import Swarm.Util (binTuples, failT)+import Swarm.Util.Effect (throwToMaybe, withThrow)+import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Util.Yaml import System.Directory (doesFileExist) import System.FilePath ((<.>), (</>))-import Witch (from, into)  ------------------------------------------------------------ -- Scenario@@ -92,36 +101,73 @@   , _scenarioEntities :: EntityMap   , _scenarioRecipes :: [Recipe Entity]   , _scenarioKnown :: [Text]-  , _scenarioWorld :: WorldDescription+  , _scenarioWorlds :: NonEmpty WorldDescription+  , _scenarioNavigation :: Navigation (M.Map SubworldName) Location   , _scenarioRobots :: [TRobot]   , _scenarioObjectives :: [Objective]   , _scenarioSolution :: Maybe ProcessedTerm   , _scenarioStepsPerTick :: Maybe Int   }-  deriving (Eq, Show)+  deriving (Show) -makeLensesWith (lensRules & generateSignatures .~ False) ''Scenario+makeLensesNoSigs ''Scenario -instance FromJSONE EntityMap Scenario where+instance FromJSONE (EntityMap, WorldMap) Scenario where   parseJSONE = withObjectE "scenario" $ \v -> do     -- parse custom entities-    em <- liftE (buildEntityMap <$> (v .:? "entities" .!= []))-    -- extend ambient EntityMap with custom entities+    emRaw <- liftE (v .:? "entities" .!= [])+    em <- case run . runThrow $ buildEntityMap emRaw of+      Right x -> return x+      Left x -> failT [prettyText @LoadingFailure x] -    withE em $ do+    -- 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 ->-          fail . into @String $-            "Unknown entities in 'known' list: " <> T.intercalate ", " unk+        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")@@ -133,7 +179,8 @@         <*> pure em         <*> v ..:? "recipes" ..!= []         <*> pure known-        <*> localE (,rsMap) (v ..: "world")+        <*> pure allWorlds+        <*> pure mergedNavigation         <*> pure rs         <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)         <*> liftE (v .:? "solution")@@ -178,9 +225,13 @@ --   not have to scan them. scenarioKnown :: Lens' Scenario [Text] --- | The starting world for the scenario.-scenarioWorld :: Lens' Scenario WorldDescription+-- | 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]@@ -200,36 +251,39 @@ -- Loading scenarios ------------------------------------------------------------ -getScenarioPath :: FilePath -> IO (Maybe FilePath)+getScenarioPath ::+  (Has (Lift IO) sig m) =>+  FilePath ->+  m (Maybe FilePath) getScenarioPath scenario = do-  libScenario <- getDataFileNameSafe $ "scenarios" </> scenario-  libScenarioExt <- getDataFileNameSafe $ "scenarios" </> scenario <.> "yaml"-+  libScenario <- throwToMaybe @SystemFailure $ getDataFileNameSafe Scenarios $ "scenarios" </> scenario+  libScenarioExt <- throwToMaybe @SystemFailure $ getDataFileNameSafe Scenarios $ "scenarios" </> scenario <.> "yaml"   let candidates = catMaybes [Just scenario, libScenarioExt, libScenario]-  listToMaybe <$> filterM doesFileExist candidates+  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 (Lift IO) sig m, Has (Throw Text) sig m) =>-  String ->+  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>+  FilePath ->   EntityMap ->+  WorldMap ->   m (Scenario, FilePath)-loadScenario scenario em = do-  mfileName <- sendIO $ getScenarioPath scenario-  case mfileName of-    Nothing -> throwError @Text $ "Scenario not found: " <> from @String scenario-    Just fileName -> (,fileName) <$> loadScenarioFile em fileName+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 (Lift IO) sig m, Has (Throw Text) sig m) =>+  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>   EntityMap ->+  WorldMap ->   FilePath ->   m Scenario-loadScenarioFile em fileName = do-  res <- sendIO $ decodeFileEitherE em fileName-  case res of-    Left parseExn -> throwError @Text (from @String (prettyPrintParseException parseExn))-    Right c -> return c+loadScenarioFile em worldMap fileName =+  (withThrow adaptError . (liftEither <=< sendIO)) $+    decodeFileEitherE (em, worldMap) fileName+ where+  adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml
− src/Swarm/Game/Scenario/Cell.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}--module Swarm.Game.Scenario.Cell (-  PCell (..),-  Cell,-) where--import Control.Lens hiding (from, (<.>))-import Control.Monad (when)-import Control.Monad.Extra (mapMaybeM)-import Data.Text (Text)-import Data.Vector qualified as V-import Data.Yaml as Y-import Swarm.Game.Entity-import Swarm.Game.Scenario.RobotLookup-import Swarm.Game.Terrain-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 :: Maybe 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---- | 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) Cell where-  parseJSONE = withArrayE "tuple" $ \v -> do-    let tup = V.toList v-    when (null tup) $ fail "palette entry must nonzero length (terrain, optional entity and then robots if any)"--    terr <- liftE $ parseJSON (head tup)--    ent <- case tup ^? ix 1 of-      Nothing -> return Nothing-      Just e -> do-        meName <- liftE $ parseJSON @(Maybe Text) e-        traverse (localE fst . getEntity) meName--    let name2rob r = do-          mrName <- liftE $ parseJSON @(Maybe Text) r-          traverse (localE snd . getRobot) mrName--    robs <- mapMaybeM name2rob (drop 2 tup)--    return $ Cell terr ent robs
src/Swarm/Game/Scenario/Objective.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Objective where  import Control.Applicative ((<|>))@@ -10,10 +12,14 @@ 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.TUI.Model.Achievement.Definitions-import Swarm.Util (reflow)+import Swarm.Language.Syntax (Syntax)+import Swarm.Language.Text.Markdown qualified as Markdown+import Swarm.Util.Lens (makeLensesNoSigs)  ------------------------------------------------------------ -- Scenario objectives@@ -60,7 +66,7 @@ -- | An objective is a condition to be achieved by a player in a --   scenario. data Objective = Objective-  { _objectiveGoal :: [Text]+  { _objectiveGoal :: Markdown.Document Syntax   , _objectiveTeaser :: Maybe Text   , _objectiveCondition :: ProcessedTerm   , _objectiveId :: Maybe ObjectiveLabel@@ -71,11 +77,14 @@   }   deriving (Eq, Show, Generic, ToJSON) -makeLensesWith (lensRules & generateSignatures .~ False) ''Objective+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 [Text]+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.@@ -113,7 +122,7 @@ instance FromJSON Objective where   parseJSON = withObject "objective" $ \v ->     Objective-      <$> (fmap . map) reflow (v .:? "goal" .!= [])+      <$> (v .:? "goal" .!= mempty)       <*> (v .:? "teaser")       <*> (v .: "condition")       <*> (v .:? "id")@@ -128,6 +137,11 @@   , 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
src/Swarm/Game/Scenario/Objective/Graph.hs view
@@ -1,6 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Utilities for performing graph analysis on Objective prerequisites+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Utilities for performing graph analysis on Objective prerequisites module Swarm.Game.Scenario.Objective.Graph where  import Control.Arrow ((&&&))@@ -15,6 +18,8 @@ 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@@ -40,6 +45,9 @@  instance ToJSON Graph where   toJSON = String . T.pack . show++instance ToSample GraphInfo where+  toSamples _ = SD.noSamples  getConstFromSigned :: BE.Signed a -> a getConstFromSigned = \case
src/Swarm/Game/Scenario/Objective/Logic.hs view
@@ -1,4 +1,7 @@--- | A model for defining boolean expressions for Objective prerequisites.+-- |+-- 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'.
− src/Swarm/Game/Scenario/Objective/Presentation/Model.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}---- A UI-centric model for Objective presentation.-module Swarm.Game.Scenario.Objective.Presentation.Model 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 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)---- | TODO: #1044 Could also add an "ObjectiveFailed" constructor...-newtype Announcement-  = ObjectiveCompleted Objective-  deriving (Show, Generic, ToJSON)--type CategorizedGoals = Map GoalStatus (NonEmpty Objective)--data GoalEntry-  = Header GoalStatus-  | Goal GoalStatus Objective--isHeader :: GoalEntry -> Bool-isHeader = \case-  Header _ -> True-  _ -> False--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)--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
− src/Swarm/Game/Scenario/Objective/Presentation/Render.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- Display logic for Objectives.-module Swarm.Game.Scenario.Objective.Presentation.Render 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.NonEmpty qualified as NE-import Data.Map.Strict qualified as M-import Data.Maybe (listToMaybe)-import Data.Vector qualified as V-import Swarm.Game.Scenario.Objective-import Swarm.Game.Scenario.Objective.Presentation.Model-import Swarm.TUI.Attr-import Swarm.TUI.Model.Name-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 = concatMap f $ M.toList categorizedObjs-  f (h, xs) = Header h : map (Goal h) (NE.toList xs)--renderGoalsDisplay :: GoalDisplay -> Widget Name-renderGoalsDisplay gd =-  if hasMultiple-    then-      hBox-        [ leftSide-        , hLimitPercent 70 $ padLeft (Pad 2) goalElaboration-        ]-    else goalElaboration- where-  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-  Header gs -> withAttr boldAttr $ str $ show gs-  Goal gs obj -> getCompletionIcon obj gs <+> titleWidget-   where-    textSource = obj ^. objectiveTeaser <|> obj ^. objectiveId <|> listToMaybe (obj ^. objectiveGoal)-    titleWidget = maybe (txt "?") withEllipsis textSource--singleGoalDetails :: GoalEntry -> Widget Name-singleGoalDetails = \case-  Header _gs -> displayParagraphs [" "]-  Goal _gs obj -> displayParagraphs $ obj ^. objectiveGoal
src/Swarm/Game/Scenario/Objective/Validation.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} --- | Validity checking for Objective prerequisites+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Validity checking for Objective prerequisites module Swarm.Game.Scenario.Objective.Validation where  import Control.Monad (unless)@@ -11,8 +14,7 @@ import Data.Text qualified as T import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph-import Swarm.Util (quote)-import Witch (into)+import Swarm.Util (failT, quote)  -- | Performs monadic validation before returning -- the "pure" construction of a wrapper record.@@ -28,21 +30,19 @@   for_ objectives $ \x -> case _objectivePrerequisite x of     Just p ->       unless (null remaining) $-        fail . into @String $-          T.unwords-            [ "Reference to undefined objective(s)"-            , T.intercalate ", " (map quote $ Set.toList remaining) <> "."-            , "Defined are:"-            , T.intercalate ", " (map quote $ Set.toList allIds)-            ]+        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) $-    fail . into @String $-      T.unwords ["There are dependency cycles in the prerequisites."]+    failT ["There are dependency cycles in the prerequisites."]    return objectives  where
src/Swarm/Game/Scenario/Objective/WinCheck.hs view
@@ -1,4 +1,9 @@--- | Utilities to check whether conditions are met for a game win/loss.+{-# 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@@ -9,6 +14,8 @@ 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 @@ -58,6 +65,9 @@ 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@@ -65,6 +75,9 @@   , prereqsSatisfied :: Bool   }   deriving (Generic, ToJSON)++instance ToSample PrereqSatisfaction where+  toSamples _ = SD.noSamples  -- | Used only by the web interface for debugging getSatisfaction :: ObjectiveCompletion -> [PrereqSatisfaction]
src/Swarm/Game/Scenario/RobotLookup.hs view
@@ -1,31 +1,40 @@ {-# 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 Text IndexedTRobot+type RobotMap = Map RobotName IndexedTRobot  -- | Create a 'RobotMap' from a list of robot templates. buildRobotMap :: [TRobot] -> RobotMap-buildRobotMap rs = M.fromList $ zipWith (\x y -> (view trobotName y, (x, y))) [0 ..] rs+buildRobotMap rs = M.fromList $ zipWith (\x y -> (RobotName $ view trobotName y, (x, y))) [0 ..] rs  ------------------------------------------------------------ -- Lookup utilities@@ -33,11 +42,11 @@  -- | Look up a thing by name, throwing a parse error if it is not --   found.-getThing :: String -> (Text -> m -> Maybe a) -> Text -> ParserE m a+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 -> fail $ "Unknown " <> thing <> " name: " ++ show name+    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@@ -47,5 +56,5 @@  -- | Look up a robot by name in a 'RobotMap', throwing a parse error --   if it is not found.-getRobot :: Text -> ParserE RobotMap IndexedTRobot+getRobot :: RobotName -> ParserE RobotMap IndexedTRobot getRobot = getThing "robot" M.lookup
+ src/Swarm/Game/Scenario/Scoring/Best.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | 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
+ src/Swarm/Game/Scenario/Scoring/CodeSize.hs view
@@ -0,0 +1,32 @@+-- | Types and utilities to compute code size+-- in terms of textual length and AST.+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
+ src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}++-- | 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
+ src/Swarm/Game/Scenario/Scoring/GenericMetrics.hs view
@@ -0,0 +1,61 @@+-- | 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
+ src/Swarm/Game/Scenario/Status.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | 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++getLaunchParams :: ScenarioStatus -> SerializableLaunchParams+getLaunchParams = \case+  NotStarted -> LaunchParams (pure Nothing) (pure Nothing)+  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
src/Swarm/Game/Scenario/Style.hs view
@@ -1,3 +1,5 @@+-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Style where  import Data.Aeson@@ -25,8 +27,11 @@ instance FromJSON StyleFlag where   parseJSON = genericParseJSON styleFlagJsonOptions +instance ToJSON StyleFlag where+  toJSON = genericToJSON styleFlagJsonOptions+ newtype HexColor = HexColor Text-  deriving (Eq, Show, Generic, FromJSON)+  deriving (Eq, Show, Generic, FromJSON, ToJSON)  data CustomAttr = CustomAttr   { name :: String@@ -35,3 +40,10 @@   , style :: Maybe (Set StyleFlag)   }   deriving (Eq, Show, Generic, FromJSON)++instance ToJSON CustomAttr where+  toJSON =+    genericToJSON+      defaultOptions+        { omitNothingFields = True+        }
+ src/Swarm/Game/Scenario/Topography/Area.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++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++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)++isEmpty :: AreaDimensions -> Bool+isEmpty (AreaDimensions w h) = w == 0 || h == 0++getAreaDimensions :: [[a]] -> AreaDimensions+getAreaDimensions cellGrid =+  AreaDimensions w h+ where+  w = fromIntegral $ maybe 0 length $ listToMaybe cellGrid -- column count+  h = fromIntegral $ length cellGrid -- row count
+ src/Swarm/Game/Scenario/Topography/Cell.hs view
@@ -0,0 +1,123 @@+{-# 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 (when)+import Control.Monad.Extra (mapMaybeM)+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 tup = V.toList v+    when (null tup) $ fail "palette entry must nonzero length (terrain, optional entity and then robots if any)"++    terr <- liftE $ parseJSON (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 tup)++    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
+ src/Swarm/Game/Scenario/Topography/EntityFacade.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DerivingVia #-}++-- | 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.Text (Text)+import Data.Yaml as Y (ToJSON (toJSON))+import Swarm.Game.Display (Display)+import Swarm.Game.Entity qualified as E++type EntityName = Text++-- | 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 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)
+ src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+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 '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 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-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
+ src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+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)
+ src/Swarm/Game/Scenario/Topography/Placement.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+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
+ src/Swarm/Game/Scenario/Topography/Structure.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+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 'Cell' 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
+ src/Swarm/Game/Scenario/Topography/WorldDescription.hs view
@@ -0,0 +1,117 @@+{-# 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
+ src/Swarm/Game/Scenario/Topography/WorldPalette.hs view
@@ -0,0 +1,128 @@+{-# 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
− src/Swarm/Game/Scenario/WorldDescription.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}--module Swarm.Game.Scenario.WorldDescription where--import Data.Aeson.Key qualified as Key-import Data.Aeson.KeyMap (KeyMap)-import Data.Aeson.KeyMap qualified as KeyMap-import Data.Text (Text)-import Data.Text qualified as T-import Data.Yaml as Y-import Swarm.Game.Entity-import Swarm.Game.Scenario.Cell-import Swarm.Game.Scenario.RobotLookup-import Swarm.Util.Location-import Swarm.Util.Yaml-import Witch (into)----------------------------------------------------------------- World description----------------------------------------------------------------- | A world palette maps characters to 'Cell' values.-newtype WorldPalette e = WorldPalette-  {unPalette :: KeyMap (PCell e)}-  deriving (Eq, Show)--instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where-  parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE---- | 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-  { defaultTerrain :: Maybe (PCell e)-  , offsetOrigin :: Bool-  , palette :: WorldPalette e-  , ul :: Location-  , area :: [[PCell e]]-  }-  deriving (Eq, Show)--type WorldDescription = PWorldDescription Entity--instance FromJSONE (EntityMap, RobotMap) WorldDescription where-  parseJSONE = withObjectE "world description" $ \v -> do-    pal <- v ..:? "palette" ..!= WorldPalette mempty-    WorldDescription-      <$> v ..:? "default"-      <*> liftE (v .:? "offset" .!= False)-      <*> pure pal-      <*> liftE (v .:? "upperleft" .!= origin)-      <*> liftE ((v .:? "map" .!= "") >>= paintMap pal)---- | "Paint" a world map using a 'WorldPalette', turning it from a raw---   string into a nested list of 'Cell' 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 => WorldPalette e -> Text -> m [[PCell e]]-paintMap pal = traverse (traverse toCell . into @String) . T.lines- where-  toCell c = case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of-    Nothing -> fail $ "Char not in world palette: " ++ show c-    Just cell -> return cell
src/Swarm/Game/ScenarioInfo.hs view
@@ -1,14 +1,8 @@ {-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-partial-fields #-}  -- -Wno-orphans is for the Eq/Ord Time instances  -- |--- Module      :  Swarm.Game.ScenarioStatus--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Saving and loading info about scenarios (status, path, etc.) as@@ -17,19 +11,17 @@   -- * Scenario info   ScenarioStatus (..),   _NotStarted,-  _InProgress,-  _Complete,   ScenarioInfo (..),   scenarioPath,   scenarioStatus,-  scenarioBestTime,-  scenarioBestTicks,-  updateScenarioInfoOnQuit,+  CodeSizeDeterminators (CodeSizeDeterminators),+  updateScenarioInfoOnFinish,   ScenarioInfoPair,    -- * Scenario collection   ScenarioCollection (..),   scenarioCollectionToList,+  flatten,   scenarioItemByPath,   normalizeScenarioPath,   ScenarioItem (..),@@ -46,130 +38,38 @@ ) where  import Control.Algebra (Has)-import Control.Carrier.Lift (Lift, sendIO)-import Control.Carrier.Throw.Either (Throw, runThrow, throwError)+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, unless, when)-import Data.Aeson (-  Options (..),-  defaultOptions,-  genericParseJSON,-  genericToEncoding,-  genericToJSON,- )-import Data.Char (isSpace, toLower)-import Data.Function (on)+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.Text (Text, pack)-import Data.Time (NominalDiffTime, ZonedTime, diffUTCTime, zonedTimeToUTC)+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Text (Text) import Data.Yaml as Y-import GHC.Generics (Generic) import Swarm.Game.Entity+import Swarm.Game.Failure+import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath) import Swarm.Game.Scenario-import Swarm.Util (dataNotFound, getDataDirSafe, getSwarmSavePath)+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) --- Some orphan ZonedTime instances--instance Eq ZonedTime where-  (==) = (==) `on` zonedTimeToUTC--instance Ord ZonedTime where-  (<=) = (<=) `on` zonedTimeToUTC---- | A @ScenarioStatus@ stores the status of a scenario along with---   appropriate metadata: not started, in progress, or complete.---   Note that "in progress" is currently a bit of a misnomer since---   games cannot be saved; at the moment it really means more like---   "you played this scenario before but didn't win".-data ScenarioStatus-  = NotStarted-  | InProgress-      { _scenarioStarted :: ZonedTime-      -- ^ Time when the scenario was started including time zone.-      , _scenarioElapsed :: NominalDiffTime-      -- ^ Time elapsed until quitting the scenario.-      , _scenarioElapsedTicks :: Integer-      -- ^ Ticks elapsed until quitting the scenario.-      }-  | Complete-      { _scenarioStarted :: ZonedTime-      -- ^ Time when the scenario was started including time zone.-      , _scenarioElapsed :: NominalDiffTime-      -- ^ Time elapsed until quitting the scenario.-      , _scenarioElapsedTicks :: Integer-      -- ^ Ticks elapsed until quitting the scenario.-      }-  deriving (Eq, Ord, Show, Read, Generic)--instance FromJSON ScenarioStatus where-  parseJSON = genericParseJSON scenarioOptions--instance ToJSON ScenarioStatus where-  toEncoding = genericToEncoding scenarioOptions-  toJSON = genericToJSON scenarioOptions---- | A @ScenarioInfo@ record stores metadata about a scenario: its---   canonical path, most recent status, and best-ever status.-data ScenarioInfo = ScenarioInfo-  { _scenarioPath :: FilePath-  , _scenarioStatus :: ScenarioStatus-  , _scenarioBestTime :: ScenarioStatus-  , _scenarioBestTicks :: 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)--scenarioOptions :: Options-scenarioOptions =-  defaultOptions-    { fieldLabelModifier = map toLower . drop (length "_scenario")-    }--makeLensesWith (lensRules & generateSignatures .~ False) ''ScenarioInfo---- | The path of the scenario, relative to @data/scenarios@.-scenarioPath :: Lens' ScenarioInfo FilePath---- | The status of the scenario.-scenarioStatus :: Lens' ScenarioInfo ScenarioStatus---- | The best status of the scenario, measured in real world time.-scenarioBestTime :: Lens' ScenarioInfo ScenarioStatus---- | The best status of the scenario, measured in game ticks.-scenarioBestTicks :: 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.-updateScenarioInfoOnQuit :: ZonedTime -> Integer -> Bool -> ScenarioInfo -> ScenarioInfo-updateScenarioInfoOnQuit z ticks completed (ScenarioInfo p s bTime bTicks) = case s of-  InProgress start _ _ ->-    let el = (diffUTCTime `on` zonedTimeToUTC) z start-        cur = (if completed then Complete else InProgress) start el ticks-        best f b = case b of-          Complete {} | not completed || f b <= f cur -> b -- keep faster completed-          InProgress {} | not completed && f b > f cur -> b -- keep longer progress (fun!)-          _ -> cur -- otherwise update with current-     in ScenarioInfo p cur (best _scenarioElapsed bTime) (best _scenarioElapsedTicks bTicks)-  _ -> error "Logical error: trying to quit scenario which is not in progress!"- -- ---------------------------------------------------------------------------- -- Scenario Item -- ----------------------------------------------------------------------------@@ -177,7 +77,7 @@ -- | 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 (Eq, Show)+  deriving (Show)  -- | Retrieve the name of a scenario item. scenarioItemName :: ScenarioItem -> Text@@ -191,14 +91,14 @@   { scOrder :: Maybe [FilePath]   , scMap :: Map FilePath ScenarioItem   }-  deriving (Eq, Show)+  deriving (Show)  -- | Access and modify ScenarioItems 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 :: (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@@ -208,15 +108,19 @@       SICollection n' col -> SICollection n' <$> ixp xs f col  -- | Canonicalize a scenario path, making it usable as a unique key.-normalizeScenarioPath :: ScenarioCollection -> FilePath -> IO FilePath+normalizeScenarioPath ::+  (MonadIO m) =>+  ScenarioCollection ->+  FilePath ->+  m FilePath normalizeScenarioPath col p =   let path = p -<.> "yaml"    in if isJust $ col ^? scenarioItemByPath path         then return path-        else do+        else liftIO $ do           canonPath <- canonicalizePath path-          Just ddir <- getDataDirSafe "." -- no way we got this far without data directory-          d <- canonicalizePath ddir+          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))@@ -227,71 +131,82 @@ 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 (Lift IO) sig m) => EntityMap -> m (Either Text ScenarioCollection)-loadScenarios em = runThrow $ do-  let p = "scenarios"-  mdataDir <- sendIO $ getDataDirSafe p-  case mdataDir of-    Nothing -> sendIO (dataNotFound p) >>= throwError-    Just dataDir -> loadScenarioDir em dataDir+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 (Lift IO) sig m, Has (Throw Text) sig m) =>+  (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>   EntityMap ->+  WorldMap ->   FilePath ->   m ScenarioCollection-loadScenarioDir em dir = do+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") $-        sendIO . putStrLn $-          "Warning: no "-            <> orderFileName-            <> " file found in "-            <> dirName-            <> ", using alphabetical order"+      when (dirName /= "Testing") . warn $+        OrderFileWarning (dirName </> orderFileName) NoOrderFile       return Nothing-    True -> Just . filter (not . null) . lines <$> sendIO (readFile orderFile)-  fs <- sendIO $ keepYamlOrPublicDirectory dir =<< listDirectory dir+    True -> Just <$> readOrderFile orderFile+  itemPaths <- sendIO $ keepYamlOrPublicDirectory dir =<< listDirectory dir    case morder of     Just order -> do-      let missing = fs \\ order-          dangling = order \\ fs+      let missing = itemPaths \\ order+          dangling = order \\ itemPaths -      unless (null missing) $-        sendIO . putStr . unlines $-          ( "Warning: while processing "-              <> (dirName </> orderFileName)-              <> ": files not listed in "-              <> orderFileName-              <> " will be ignored"-          )-            : map ("  - " <>) missing+      forM_ (NE.nonEmpty missing) $+        warn+          . OrderFileWarning (dirName </> orderFileName)+          . MissingFiles -      unless (null dangling) $-        sendIO . putStr . unlines $-          ( "Warning: while processing "-              <> (dirName </> orderFileName)-              <> ": nonexistent files will be ignored"-          )-            : map ("  - " <>) dangling+      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` fs) <$> morder-  SC morder' . M.fromList <$> mapM (\item -> (item,) <$> loadScenarioItem em (dir </> item)) fs+  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.@@ -311,7 +226,7 @@  -- | Load saved info about played scenario from XDG data directory. loadScenarioInfo ::-  (Has (Lift IO) sig m, Has (Throw Text) sig m) =>+  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>   FilePath ->   m ScenarioInfo loadScenarioInfo p = do@@ -320,10 +235,12 @@   hasInfo <- sendIO $ doesFileExist infoPath   if not hasInfo     then do-      return $ ScenarioInfo path NotStarted NotStarted NotStarted+      return $+        ScenarioInfo path NotStarted     else-      sendIO (decodeFileEither infoPath)-        >>= either (throwError . pack . prettyPrintParseException) return+      withThrow (AssetNotLoaded (Data Scenarios) infoPath . CanNotParseYaml)+        . (liftEither <=< sendIO)+        $ decodeFileEither infoPath  -- | Save info about played scenario to XDG data directory. saveScenarioInfo ::@@ -337,19 +254,27 @@ -- | Load a scenario item (either a scenario, or a subdirectory --   containing a collection of scenarios) from a particular path. loadScenarioItem ::-  (Has (Lift IO) sig m, Has (Throw Text) sig m) =>+  ( Has (Throw SystemFailure) sig m+  , Has (Accum (Seq SystemFailure)) sig m+  , Has (Lift IO) sig m+  ) =>   EntityMap ->+  WorldMap ->   FilePath ->   m ScenarioItem-loadScenarioItem em path = do+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 path+    True -> SICollection collectionName <$> loadScenarioDir em worldMap path     False -> do-      s <- loadScenarioFile em path-      si <- loadScenarioInfo path-      return $ SISingle (s, si)+      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
src/Swarm/Game/State.hs view
@@ -7,10 +7,6 @@ {-# LANGUAGE ViewPatterns #-}  -- |--- Module      :  Swarm.Game.State--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Definition of the record holding all the game-related state, and various related@@ -27,10 +23,13 @@   Announcement (..),   RunStatus (..),   Seed,+  Step (..),+  SingleStep (..),   GameState,    -- ** GameState fields   creativeMode,+  gameStep,   winCondition,   winSolution,   gameAchievements,@@ -40,6 +39,7 @@   robotMap,   robotsByLocation,   robotsAtLocation,+  robotsWatching,   robotsInArea,   baseRobot,   activeRobots,@@ -53,14 +53,16 @@   randGen,   adjList,   nameList,+  initiallyRunCode,   entityMap,   recipesOut,   recipesIn,   recipesReq,-  scenarios,   currentScenarioPath,   knownEntities,-  world,+  worldNavigation,+  multiWorld,+  worldScrollable,   viewCenterRule,   viewCenter,   needsRedraw,@@ -68,6 +70,7 @@   replNextValueIndex,   replWorking,   replActiveType,+  inputHandler,   messageQueue,   lastSeenMessageTime,   focusedRobotID,@@ -79,43 +82,58 @@   notificationsCount,   notificationsContent, +  -- ** Launch parameters+  LaunchParams,+  ValidatedLaunchParams,+   -- ** GameState initialization+  GameStateConfig (..),   initGameState,   scenarioToGameState,-  initGameStateForScenario,-  classicGame0,   CodeToRun (..),+  Sha1 (..),+  SolutionSource (..),+  parseCodeFile,    -- * Utilities   applyViewCenterRule,   recalcViewCenter,   modifyViewCenter,   viewingRegion,+  unfocus,   focusedRobot,+  RobotRange (..),+  focusedRange,   clearFocusedRobotLogUpdated,   addRobot,+  addRobotToLocation,   addTRobot,   emitMessage,+  wakeWatchingRobots,   sleepUntil,   sleepForever,   wakeUpRobotsDoneSleeping,   deleteRobot,+  removeRobotFromLocationMap,   activateRobot,   toggleRunStatus,   messageIsRecent,   messageIsFromNearby,+  getRunCodePath, ) where -import Control.Algebra (Has) 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.Except+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)@@ -124,6 +142,7 @@ 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@@ -132,56 +151,61 @@ import Data.Sequence qualified as Seq import Data.Set qualified as S import Data.Text (Text)-import Data.Text qualified as T (lines)-import Data.Text.IO qualified as T (readFile)-import Data.Time (getZonedTime)+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 Swarm.Game.CESK (emptyStore, finalValue, initMachine)+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,   inRecipeMap,-  loadRecipes,   outRecipeMap,   reqRecipeMap,  ) import Swarm.Game.Robot import Swarm.Game.Scenario.Objective-import Swarm.Game.Scenario.Objective.Presentation.Model+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.WorldGen (Seed, findGoodOrigin, testWorld2FromArray)+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.Pipeline (ProcessedTerm)-import Swarm.Language.Pipeline.QQ (tmQ)-import Swarm.Language.Syntax (Const, Term' (TText), allConst)+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.TUI.Model.Achievement.Attainment-import Swarm.TUI.Model.Achievement.Definitions-import Swarm.Util (getDataFileNameSafe, getElemsInArea, isRightOr, manhattan, uniq, (<+=), (<<.=), (?))-import Swarm.Util.Location+import Swarm.Util (applyWhen, binTuples, surfaceEmpty, uniq, (<+=), (<<.=), (?))+import Swarm.Util.Erasable+import Swarm.Util.Lens (makeLensesExcluding) import System.Clock qualified as Clock import System.Random (StdGen, mkStdGen, randomRIO)-import Witch (into)  ------------------------------------------------------------ -- Subsidiary data types ------------------------------------------------------------ -data CodeToRun-  = SuggestedSolution ProcessedTerm-  | ScriptPath FilePath- -- | The 'ViewCenterRule' specifies how to determine the center of the --   world viewport. data ViewCenterRule   = -- | The view should be centered on an absolute position.-    VCLocation Location+    VCLocation (Cosmic Location)   | -- | The view should be centered on a certain robot.     VCRobot RID   deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)@@ -227,6 +251,9 @@  makePrisms ''WinCondition +instance ToSample WinCondition where+  toSamples _ = SD.noSamples+ -- | A data type to keep track of the pause mode. data RunStatus   = -- | The game is running.@@ -260,6 +287,39 @@  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 ------------------------------------------------------------@@ -269,11 +329,44 @@ defaultRobotStepsPerTick :: Int defaultRobotStepsPerTick = 100 +-- | Type for remebering 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+ -- | 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+  , _gameStep :: Step   , _winCondition :: WinCondition   , _winSolution :: Maybe ProcessedTerm   , _gameAchievements :: Map GameplayAchievement Attainment@@ -292,9 +385,13 @@     -- 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-    -- append to a list than to a Set.-    _waitingRobots :: Map Integer [RID]-  , _robotsByLocation :: Map Location IntSet+    -- 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)   , _allDiscoveredEntities :: Inventory   , _availableRecipes :: Notifications (Recipe Entity)   , _availableCommands :: Notifications Const@@ -303,23 +400,26 @@   , _randGen :: StdGen   , _adjList :: Array Int Text   , _nameList :: Array Int Text+  , _initiallyRunCode :: Maybe ProcessedTerm   , _entityMap :: EntityMap   , _recipesOut :: IntMap [Recipe Entity]   , _recipesIn :: IntMap [Recipe Entity]   , _recipesReq :: IntMap [Recipe Entity]-  , _scenarios :: ScenarioCollection   , _currentScenarioPath :: Maybe FilePath   , _knownEntities :: [Text]-  , _world :: W.World Int Entity+  , _worldNavigation :: Navigation (M.Map SubworldName) Location+  , _multiWorld :: W.MultiWorld Int Entity+  , _worldScrollable :: Bool   , _viewCenterRule :: ViewCenterRule-  , _viewCenter :: Location+  , _viewCenter :: Cosmic Location   , _needsRedraw :: Bool   , _replStatus :: REPLStatus   , _replNextValueIndex :: Integer+  , _inputHandler :: Maybe (Text, Value)   , _messageQueue :: Seq LogEntry-  , _lastSeenMessageTime :: Integer+  , _lastSeenMessageTime :: TickNumber   , _focusedRobotID :: RID-  , _ticks :: Integer+  , _ticks :: TickNumber   , _robotStepsPerTick :: Int   } @@ -335,18 +435,14 @@   ]   ''GameState -let exclude = ['_viewCenter, '_focusedRobotID, '_viewCenterRule, '_activeRobots, '_waitingRobots, '_adjList, '_nameList]- in makeLensesWith-      ( lensRules-          & generateSignatures .~ False-          & lensField . mapped . mapped %~ \fn n ->-            if n `elem` exclude then [] else fn n-      )-      ''GameState+makeLensesExcluding ['_viewCenter, '_focusedRobotID, '_viewCenterRule, '_activeRobots, '_waitingRobots, '_adjList, '_nameList] ''GameState  -- | Is the user in creative mode (i.e. able to do anything without restriction)? creativeMode :: Lens' GameState Bool +-- | How to step the game - 'WorldTick' or 'RobotStep' for debugging the 'CESK' machine.+gameStep :: Lens' GameState Step+ -- | How to determine whether the player has won. winCondition :: Lens' GameState WinCondition @@ -357,7 +453,7 @@ -- | Map of in-game achievements that were attained gameAchievements :: Lens' GameState (Map GameplayAchievement Attainment) --- | A queue of global announcments.+-- | A queue of global announcements. -- Note that this is distinct from the "messageQueue", -- which is for messages emitted by robots. --@@ -383,25 +479,32 @@ --   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 Location IntSet)+robotsByLocation :: Lens' GameState (Map SubworldName (Map Location IntSet))  -- | Get a list of all the robots at a particular location.-robotsAtLocation :: Location -> GameState -> [Robot]+robotsAtLocation :: Cosmic Location -> GameState -> [Robot] robotsAtLocation loc gs =   mapMaybe (`IM.lookup` (gs ^. robotMap))     . maybe [] IS.toList-    . M.lookup loc+    . 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 :: Location -> Int32 -> GameState -> [Robot]-robotsInArea o d gs = map (rm IM.!) rids+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 rl+  rids =+    concatMap IS.elems $+      getElemsInArea o d $+        M.findWithDefault mempty subworldName rl  -- | The base robot, if it exists. baseRobot :: Traversal' GameState Robot@@ -423,7 +526,7 @@ -- | The names of the robots that are currently sleeping, indexed by wake up --   time. Note that this may not include all sleeping robots, particularly --   those that are only taking a short nap (e.g. wait 1).-waitingRobots :: Getter GameState (Map Integer [RID])+waitingRobots :: Getter GameState (Map TickNumber [RID]) waitingRobots = internalWaitingRobots  -- | A counter used to generate globally unique IDs.@@ -444,6 +547,10 @@ nameList :: Getter GameState (Array Int Text) nameList = to _nameList +-- | Code that is run upon scenario start, before any+-- REPL interaction.+initiallyRunCode :: Lens' GameState (Maybe ProcessedTerm)+ -- | The catalog of all entities that the game knows about. entityMap :: Lens' GameState EntityMap @@ -456,30 +563,34 @@ -- | All recipes the game knows about, indexed by requirement/catalyst. recipesReq :: Lens' GameState (IntMap [Recipe Entity]) --- | The collection of scenarios that comes with the game.-scenarios :: Lens' GameState ScenarioCollection- -- | The filepath of the currently running scenario. -- -- This is useful as an index to 'scenarios' collection, -- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'. currentScenarioPath :: Lens' GameState (Maybe FilePath) --- | The names of entities that should be considered "known", that is,+-- | The names of entities that should be considered \"known\", that is, --   robots know what they are without having to scan them. knownEntities :: Lens' GameState [Text] +-- | Includes a 'Map' of named locations and an+-- "Edge list" (graph) that maps portal entrances to exits+worldNavigation :: Lens' GameState (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+--   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.-world :: Lens' GameState (W.World Int Entity)+multiWorld :: Lens' GameState (W.MultiWorld Int Entity) +-- | Whether the world map is supposed to be scrollable or not.+worldScrollable :: Lens' GameState Bool+ -- | 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 Location+viewCenter :: Getter GameState (Cosmic Location) viewCenter = to _viewCenter  -- | Whether the world view needs to be redrawn.@@ -491,13 +602,16 @@ -- | The index of the next it{index} value replNextValueIndex :: Lens' GameState Integer +-- | The currently installed input handler and hint text.+inputHandler :: Lens' GameState (Maybe (Text, Value))+ -- | A queue of global messages. -- -- Note that we put the newest entry to the right. messageQueue :: Lens' GameState (Seq LogEntry)  -- | Last time message queue has been viewed (used for notification).-lastSeenMessageTime :: Lens' GameState Integer+lastSeenMessageTime :: Lens' GameState TickNumber  -- | The current robot in focus. --@@ -510,7 +624,7 @@ focusedRobotID = to _focusedRobotID  -- | The number of ticks elapsed since the game started.-ticks :: Lens' GameState Integer+ticks :: Lens' GameState TickNumber  -- | The maximum number of CESK machine steps a robot may take during --   a single tick.@@ -534,14 +648,14 @@   setter :: GameState -> ViewCenterRule -> GameState   setter g rule =     case rule of-      VCLocation v2 -> g {_viewCenterRule = rule, _viewCenter = v2}+      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 v2 -> g {_viewCenterRule = rule, _viewCenter = v2, _focusedRobotID = rid}+              Just loc -> g {_viewCenterRule = rule, _viewCenter = loc, _focusedRobotID = rid}  -- | Whether the repl is currently working. replWorking :: Getter GameState Bool@@ -580,16 +694,24 @@         <> Seq.filter ((== gs ^. focusedRobotID) . view leRobotID) mq  messageIsRecent :: GameState -> LogEntry -> Bool-messageIsRecent gs e = e ^. leTime >= gs ^. ticks - 1+messageIsRecent gs e = addTicks 1 (e ^. leTime) >= gs ^. ticks -messageIsFromNearby :: Location -> LogEntry -> Bool-messageIsFromNearby l e = manhattan l (e ^. leLocation) <= hearingDistance+-- | Reconciles the possibilities of log messages being+-- omnipresent and robots being in different worlds+messageIsFromNearby :: Cosmic Location -> LogEntry -> Bool+messageIsFromNearby l e = case e ^. leLocation of+  Omnipresent -> True+  Located x -> f x+ 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+--   is 'Maybe' because the rule may refer to a robot which does not --   exist.-applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe Location+applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location) applyViewCenterRule (VCLocation l) _ = Just l applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation @@ -606,25 +728,34 @@     & (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id)  where   oldViewCenter = g ^. viewCenter-  newViewCenter = fromMaybe oldViewCenter (applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap))+  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 :: (Location -> Location) -> GameState -> GameState+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 :: GameState -> (Int32, Int32) -> (W.Coords, W.Coords)-viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax))+viewingRegion :: GameState -> (Int32, Int32) -> Cosmic W.BoundsRectangle+viewingRegion g (w, h) = Cosmic sw (W.Coords (rmin, cmin), W.Coords (rmax, cmax))  where-  Location cx cy = g ^. viewCenter+  Cosmic sw (Location cx cy) = g ^. viewCenter   (rmin, rmax) = over both (+ (-cy - h `div` 2)) (0, h - 1)   (cmin, cmax) = over both (+ (cx - w `div` 2)) (0, w - 1) @@ -633,8 +764,71 @@ 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.+--   * 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 <$ focusedRobot g+ where+  checkRange = case r of+    InfinitelyFar -> Far+    Measurable r' -> computedRange r'++  computedRange r'+    | g ^. creativeMode || g ^. worldScrollable || r' <= minRadius = Close+    | r' > maxRadius = Far+    | otherwise = MidRange $ (r' - minRadius) / (maxRadius - minRadius)++  -- Euclidean distance from the base to the view center.+  r = case g ^. robotMap . at 0 of+    -- if the base doesn't exist, we have bigger problems+    Nothing -> InfinitelyFar+    Just br -> cosmoMeasure euclidean (g ^. viewCenter) (br ^. robotLocation)++  -- See whether the base or focused robot have antennas installed.+  baseInv, focInv :: Maybe Inventory+  baseInv = g ^? robotMap . ix 0 . equippedDevices+  focInv = view equippedDevices <$> focusedRobot g++  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 :: (Has (State GameState) sig m) => m () clearFocusedRobotLogUpdated = do   n <- use focusedRobotID   robotMap . ix n . robotLogUpdated .= False@@ -643,7 +837,7 @@ --   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 :: (Has (State GameState) sig m) => TRobot -> m Robot addTRobot r = do   rid <- gensym <+= 1   let r' = instantiateRobot rid r@@ -653,20 +847,28 @@ -- | 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 :: (Has (State GameState) sig m) => Robot -> m () addRobot r = do   let rid = r ^. robotID    robotMap %= IM.insert rid r-  robotsByLocation-    %= M.insertWith IS.union (r ^. robotLocation) (IS.singleton rid)+  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 :: (Has (State GameState) sig m) => LogEntry -> m () emitMessage msg = messageQueue %= (|> msg) . dropLastIfLong  where   tooLong s = Seq.length s >= maxMessageQueueSize@@ -675,23 +877,23 @@  -- | Takes a robot out of the activeRobots set and puts it in the waitingRobots --   queue.-sleepUntil :: Has (State GameState) sig m => RID -> Integer -> m ()+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 :: (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 :: (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 :: (Has (State GameState) sig m) => m () wakeUpRobotsDoneSleeping = do   time <- use ticks   mrids <- internalWaitingRobots . at time <<.= Nothing@@ -702,82 +904,179 @@       let aliveRids = filter (`IM.member` robots) rids       internalActiveRobots %= IS.union (IS.fromList aliveRids) -deleteRobot :: Has (State GameState) sig m => RID -> m ()+      -- 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 watching this location.+--+-- NOTE: Clearing "TickNumber" map entries from "internalWaitingRobots"+-- upon wakeup is handled by "wakeUpRobotsDoneSleeping" in State.hs+wakeWatchingRobots :: (Has (State GameState) sig m) => Cosmic Location -> m ()+wakeWatchingRobots loc = do+  currentTick <- use 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.-    robotsByLocation . ix (robot ^. robotLocation) %= IS.delete rn+    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 ------------------------------------------------------------ --- | Create an initial game state record, first loading entities and---   recipes from disk.-initGameState :: ExceptT Text IO GameState-initGameState = do-  let guardRight what i = i `isRightOr` (\e -> "Failed to " <> what <> ": " <> e)-  entities <- loadEntities >>= guardRight "load entities"-  recipes <- loadRecipes entities >>= guardRight "load recipes"-  loadedScenarios <- loadScenarios entities >>= guardRight "load scenarios"+type LaunchParams a = ParameterizableLaunchParams CodeToRun a -  let markEx what a = catchError a (\e -> fail $ "Failed to " <> what <> ": " <> show e)+-- | 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 -  (adjs, names) <- liftIO . markEx "load name generation data" $ do-    -- if data directory did not exist we would have failed loading scenarios-    Just adjsFile <- getDataFileNameSafe "adjectives.txt"-    as <- tail . T.lines <$> T.readFile adjsFile-    Just namesFile <- getDataFileNameSafe "names.txt"-    ns <- tail . T.lines <$> T.readFile namesFile-    return (as, ns)+-- | Record to pass information needed to create an initial+--   'GameState' record when starting a scenario.+data GameStateConfig = GameStateConfig+  { initAdjList :: Array Int Text+  , initNameList :: Array Int Text+  , initEntities :: EntityMap+  , initRecipes :: [Recipe Entity]+  , initWorldMap :: WorldMap+  } -  return $-    GameState-      { _creativeMode = False-      , _winCondition = NoWinCondition-      , _winSolution = Nothing-      , -- This does not need to be initialized with anything,-        -- since the master list of achievements is stored in UIState-        _gameAchievements = mempty-      , _announcementQueue = mempty-      , _runStatus = Running-      , _robotMap = IM.empty-      , _robotsByLocation = M.empty-      , _availableRecipes = mempty-      , _availableCommands = mempty-      , _allDiscoveredEntities = empty-      , _activeRobots = IS.empty-      , _waitingRobots = M.empty-      , _gensym = 0-      , _seed = 0-      , _randGen = mkStdGen 0-      , _adjList = listArray (0, length adjs - 1) adjs-      , _nameList = listArray (0, length names - 1) names-      , _entityMap = entities-      , _recipesOut = outRecipeMap recipes-      , _recipesIn = inRecipeMap recipes-      , _recipesReq = reqRecipeMap recipes-      , _scenarios = loadedScenarios-      , _currentScenarioPath = Nothing-      , _knownEntities = []-      , _world = W.emptyWorld (fromEnum StoneT)-      , _viewCenterRule = VCRobot 0-      , _viewCenter = origin-      , _needsRedraw = False-      , _replStatus = REPLDone Nothing-      , _replNextValueIndex = 0-      , _messageQueue = Empty-      , _lastSeenMessageTime = -1-      , _focusedRobotID = 0-      , _ticks = 0-      , _robotStepsPerTick = defaultRobotStepsPerTick-      }+-- | Create an initial, fresh game state record when starting a new scenario.+initGameState :: GameStateConfig -> GameState+initGameState gsc =+  GameState+    { _creativeMode = False+    , _gameStep = WorldTick+    , _winCondition = NoWinCondition+    , _winSolution = Nothing+    , -- This does not need to be initialized with anything,+      -- since the master list of achievements is stored in UIState+      _gameAchievements = mempty+    , _announcementQueue = mempty+    , _runStatus = Running+    , _robotMap = IM.empty+    , _robotsByLocation = M.empty+    , _robotsWatching = mempty+    , _availableRecipes = mempty+    , _availableCommands = mempty+    , _allDiscoveredEntities = empty+    , _activeRobots = IS.empty+    , _waitingRobots = M.empty+    , _gensym = 0+    , _seed = 0+    , _randGen = mkStdGen 0+    , _adjList = initAdjList gsc+    , _nameList = initNameList gsc+    , _initiallyRunCode = Nothing+    , _entityMap = initEntities gsc+    , _recipesOut = outRecipeMap (initRecipes gsc)+    , _recipesIn = inRecipeMap (initRecipes gsc)+    , _recipesReq = reqRecipeMap (initRecipes gsc)+    , _currentScenarioPath = Nothing+    , _knownEntities = []+    , _worldNavigation = Navigation mempty mempty+    , _multiWorld = mempty+    , _worldScrollable = True+    , _viewCenterRule = VCRobot 0+    , _viewCenter = defaultCosmicLocation+    , _needsRedraw = False+    , _replStatus = REPLDone Nothing+    , _replNextValueIndex = 0+    , _inputHandler = Nothing+    , _messageQueue = Empty+    , _lastSeenMessageTime = TickNumber (-1)+    , _focusedRobotID = 0+    , _ticks = TickNumber 0+    , _robotStepsPerTick = defaultRobotStepsPerTick+    } --- | Set a given scenario as the currently loaded scenario in the game state.-scenarioToGameState :: Scenario -> Maybe Seed -> Maybe CodeToRun -> GameState -> IO GameState-scenarioToGameState scenario userSeed toRun g = do+-- | 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@@ -790,53 +1089,54 @@   let robotList' = (robotCreatedAt .~ now) <$> robotList    return $-    g-      { _creativeMode = scenario ^. scenarioCreative-      , _winCondition = theWinCondition-      , _winSolution = scenario ^. scenarioSolution-      , _runStatus = Running-      , _robotMap = IM.fromList $ map (view robotID &&& id) robotList'-      , _robotsByLocation =-          M.fromListWith IS.union $-            map (view robotLocation &&& (IS.singleton . view robotID)) robotList'-      , _activeRobots = setOf (traverse . robotID) robotList'-      , _availableCommands = Notifications 0 initialCommands-      , _waitingRobots = M.empty-      , _gensym = initGensym-      , _seed = theSeed-      , _randGen = mkStdGen theSeed-      , _entityMap = em-      , _recipesOut = addRecipesWith outRecipeMap recipesOut-      , _recipesIn = addRecipesWith inRecipeMap recipesIn-      , _recipesReq = addRecipesWith reqRecipeMap recipesReq-      , _knownEntities = scenario ^. scenarioKnown-      , _world = theWorld theSeed-      , _viewCenterRule = VCRobot baseID-      , _viewCenter = origin-      , _needsRedraw = False-      , -- 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)-        _replStatus = case running of-          False -> REPLDone Nothing-          True -> REPLWorking (Typed Nothing PolyUnit mempty)-      , _replNextValueIndex = 0-      , _messageQueue = Empty-      , _focusedRobotID = baseID-      , _ticks = 0-      , _robotStepsPerTick = (scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick+    (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'+      & availableCommands .~ Notifications 0 initialCommands+      & gensym .~ initGensym+      & seed .~ theSeed+      & randGen .~ mkStdGen theSeed+      & initiallyRunCode .~ initialCodeToRun+      & entityMap .~ em+      & recipesOut %~ addRecipesWith outRecipeMap+      & recipesIn %~ addRecipesWith inRecipeMap+      & recipesReq %~ addRecipesWith reqRecipeMap+      & knownEntities .~ scenario ^. scenarioKnown+      & worldNavigation .~ scenario ^. scenarioNavigation+      & multiWorld .~ allSubworldsMap 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.+      & worldScrollable .~ NE.head (scenario ^. scenarioWorlds) ^. to scrollable+      & viewCenterRule .~ VCRobot baseID+      & 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)+      & robotStepsPerTick .~ ((scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick)  where-  em = g ^. entityMap <> scenario ^. scenarioEntities+  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))   -- 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-  getCodeToRun x = case x of-    SuggestedSolution s -> s-    ScriptPath (into @Text -> f) -> [tmQ| run($str:f) |]+  getCodeToRun (CodeToRun _ s) = s    -- Rules for selecting the "base" robot:   -- -------------------------------------@@ -859,9 +1159,16 @@   --   2.a. If multiple robots are specified in the map, prefer the one that   --        is defined first within the Scenario file.   --   2.b. If multiple robots are instantiated from the same template, then-  --        prefer the one closest to the upper-left of the screen, with higher rows given precedence over columns.+  --        prefer the one with a lower-indexed subworld. Note that the root+  --        subworld is always first.+  --   2.c. 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).   robotsByBasePrecedence = locatedRobots ++ map snd (sortOn fst genRobots) +  initialCodeToRun = getCodeToRun <$> toRun+   robotList =     zipWith instantiateRobot [baseID ..] robotsByBasePrecedence       -- If the  --run flag was used, use it to replace the CESK machine of the@@ -869,16 +1176,19 @@       -- 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 getCodeToRun <$> toRun of+      & 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+      & ix baseID+        . robotInventory         %~ case scenario ^. scenarioCreative of           False -> id           True -> union (fromElems (map (0,) things))-      & ix baseID . equippedDevices+      & ix baseID+        . equippedDevices         %~ case scenario ^. scenarioCreative of           False -> id           True -> const (fromList devices)@@ -899,8 +1209,26 @@       (maybe True (`S.member` initialCaps) . constCaps)       allConst -  (genRobots, wf) = buildWorld em (scenario ^. scenarioWorld)-  theWorld = W.newWorld . wf+  -- 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) builtWorldTuples++  builtWorldTuples :: NonEmpty (SubworldName, ([IndexedTRobot], Seed -> WorldFun Int Entity))+  builtWorldTuples =+    NE.map (worldName &&& buildWorld) $+      scenario ^. scenarioWorlds++  allSubworldsMap :: Seed -> W.MultiWorld Int Entity+  allSubworldsMap s =+    M.map genWorld+      . M.fromList+      . NE.toList+      $ builtWorldTuples+   where+    genWorld x = W.newWorld $ snd x s+   theWinCondition =     maybe       NoWinCondition@@ -908,58 +1236,37 @@       (NE.nonEmpty (scenario ^. scenarioObjectives))    initGensym = length robotList - 1-  addRecipesWith f gRs = IM.unionWith (<>) (f $ scenario ^. scenarioRecipes) (g ^. gRs)+  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 :: EntityMap -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity)-buildWorld em WorldDescription {..} = (robots, first fromEnum . wf)+buildWorld :: WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity)+buildWorld WorldDescription {..} = (robots worldName, first fromEnum . wf)  where   rs = fromIntegral $ length area   cs = fromIntegral $ length (head area)   Coords (ulr, ulc) = locToCoords ul -  worldGrid :: [[(TerrainType, Maybe Entity)]]+  worldGrid :: [[(TerrainType, Erasable Entity)]]   worldGrid = (map . map) (cellTerrain &&& cellEntity) area -  worldArray :: Array (Int32, Int32) (TerrainType, Maybe Entity)+  worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity)   worldArray = listArray ((ulr, ulc), (ulr + rs - 1, ulc + cs - 1)) (concat worldGrid) -  wf = case defaultTerrain of-    Nothing ->-      (if offsetOrigin then findGoodOrigin else id) . testWorld2FromArray em worldArray-    Just (Cell t e _) -> const (worldFunFromArray worldArray (t, e))+  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 :: [IndexedTRobot]-  robots =+  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 ?~ W.coordsToLoc (Coords (ulr + r, ulc + c))+            let robotWithLoc = trobotLocation ?~ Cosmic swName (W.coordsToLoc (Coords (ulr + r, ulc + c)))              in map (fmap robotWithLoc) robotList         )---- | Create an initial game state for a specific scenario.--- Note that this function is used only for unit tests, integration tests, and benchmarks.------ In normal play, the code path that gets executed is scenarioToAppState.-initGameStateForScenario :: String -> Maybe Seed -> Maybe FilePath -> ExceptT Text IO GameState-initGameStateForScenario sceneName userSeed toRun = do-  g <- initGameState-  (scene, path) <- loadScenario sceneName (g ^. entityMap)-  gs <- liftIO $ scenarioToGameState scene userSeed (ScriptPath <$> toRun) g-  normalPath <- liftIO $ normalizeScenarioPath (gs ^. scenarios) path-  t <- liftIO getZonedTime-  return $-    gs-      & currentScenarioPath ?~ normalPath-      & scenarios . scenarioItemByPath normalPath . _SISingle . _2 . scenarioStatus .~ InProgress t 0 0---- | For convenience, the 'GameState' corresponding to the classic---   game with seed 0.---   This is used only for benchmarks and unit tests.-classicGame0 :: ExceptT Text IO GameState-classicGame0 = initGameStateForScenario "classic" (Just 0) Nothing
src/Swarm/Game/Step.hs view
@@ -7,2163 +7,2842 @@ {-# LANGUAGE ViewPatterns #-}  -- |--- Module      :  Swarm.Game.Step--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com------ SPDX-License-Identifier: BSD-3-Clause------ Facilities for stepping the robot CESK machines, /i.e./ the actual--- interpreter for the Swarm language.-module Swarm.Game.Step where--import Control.Applicative (liftA2)-import Control.Arrow ((&&&))-import Control.Carrier.Error.Either (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)-import Data.Array (bounds, (!))-import Data.Bifunctor (second)-import Data.Bool (bool)-import Data.Char (chr, ord)-import Data.Either (partitionEithers, rights)-import Data.Foldable (asum, traverse_)-import Data.Functor (void)-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.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 (zero)-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.Recipe-import Swarm.Game.Robot-import Swarm.Game.Scenario.Objective qualified as OB-import Swarm.Game.Scenario.Objective.WinCheck qualified as WC-import Swarm.Game.State-import Swarm.Game.World qualified as W-import Swarm.Language.Capability-import Swarm.Language.Context hiding (delete)-import Swarm.Language.Pipeline-import Swarm.Language.Pipeline.QQ (tmQ)-import Swarm.Language.Pretty (prettyText)-import Swarm.Language.Requirement qualified as R-import Swarm.Language.Syntax-import Swarm.Language.Typed (Typed (..))-import Swarm.Language.Value-import Swarm.TUI.Model.Achievement.Attainment-import Swarm.TUI.Model.Achievement.Definitions-import Swarm.Util-import Swarm.Util.Location-import System.Clock (TimeSpec)-import System.Clock qualified-import System.Random (UniformRange, uniformR)-import Witch (From (from), into)-import Prelude hiding (lookup)---- | The main function to do one game tick.  The only reason we need---   @IO@ is so that robots can run programs loaded from files, via---   the 'Run' command; but eventually I want to get rid of that---   command and have a library of modules that you can create, edit,---   and run all from within the UI (the library could also be loaded---   from a file when the whole program starts up).-gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m ()-gameTick = do-  wakeUpRobotsDoneSleeping-  robotNames <- use activeRobots-  forM_ (IS.toList robotNames) $ \rn -> do-    mr <- uses robotMap (IM.lookup rn)-    case mr of-      Nothing -> return ()-      Just curRobot -> do-        curRobot' <- tickRobot curRobot-        if curRobot' ^. selfDestruct-          then deleteRobot rn-          else do-            robotMap %= IM.insert rn curRobot'-            time <- use ticks-            case waitingUntil curRobot' of-              Just wakeUpTime-                -- if w=2 t=1 then we do not needlessly put robot to waiting queue-                | wakeUpTime - 2 <= time -> return ()-                | otherwise -> sleepUntil rn wakeUpTime-              Nothing ->-                unless (isActive curRobot') (sleepForever rn)--  -- 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 replStatus-      case res of-        REPLWorking (Typed Nothing ty req) -> case getResult r of-          Just (v, s) -> do-            replStatus .= REPLWorking (Typed (Just v) ty req)-            baseRobot . robotContext . defStore .= s-          Nothing -> return ()-        _otherREPLStatus -> return ()-    Nothing -> return ()--  -- Possibly update the view center.-  modify recalcViewCenter--  -- Possibly 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 entityMap-      hypotheticalWinCheck em g winState oc-    _ -> return ()--  -- Advance the game time by one.-  ticks += 1---- | 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-      currentTime <- sendIO getZonedTime-      gameAchievements-        %= M.insertWith-          (<>)-          LoseScenario-          (Attainment (GameplayAchievement LoseScenario) Nothing currentTime)-    _ -> return ()--  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)-          currentCompletions-          announcements-      Right boolResult ->-        CompletionsWithExceptions-          exnTexts-          (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 (ErrorTrace 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)--getNow :: Has (Lift IO) sig m => m TimeSpec-getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic---- | 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" [] zero zero defaultRobotDisplay c [] [] True False--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----------------------------------------------------------------- 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---- | Perform an action requiring a 'W.World' state component in a---   larger context with a 'GameState'.-zoomWorld :: (Has (State GameState) sig m) => StateC (W.World Int Entity) Identity b -> m b-zoomWorld n = do-  w <- use world-  let (w', a) = run (runState w n)-  world .= w'-  return a---- | Get the entity (if any) at a given location.-entityAt :: (Has (State GameState) sig m) => Location -> m (Maybe Entity)-entityAt loc = zoomWorld (W.lookupEntityM @Int (W.locToCoords loc))---- | Modify the entity (if any) at a given location.-updateEntityAt ::-  (Has (State GameState) sig m) => Location -> (Maybe Entity -> Maybe Entity) -> m ()-updateEntityAt loc upd = zoomWorld (W.updateM @Int (W.locToCoords loc) upd)---- | 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))---- | 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-  adjs <- use @GameState adjList-  names <- use @GameState nameList-  i <- uniform (bounds adjs)-  j <- uniform (bounds names)-  return $ T.concat [adjs ! i, "_", names ! j]----------------------------------------------------------------- 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) => LogSource -> Text -> m LogEntry-createLogEntry source msg = do-  rid <- use robotID-  rn <- use robotName-  time <- use ticks-  loc <- use robotLocation-  pure $ LogEntry time source rn rid loc msg---- | Print some text via the robot's log.-traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry-traceLog source msg = do-  m <- createLogEntry source 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 . 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 '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 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-      creative <- use creativeMode-      sys <- use systemRobot-      robotCaps <- use robotCapabilities-      let hasCaps = cap `S.member` robotCaps-      (sys || creative || hasCaps)-        `holdsOr` Incapable FixByEquip (R.singletonCap cap) (TConst c)---- | 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-  creative <- use creativeMode-  sys <- use systemRobot-  caps <- use robotCapabilities-  return (sys || creative || 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---- | Create an exception about a command failing.-cmdExn :: Const -> [Text] -> Exn-cmdExn c parts = CmdFailed c (T.unwords parts) Nothing---- | 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 robotStepsPerTick-  tickRobotRec (r & tickSteps .~ 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-  | isActive r && (r ^. runningAtomic || r ^. tickSteps > 0) =-      stepRobot r >>= tickRobotRec-  | otherwise = return r---- | Single-step a robot by decrementing its 'tickSteps' 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 & tickSteps -~ 1) (stepCESK (r ^. machine))-  -- sendIO $ appendFile "out.txt" (prettyString cesk' ++ "\n")-  return $ r' & machine .~ cesk'---- 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 world-  let eNow = W.lookupEntity (W.locToCoords loc) w-  if Just eThen /= eNow-    then throwError $ cmdExn c ["The", eThen ^. entityName, "is not there."]-    else do-      world %= W.update (W.locToCoords loc) (const down)-      pure ()---- | 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 ticks-    if wakeupTime <= time-      then stepCESK cesk'-      else return cesk-  Out v s (FImmediate cmd wf rf : k) -> do-    wc <- runError $ mapM_ (updateWorld cmd) wf-    case wc of-      Left exn -> return $ Up exn s k-      Right () -> do-        forM_ rf $ \case-          AddEntity c e -> robotInventory %= E.insertCount c e-          LearnEntity e -> robotInventory %= E.insertCount 0 e-        needsRedraw .= True-        stepCESK (Out v s k)--  -- 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-  -- 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"-  -- 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 (setCell loc (V v) s) k-  -------------------------------------------------------------  -- Execution--  -- 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 tickSteps 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) $ tickSteps .= 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 '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-        currentTime <- sendIO getZonedTime-        scenarioPath <- use currentScenarioPath-        gameAchievements-          %= M.insertWith-            (<>)-            a-            (Attainment (GameplayAchievement a) scenarioPath currentTime)-      _ -> 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 entityMap-    if h-      then do-        void $ traceLog (ErrorTrace 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) -> Location -> TimeSpec -> m ()-addSeedBot e (minT, maxT) loc ts =-  void $-    addTRobot $-      mkRobot-        ()-        Nothing-        "seed"-        ["A growing seed."]-        (Just loc)-        zero-        ( defaultEntityDisplay '.'-            & displayAttr .~ (e ^. entityDisplay . displayAttr)-            & displayPriority .~ 0-        )-        (initMachine (seedProgram minT (maxT - minT) (e ^. entityName)) empty emptyStore)-        []-        [(1, e)]-        True-        False-        ts---- | 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)---- | 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--  -- 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 ticks-        return $ Waiting (time + d) (Out VUnit s k)-      _ -> badConst-    Selfdestruct -> do-      destroyIfNotBase $ Just AttemptSelfDestructBase-      flagRedraw-      return $ Out VUnit s k-    Move -> do-      -- Figure out where we're going-      loc <- use robotLocation-      orient <- use robotOrientation-      let nextLoc = loc .+^ (orient ? zero)-      checkMoveAhead nextLoc $-        MoveFailure-          { failIfBlocked = ThrowExn-          , failIfDrown = Destroy-          }-      updateRobotLocation loc nextLoc-      return $ Out VUnit s k-    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 = Location (fromIntegral x) (fromIntegral y)--        onTarget rid $ do-          checkMoveAhead nextLoc $-            MoveFailure-              { failIfBlocked = Destroy-              , failIfDrown = Destroy-              }-          updateRobotLocation oldLoc nextLoc--        return $ Out VUnit s k-      _ -> badConst-    Grab -> doGrab Grab'-    Harvest -> doGrab Harvest'-    Swap -> case vs of-      [VText name] -> do-        loc <- use robotLocation-        -- Make sure the robot has the thing in its inventory-        e <- hasInInventoryOrFail name-        -- Grab-        r <- doGrab Swap'-        case r of-          Out {} -> do-            -- Place the entity and remove it from the inventory-            updateEntityAt loc (const (Just e))-            robotInventory %= delete e-          _ -> pure ()-        return r-      _ -> badConst-    Turn -> case vs of-      [VDir d] -> do-        when (isCardinal d) $ hasCapabilityFor COrient (TDir d)-        robotOrientation . _Just %= applyTurn d-        flagRedraw-        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-    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 entityMap-        e <--          lookupEntityName name em-            `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."]--        outRs <- use 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 [] (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-    Whereami -> do-      loc <- use robotLocation-      let Location x y = loc-      return $ Out (VPair (VInt (fromIntegral x)) (VInt (fromIntegral y))) s k-    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-      t <- use ticks-      return $ Out (VInt t) s k-    Drill -> case vs of-      [VDir d] -> do-        rname <- use robotName-        inv <- use robotInventory-        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--        drill <- preferredDrill `isJustOr` Fatal "Drill is required but not equipped?!"--        let directionText = case d of-              DRelative DDown -> "under"-              DRelative DForward -> "ahead of"-              DRelative DBack -> "behind"-              _ -> dirSyntax (dirInfo d) <> " of"--        (nextLoc, nextME) <- lookInDirection d-        nextE <--          nextME-            `isJustOrFail` ["There is nothing to drill", directionText, "robot", rname <> "."]--        inRs <- use recipesIn--        let recipes = filter drilling (recipesFor inRs nextE)-            drilling = any ((== drill) . snd) . view recipeRequirements--        not (null recipes) `holdsOrFail` ["There is no way to drill", indefinite (nextE ^. entityName) <> "."]--        -- add the drilled 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 drill", indefinite (nextE ^. entityName) <> "."]--        let (out, down) = L.partition ((`hasProperty` Portable) . snd) outs-        let learn = map (LearnEntity . snd) down-        let 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-        finishCookingRecipe recipe [changeWorld] (learn <> gain)-      _ -> badConst-    Blocked -> do-      loc <- use robotLocation-      orient <- use robotOrientation-      let nextLoc = loc .+^ (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-        res <- case me of-          Nothing -> return $ VInj False VUnit-          Just e -> do-            robotInventory %= insertCount 0 e-            updateDiscoveredEntities e-            return $ VInj True (VText (e ^. entityName))--        return $ Out res 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--        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 -> 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-    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])-        let robotValue = VRobot (r ^. robotID)-        return $ Out robotValue s k-      _ -> badConst-    RobotNumbered -> case vs of-      [VInt rid] -> do-        r <--          robotWithID (fromIntegral rid)-            >>= (`isJustOrFail` ["There is no robot with number", from (show rid)])-        let robotValue = VRobot (r ^. robotID)-        return $ Out robotValue s k-      _ -> badConst-    Say -> case vs of-      [VText msg] -> do-        creative <- use creativeMode-        system <- use systemRobot-        loc <- use robotLocation-        m <- traceLog Said msg -- current robot will inserted to robot set, so it needs the log-        emitMessage m-        let addLatestClosest rl = \case-              Seq.Empty -> Seq.singleton m-              es Seq.:|> e-                | e ^. leTime < m ^. leTime -> es |> e |> m-                | manhattan rl (e ^. leLocation) > manhattan rl (m ^. leLocation) -> es |> m-                | otherwise -> es |> e-        let addToRobotLog :: Has (State GameState) sgn m => Robot -> m ()-            addToRobotLog r = do-              r' <- execState r $ do-                hasLog <- hasCapability CLog-                hasListen <- hasCapability CListen-                loc' <- use robotLocation-                when (hasLog && hasListen) (robotLog %= addLatestClosest loc')-              addRobot r'-        robotsAround <--          if creative || system-            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-      creative <- use creativeMode-      system <- use systemRobot-      mq <- use messageQueue-      let isClose e = system || creative || messageIsFromNearby loc e-      let notMine e = rid /= e ^. leRobotID-      let limitLast = \case-            _s Seq.:|> l -> Just $ l ^. leText-            _ -> Nothing-      let 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 msg-        return $ Out VUnit s k-      _ -> badConst-    View -> case vs of-      [VRobot rid] -> do-        _ <--          robotWithID rid-            >>= (`isJustOrFail` ["There is no actor with ID", from (show rid), "to view."])--        -- 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) $-          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 entityMap-        e <--          lookupEntityName name em-            `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."]--        robotInventory %= insert e-        updateDiscoveredEntities e--        return $ Out VUnit s k-      _ -> badConst-    Ishere -> case vs of-      [VText name] -> do-        loc <- use robotLocation-        me <- entityAt loc-        case me of-          Nothing -> return $ Out (VBool False) s k-          Just e -> return $ Out (VBool (T.toLower (e ^. entityName) == T.toLower name)) 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 loc . (^. robotLocation)) -- prefer closer-              $ robotsInArea loc 1 g -- all robots within Manhattan distance 1-      return $ Out (VInj (isJust neighbor) (maybe VUnit (VRobot . (^. robotID)) 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 lookupCell 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' (setCell 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-    Reprogram -> case vs of-      [VRobot childRobotID, VDelay cmd e] -> do-        r <- get-        creative <- use creativeMode--        -- 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-        -- creative mode ignores distance checks-        loc <- use robotLocation-        (creative || (childRobot ^. robotLocation) `manhattan` loc <= 1)-          `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--        -- Construct the new robot and add it to the world.-        parentCtx <- use robotContext-        newRobot <--          addTRobot . (trobotContext .~ parentCtx) $-            mkRobot-              ()-              (Just pid)-              displayName-              ["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])-              []-              []-              False-              False-              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 (VRobot (newRobot ^. robotID)) 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 entityMap-            creative <- use creativeMode-            logger <--              lookupEntityName "logger" em-                `isJustOr` Fatal "While executing 'salvage': there's no such thing as a logger!?"-            when (creative || 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 ticks-            return $ Waiting (time + fromIntegral numItems + 1) (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 <- sendIO $ getDataFileNameSafe filePath-        sDataSW <- sendIO $ getDataFileNameSafe (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-  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)-      ]--  finishCookingRecipe :: HasRobotStepState sig m => Recipe e -> [WorldUpdate Entity] -> [RobotUpdate] -> m CESK-  finishCookingRecipe r wf rf = do-    time <- use ticks-    let remTime = r ^. recipeTime-    return . (if remTime <= 1 then id else Waiting (remTime + time)) $-      Out VUnit s (FImmediate c wf rf : k)--  lookInDirection :: HasRobotStepState sig m => Direction -> m (Location, Maybe Entity)-  lookInDirection d = do-    loc <- use robotLocation-    orient <- use robotOrientation-    when (isCardinal d) $ hasCapabilityFor COrient (TDir d)-    let nextLoc = loc .+^ applyTurn d (orient ? zero)-    (nextLoc,) <$> entityAt nextLoc--  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 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)--  destroyIfNotBase :: HasRobotStepState sig m => 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-    selfDestruct .= True--  -- Make sure nothing is in the way. Note that system robots implicitly ignore and base throws on failure.-  checkMoveAhead :: HasRobotStepState sig m => Location -> MoveFailure -> m ()-  checkMoveAhead nextLoc MoveFailure {..} = do-    me <- entityAt nextLoc-    systemRob <- use systemRobot-    case me of-      Nothing -> return ()-      Just e-        | systemRob -> return ()-        | otherwise -> do-            -- robots can not walk through walls-            when (e `hasProperty` Unwalkable) $-              case failIfBlocked of-                Destroy -> destroyIfNotBase Nothing-                ThrowExn -> throwError $ cmdExn c ["There is a", e ^. entityName, "in the way!"]-                IgnoreFail -> return ()--            -- robots drown if they walk over liquid without boat-            caps <- use robotCapabilities-            when (e `hasProperty` Liquid && CFloat `S.notMember` caps) $-              case failIfDrown of-                Destroy -> destroyIfNotBase Nothing-                ThrowExn -> throwError $ cmdExn c ["There is a dangerous liquid", e ^. entityName, "in the way!"]-                IgnoreFail -> return ()--  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) <> "."]-        -- Make sure it is either in the same location or we do not care-        omni <- (||) <$> use systemRobot <*> use creativeMode-        loc <- use robotLocation-        (omni || (other ^. robotLocation) `manhattan` loc <= 1)-          `holdsOrFail` ["The robot with ID", from (show rid), "is not close enough."]-        return other--  holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m ()-  holdsOrFail a ts = a `holdsOr` cmdExn c ts--  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 a ts = a `isJustOr` cmdExn c ts--  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--  -- The code for grab and harvest is almost identical, hence factored-  -- out here.-  doGrab :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GrabbingCmd -> m CESK-  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 <- (||) <$> use systemRobot <*> use creativeMode-    (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 entityMap (lookupEntityName n)--    robotInventory %= insert e'-    updateDiscoveredEntities e'--    -- Return the name of the item obtained.-    return $ Out (VText (e' ^. entityName)) s k----------------------------------------------------------------- Some utility functions----------------------------------------------------------------- | How to handle failure, for example when moving to blocked location-data RobotFailure = ThrowExn | Destroy | IgnoreFail---- | How to handle failure when moving/teleporting to a location.-data MoveFailure = MoveFailure-  { failIfBlocked :: RobotFailure-  , failIfDrown :: RobotFailure-  }--data GrabbingCmd = Grab' | Harvest' | Swap' deriving (Eq, Show)--verbGrabbingCmd :: GrabbingCmd -> Text-verbGrabbingCmd = \case-  Harvest' -> "harvest"-  Grab' -> "grab"-  Swap' -> "swap"--verbedGrabbingCmd :: GrabbingCmd -> Text-verbedGrabbingCmd = \case-  Harvest' -> "harvested"-  Grab' -> "grabbed"-  Swap' -> "swapped"---- | 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 'Build' or '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.-updateRobotLocation ::-  (HasRobotStepState sig m) =>-  Location ->-  Location ->-  m ()-updateRobotLocation oldLoc newLoc-  | oldLoc == newLoc = return ()-  | otherwise = do-      rid <- use robotID-      robotsByLocation . at oldLoc %= deleteOne rid-      robotsByLocation . at newLoc . non Empty %= IS.insert rid-      modify (unsafeSetRobotLocation newLoc)-      flagRedraw- where-  -- Make 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!-  deleteOne _ Nothing = Nothing-  deleteOne x (Just s)-    | IS.null s' = Nothing-    | otherwise = Just s'-   where-    s' = IS.delete x s---- | Execute a stateful action on a target robot --- whether the---   current one or another.-onTarget ::-  HasRobotStepState sig m =>-  RID ->-  (forall sig' m'. (HasRobotStepState 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-  VClo {} -> incomparable v1-  VCApp {} -> incomparable v1-  VDef {} -> incomparable v1-  VResult {} -> incomparable v1-  VBind {} -> incomparable v1-  VDelay {} -> incomparable v1-  VRef {} -> incomparable v1+-- 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 'Run' command.+-- This could be avoided by using 'Import' command instead and parsing+-- the required files at the time of declaration.+-- See <https://github.com/swarm-game/swarm/issues/495>.+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, join, msum, unless, when, zipWithM)+import Data.Array (bounds, (!))+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.Waypoint (WaypointName (..))+import Swarm.Game.State+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.Util hiding (both)+import Swarm.Util.Effect (throwToMaybe)+import System.Clock (TimeSpec)+import System.Clock qualified+import System.Random (UniformRange, uniformR)+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 gameStep >>= \case+      WorldTick -> do+        runRobotIDs active+        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 replStatus+      case res of+        REPLWorking (Typed Nothing ty req) -> case getResult r of+          Just (v, s) -> do+            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 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 gameStep >>= \case+    WorldTick -> pure ()+    RobotStep SBefore -> 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 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+      gameStep .= RobotStep (SSingle focRID)+      -- also set ticks of focused robot+      steps <- use robotStepsPerTick+      robotMap . ix focRID . tickSteps .= 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+          gameStep .= WorldTick+          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 ^. tickSteps == 0) $ 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+      gameStep .= RobotStep SBefore+      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 (ErrorTrace 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 ()++  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 (ErrorTrace 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)++getNow :: Has (Lift IO) sig m => m TimeSpec+getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic++-- | 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++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++------------------------------------------------------------+-- 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++-- | 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 multiWorld+  forM (M.lookup swName mw) $ \w -> do+    let (w', a) = run (runState w n)+    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))++-- | 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+  didChange <-+    fmap (fromMaybe False) $+      zoomWorld subworldName $+        W.updateM @Int (W.locToCoords loc) upd+  when didChange $+    wakeWatchingRobots cLoc++-- | 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))++-- | 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+  adjs <- use @GameState adjList+  names <- use @GameState nameList+  i <- uniform (bounds adjs)+  j <- uniform (bounds names)+  return $ T.concat [adjs ! i, "_", names ! j]++------------------------------------------------------------+-- 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) =>+  LogSource ->+  Text ->+  m LogEntry+createLogEntry source msg = do+  rid <- use robotID+  rn <- use robotName+  time <- use ticks+  loc <- use robotLocation+  pure $ LogEntry time source rn rid (Located loc) msg++-- | Print some text via the robot's log.+traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry+traceLog source msg = do+  m <- createLogEntry source 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 . 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 '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)++-- | 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++-- | Create an exception about a command failing.+cmdExn :: Const -> [Text] -> Exn+cmdExn c parts = CmdFailed c (T.unwords parts) Nothing++-- | 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 robotStepsPerTick+  tickRobotRec (r & tickSteps .~ 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 ticks+  case wantsToStep time r && (r ^. runningAtomic || r ^. tickSteps > 0) of+    True -> stepRobot r >>= tickRobotRec+    False -> return r++-- | Single-step a robot by decrementing its 'tickSteps' 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 & tickSteps -~ 1) (stepCESK (r ^. machine))+  -- sendIO $ appendFile "out.txt" (prettyString cesk' ++ "\n")+  return $ r' & machine .~ cesk'++-- | 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 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 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 (setCell 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 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 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 tickSteps 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) $ tickSteps .= 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 '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 entityMap+    if h+      then do+        void $ traceLog (ErrorTrace 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"+        "A growing seed."+        (Just loc)+        zero+        ( defaultEntityDisplay '.'+            & displayAttr .~ (e ^. entityDisplay . displayAttr)+            & displayPriority .~ 0+        )+        (initMachine (seedProgram minT (maxT - minT) (e ^. entityName)) empty emptyStore)+        []+        [(1, e)]+        True+        False+        ts++-- | 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)++-- | 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++  -- 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 ticks+        purgeFarAwayWatches+        return $ Waiting (addTicks d time) (Out VUnit s k)+      _ -> badConst+    Selfdestruct -> do+      destroyIfNotBase $ Just AttemptSelfDestructBase+      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+    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 $+          MoveFailure+            { failIfBlocked = ThrowExn+            , failIfDrown = 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 $+            MoveFailure+              { failIfBlocked = Destroy+              , failIfDrown = Destroy+              }+          updateRobotLocation oldLoc nextLoc++        return $ Out VUnit s k+      _ -> badConst+    Grab -> doGrab Grab'+    Harvest -> doGrab Harvest'+    Swap -> case vs of+      [VText name] -> do+        loc <- use robotLocation+        -- Make sure the robot has the thing in its inventory+        e <- hasInInventoryOrFail name+        -- Grab+        r <- doGrab Swap'+        case r of+          Out {} -> do+            -- Place the entity and remove it from the inventory+            updateEntityAt loc (const (Just e))+            robotInventory %= delete e+          _ -> pure ()+        return r+      _ -> 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+    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 entityMap+        e <-+          lookupEntityName name em+            `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."]++        outRs <- use 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 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 ticks+      return $ Out (VInt 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+        m <- traceLog Said msg -- current robot will inserted to robot set, so it needs the log+        emitMessage m+        let measureToLog robLoc rawLogLoc = case rawLogLoc of+              Located logLoc -> cosmoMeasure manhattan robLoc logLoc+              Omnipresent -> 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 leLocation)+        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 messageQueue+      let isClose e = isPrivileged || messageIsFromNearby loc e+      let notMine e = rid /= e ^. leRobotID+      let limitLast = \case+            _s Seq.:|> l -> Just $ l ^. leText+            _ -> Nothing+      let 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 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 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 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 lookupCell 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' (setCell 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+        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++        -- 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])+              []+              []+              False+              False+              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 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 ticks+            return $ Waiting (addTicks (fromIntegral 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 recipesIn++    let recipes = filter isApplicableRecipe (recipesFor inRs nextE)+        isApplicableRecipe = any ((== tool) . snd) . view recipeRequirements++    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 ticks+        return . (if remTime <= 1 then id else Waiting (addTicks remTime time)) $+          Out v s (FImmediate c wf rf : k)+   where+    remTime = r ^. recipeTime++  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++  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 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)++  destroyIfNotBase :: HasRobotStepState sig m => 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+    selfDestruct .= 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 $+      MoveFailure+        { failIfBlocked = ThrowExn+        , failIfDrown = Destroy+        }+    updateRobotLocation loc nextLoc+    return $ Out VUnit s k++  -- 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+    me <- entityAt nextLoc+    systemRob <- use systemRobot+    caps <- use robotCapabilities+    return $ do+      e <- me+      guard $ not systemRob+      go caps e+   where+    go caps e+      -- robots can not walk through walls+      | e `hasProperty` Unwalkable = 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++  applyMoveFailureEffect ::+    HasRobotStepState sig m =>+    Maybe MoveFailureDetails ->+    MoveFailure ->+    m ()+  applyMoveFailureEffect maybeFailure MoveFailure {..} =+    case maybeFailure of+      Nothing -> return ()+      Just (MoveFailureDetails e failureMode) -> case failureMode of+        PathBlocked ->+          handleFailure+            failIfBlocked+            ["There is a", e ^. entityName, "in the way!"]+        PathLiquid ->+          handleFailure+            failIfDrown+            ["There is a dangerous liquid", e ^. entityName, "in the way!"]+   where+    handleFailure behavior message = case behavior of+      Destroy -> destroyIfNotBase Nothing+      ThrowExn -> throwError $ cmdExn c message+      IgnoreFail -> return ()++  -- Determine the move failure mode and apply the corresponding effect.+  checkMoveAhead :: HasRobotStepState sig m => Cosmic Location -> MoveFailure -> m ()+  checkMoveAhead nextLoc failureHandlers = do+    maybeFailure <- checkMoveFailure nextLoc+    applyMoveFailureEffect maybeFailure failureHandlers++  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 a ts = a `holdsOr` cmdExn c ts++  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 a ts = a `isJustOr` cmdExn c ts++  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++  -- The code for grab and harvest is almost identical, hence factored+  -- out here.+  doGrab :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GrabbingCmd -> m CESK+  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 entityMap (lookupEntityName n)++    robotInventory %= insert e'+    updateDiscoveredEntities e'++    -- Return the name of the item obtained.+    return $ Out (VText (e' ^. entityName)) s k++------------------------------------------------------------+-- 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+------------------------------------------------------------++-- | 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++-- | 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+  gameAchievements+    %= M.insertWith+      (<>)+      a+      (Attainment (GameplayAchievement a) scenarioPath currentTime)++data MoveFailureMode = PathBlocked | PathLiquid+data MoveFailureDetails = MoveFailureDetails Entity MoveFailureMode++-- | How to handle failure, for example when moving to blocked location+data RobotFailure = ThrowExn | Destroy | IgnoreFail++-- | How to handle failure when moving/teleporting to a location.+data MoveFailure = MoveFailure+  { failIfBlocked :: RobotFailure+  , failIfDrown :: 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 'Build' or '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 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 =>+  RID ->+  (forall sig' m'. (HasRobotStepState 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.
src/Swarm/Game/Terrain.hs view
@@ -1,15 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+ -- |--- Module      :  Swarm.Game.Terrain--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- 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)@@ -17,7 +18,7 @@ import Data.Map qualified as M import Data.Text qualified as T import Swarm.Game.Display-import Swarm.TUI.Attr+import Swarm.Util (failT) import Text.Read (readMaybe) import Witch (into) @@ -31,19 +32,35 @@   | 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 readMaybe (into @String (T.toTitle t) ++ "T") of+    case readTerrain t of       Just ter -> return ter-      Nothing -> fail $ "Unknown terrain type: " ++ into @String t+      Nothing -> failT ["Unknown terrain type:", t] +getTerrainDefaultPaletteChar :: TerrainType -> Char+getTerrainDefaultPaletteChar = head . show++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 '▒' rockAttr)-    , (DirtT, defaultTerrainDisplay '▒' dirtAttr)-    , (GrassT, defaultTerrainDisplay '▒' grassAttr)-    , (IceT, defaultTerrainDisplay ' ' iceAttr)-    , (BlankT, defaultTerrainDisplay ' ' defAttr)+    [ (StoneT, defaultTerrainDisplay '▒' (ATerrain "stone"))+    , (DirtT, defaultTerrainDisplay '▒' (ATerrain "dirt"))+    , (GrassT, defaultTerrainDisplay '▒' (ATerrain "grass"))+    , (IceT, defaultTerrainDisplay ' ' (ATerrain "ice"))+    , (BlankT, defaultTerrainDisplay ' ' ADefault)     ]
+ src/Swarm/Game/Universe.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+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++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 -> "<default>"++-- | The swarm universe consists of locations+-- indexed by subworld.+-- Not only is this 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"++defaultCosmicLocation :: Cosmic Location+defaultCosmicLocation = Cosmic DefaultRootSubworld origin++data DistanceMeasure b = Measurable b | InfinitelyFar+  deriving (Eq, Ord)++-- | 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++offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location+offsetBy loc v = fmap (.+^ v) loc
+ src/Swarm/Game/Value.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Conversions from native Haskell values+-- to values in the swarm language.+--+-- SPDX-License-Identifier: BSD-3-Clause+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.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+-- <https://github.com/swarm-game/swarm/wiki/Commands-Cheat-Sheet commands>+-- 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 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
src/Swarm/Game/World.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}  -- |--- Module      :  Swarm.Game.World--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A /world/ refers to the grid on which the game takes place, and the@@ -14,18 +12,21 @@ -- mutable /entity/ layer, with at most one entity per cell. -- -- A world is technically finite but practically infinite (worlds are--- indexed by 64-bit signed integers, so they correspond to a--- \( 2^{64} \times 2^{64} \) torus).+-- 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,@@ -33,8 +34,9 @@    -- ** World functions   newWorld,-  emptyWorld,+  lookupCosmicTerrain,   lookupTerrain,+  lookupCosmicEntity,   lookupEntity,   update, @@ -49,65 +51,53 @@  import Control.Algebra (Has) import Control.Arrow ((&&&))-import Control.Effect.State (State, get, modify)+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.Function (on) 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.Util-import Swarm.Util.Location+import Swarm.Game.Entity (Entity, entityHash)+import Swarm.Game.Location+import Swarm.Game.Terrain (TerrainType (BlankT))+import Swarm.Game.Universe+import Swarm.Game.World.Coords+import Swarm.Util ((?))+import Swarm.Util.Erasable import Prelude hiding (lookup)  --------------------------------------------------------------- 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 '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)-------------------------------------------------------------- -- 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 {runWF :: Coords -> (t, Maybe e)}+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 h) . z)+  bimap g h (WF z) = WF (bimap g (fmap (fmap h)) . z) --- | Create a world function from a finite array of specified cells---   plus a single default cell to use everywhere else.-worldFunFromArray :: Array (Int32, Int32) (t, Maybe e) -> (t, Maybe e) -> WorldFun t e-worldFunFromArray arr def = WF $ \(Coords (r, c)) ->+-- | 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 arr ! (r, c)-    else def+    then second (fmap Last) (arr ! (r, c))+    else mempty  where   bnds = bounds arr @@ -183,6 +173,8 @@ --   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@@ -205,10 +197,13 @@ newWorld :: WorldFun t e -> World t e newWorld f = World f M.empty M.empty --- | Create a new empty 'World' consisting of nothing but the given---   terrain.-emptyWorld :: t -> World t e-emptyWorld t = newWorld (WF $ const (t, Nothing))+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'@@ -216,7 +211,7 @@ -- --   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 :: (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)@@ -224,11 +219,19 @@ -- | 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 ::+  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@@ -242,32 +245,57 @@     ? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t)     ? snd (runWF f i) --- | A stateful variant of 'lookupTerrain', which first loads the tile+-- | 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 ::+  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'.  See also 'updateM'.-update :: Coords -> (Maybe e -> Maybe e) -> World t e -> World t e+--   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, Bool) update i g w@(World f t m) =-  World f t (M.insert i (g (lookupEntity i w)) m)+  (wNew, ((/=) `on` fmap (view entityHash)) entityAfter entityBefore)+ 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 e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> (Maybe e -> Maybe e) -> m ()-updateM c g = modify @(World t e) $ update c g . loadCell c+updateM ::+  forall t sig m.+  (Has (State (World t Entity)) sig m, IArray U.UArray t) =>+  Coords ->+  (Maybe Entity -> Maybe Entity) ->+  m Bool+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 :: (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).-loadRegion :: forall t e. IArray U.UArray t => (Coords, Coords) -> World t e -> World t e+--   (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)@@ -283,16 +311,16 @@     tileCorner = tileOrigin tc     (terrain, entities) = unzip $ map (runWF f . plusOffset tileCorner) (range tileBounds) --- ------------------------------------------------------------------+--------------------------------------------------------------------- -- Runtime world update--- ------------------------------------------------------------------+---------------------------------------------------------------------  -- | Update world in an inspectable way. -- -- This type is used for changes by e.g. the drill command at later -- tick. Using ADT allows us to serialize and inspect the updates. data WorldUpdate e = ReplaceEntity-  { updatedLoc :: Location+  { updatedLoc :: Cosmic Location   , originalEntity :: e   , newEntity :: Maybe e   }
+ src/Swarm/Game/World/Abstract.hs view
@@ -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)!
+ src/Swarm/Game/World/Compile.hs view
@@ -0,0 +1,126 @@+{-# 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
+ src/Swarm/Game/World/Coords.hs view
@@ -0,0 +1,48 @@+{-# 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 '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)
+ src/Swarm/Game/World/Eval.hs view
@@ -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)
+ src/Swarm/Game/World/Gen.hs view
@@ -0,0 +1,79 @@+{-# 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"]
+ src/Swarm/Game/World/Interpret.hs view
@@ -0,0 +1,87 @@+{-# 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)
+ src/Swarm/Game/World/Load.hs view
@@ -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.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))
+ src/Swarm/Game/World/Parse.hs view
@@ -0,0 +1,270 @@+{-# 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 (MonadPlus, void)+import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)+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 (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++------------------------------------------------------------+-- Utility++sepByNE :: (MonadPlus m) => m a -> m sep -> m (NonEmpty a)+sepByNE p sep = NE.fromList <$> p `sepBy1` sep++------------------------------------------------------------+-- 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 `sepByNE` 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
+ src/Swarm/Game/World/Syntax.hs view
@@ -0,0 +1,119 @@+{-# 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
+ src/Swarm/Game/World/Typecheck.hs view
@@ -0,0 +1,687 @@+{-# 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 'Eq' instance, and run a+--   computation in a context provided with an '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'
− src/Swarm/Game/WorldGen.hs 
@@ -1,208 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module      :  Swarm.Game.WorldGen--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com------ SPDX-License-Identifier: BSD-3-Clause------ Procedural world generation via coherent noise.-module Swarm.Game.WorldGen where--import Control.Lens (view)-import Data.Array.IArray-import Data.Bifunctor (second)-import Data.Bool-import Data.ByteString (ByteString)-import Data.Enumeration-import Data.Hash.Murmur-import Data.Int (Int32)-import Data.List (find)-import Data.Maybe (fromMaybe, mapMaybe)-import Data.Set qualified as S-import Data.Tagged-import Data.Text (Text)-import Data.Text qualified as T-import Numeric.Noise.Perlin-import Swarm.Game.Entity-import Swarm.Game.Terrain-import Swarm.Game.World-import Witch-import Witch.Encoding qualified as Encoding---- | A simple test world used for a while during early development.-testWorld1 :: Coords -> (TerrainType, Maybe Text)-testWorld1 (Coords (-5, 3)) = (StoneT, Just "flerb")-testWorld1 (Coords (2, -1)) = (GrassT, Just "elephant")-testWorld1 (Coords (i, j))-  | noiseValue pn1 (fromIntegral i, fromIntegral j, 0) > 0 = (DirtT, Just "tree")-  | noiseValue pn2 (fromIntegral i, fromIntegral j, 0) > 0 = (StoneT, Just "rock")-  | otherwise = (GrassT, Nothing)- where-  pn1, pn2 :: Perlin-  pn1 = perlin 0 5 0.05 0.5-  pn2 = perlin 0 5 0.05 0.75--data Size = Small | Big deriving (Eq, Ord, Show, Read)-data Hardness = Soft | Hard deriving (Eq, Ord, Show, Read)-data Origin = Natural | Artificial deriving (Eq, Ord, Show, Read)-type Seed = Int---- | A list of entities available in the initial world.-testWorld2Entites :: S.Set Text-testWorld2Entites =-  S.fromList-    [ "mountain"-    , "boulder"-    , "LaTeX"-    , "tree"-    , "rock"-    , "lodestone"-    , "sand"-    , "wavy water"-    , "water"-    , "flower"-    , "bit (0)"-    , "bit (1)"-    , "Linux"-    , "lambda"-    , "pixel (R)"-    , "pixel (G)"-    , "pixel (B)"-    , "copper ore"-    ]---- | Look up an entity name in an entity map, when we know the entity---   must exist.  This is only used for entities which are named in---   'testWorld2'.-readEntity :: EntityMap -> Text -> Entity-readEntity em name =-  fromMaybe-    (error $ "Unknown entity name in WorldGen: " <> show name)-    (lookupEntityName name em)---- | The main world of the classic game, for historical reasons named---   'testWorld2'.  If new entities are added, you SHOULD ALSO UPDATE---   'testWorld2Entities'.-testWorld2 :: EntityMap -> Seed -> WorldFun TerrainType Entity-testWorld2 em baseSeed = second (readEntity em) (WF tw2)- where-  tw2 :: Coords -> (TerrainType, Maybe Text)-  tw2 (Coords ix@(r, c)) =-    genBiome-      (bool Small Big (sample ix pn0 > 0))-      (bool Soft Hard (sample ix pn1 > 0))-      (bool Natural Artificial (sample ix pn2 > 0))-   where-    h = murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ ix--    genBiome Big Hard Natural-      | sample ix cl0 > 0.5 = (StoneT, Just "mountain")-      | h `mod` 30 == 0 = (StoneT, Just "boulder")-      | sample ix cl0 > 0 =-          case h `mod` 30 of-            1 -> (DirtT, Just "LaTeX")-            _ -> (DirtT, Just "tree")-      | otherwise = (GrassT, Nothing)-    genBiome Small Hard Natural-      | h `mod` 100 == 0 = (StoneT, Just "lodestone")-      | h `mod` 10 == 0 = (StoneT, Just "rock")-      | otherwise = (StoneT, Nothing)-    genBiome Big Soft Natural-      | abs (sample ix pn1) < 0.1 = (DirtT, Just "sand")-      | even (r + c) = (DirtT, Just "wavy water")-      | otherwise = (DirtT, Just "water")-    genBiome Small Soft Natural-      | h `mod` 20 == 0 = (GrassT, Just "flower")-      | h `mod` 20 == 10 = (GrassT, Just "cotton")-      | otherwise = (GrassT, Nothing)-    genBiome Small Soft Artificial-      | h `mod` 10 == 0 = (GrassT, Just (T.concat ["bit (", from (show ((r + c) `mod` 2)), ")"]))-      | otherwise = (GrassT, Nothing)-    genBiome Big Soft Artificial-      | h `mod` 5000 == 0 = (DirtT, Just "Linux")-      | sample ix cl0 > 0.5 = (GrassT, Nothing)-      | otherwise = (DirtT, Nothing)-    genBiome Small Hard Artificial-      | h `mod` 120 == 1 = (StoneT, Just "lambda")-      | h `mod` 50 == 0 = (StoneT, Just (T.concat ["pixel (", from ["RGB" !! fromIntegral ((r + c) `mod` 3)], ")"]))-      | otherwise = (StoneT, Nothing)-    genBiome Big Hard Artificial-      | sample ix cl0 > 0.85 = (StoneT, Just "copper ore")-      | otherwise = (StoneT, Nothing)--    sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)--    pn :: Int -> Perlin-    pn seed = perlin (seed + baseSeed) 6 0.05 0.6--    pn0 = pn 0-    pn1 = pn 1-    pn2 = pn 2--    -- alternative noise function-    -- rg :: Int -> Ridged-    -- rg seed = ridged seed 6 0.05 1 2--    clumps :: Int -> Perlin-    clumps seed = perlin (seed + baseSeed) 4 0.08 0.5--    cl0 = clumps 0---- | Create a world function from a finite array of specified cells---   plus a seed to randomly generate the rest.-testWorld2FromArray :: EntityMap -> Array (Int32, Int32) (TerrainType, Maybe Entity) -> Seed -> WorldFun TerrainType Entity-testWorld2FromArray em arr seed = WF $ \co@(Coords (r, c)) ->-  if inRange bnds (r, c)-    then arr ! (r, c)-    else runWF tw2 co- where-  tw2 = testWorld2 em seed-  bnds = bounds arr---- | Offset a world by a multiple of the @skip@ in such a way that it---   satisfies the given predicate.-findOffset :: Integer -> ((Coords -> (t, Maybe 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 (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) . fmap (view entityName) . 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"]
src/Swarm/Language/Capability.hs view
@@ -1,8 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}+ -- |--- Module      :  Swarm.Language.Capability--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Capabilities needed to evaluate and execute programs.  Language@@ -25,6 +23,7 @@ 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)@@ -35,6 +34,12 @@     CPower   | -- | Execute the 'Move' command     CMove+  | -- | Execute the 'Backup' command+    CBackup+  | -- | Execute the 'Push' command+    CPush+  | -- | Execute the 'Stride' command+    CMovemultiple   | -- | Execute the 'Move' command for a heavy robot     CMoveheavy   | -- | Execute the 'Turn' command@@ -59,6 +64,8 @@     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@@ -71,6 +78,16 @@     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@@ -83,8 +100,14 @@     CListen   | -- | Execute the 'Log' command     CLog-  | -- | Manipulate text values-    CText+  | -- | 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@@ -119,15 +142,25 @@     CAtomic   | -- | Capability to execute swap (grab and place atomically at the same time).     CSwap-  | -- | Capabiltiy to do time-related things, like `wait` and get the-    --   current time.-    CTime+  | -- | 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.@@ -146,7 +179,7 @@     tryRead :: Text -> Parser Capability     tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of       Just c -> return c-      Nothing -> fail $ "Unknown capability " ++ from t+      Nothing -> failT ["Unknown capability", t]  -- | Capabilities needed to evaluate or execute a constant. constCaps :: Const -> Maybe Capability@@ -176,6 +209,9 @@   Log -> Just CLog   Selfdestruct -> Just CSelfdestruct   Move -> Just CMove+  Backup -> Just CBackup+  Push -> Just CPush+  Stride -> Just CMovemultiple   Turn -> Just CTurn   Grab -> Just CGrab   Harvest -> Just CHarvest@@ -197,6 +233,7 @@   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@@ -207,16 +244,28 @@   Self -> Just CWhoami   Swap -> Just CSwap   Atomic -> Just CAtomic-  Time -> Just CTime-  Wait -> Just CTime+  Instant -> Just CGod+  Time -> Just CTimeabs+  Wait -> Just CTimerel+  Scout -> Just CRecondir   Whereami -> Just CSenseloc+  Waypoint -> Just CGod+  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 CText-  Concat -> Just CText-  Split -> Just CText-  Chars -> Just CText+  Format -> Just CFormat+  Concat -> Just CConcat+  Split -> Just CSplit+  Chars -> Just CCharcount   CharAt -> Just CCode   ToChar -> Just CCode   -- ----------------------------------------------------------------@@ -225,6 +274,7 @@   RobotNamed -> Just CGod   RobotNumbered -> Just CGod   Create -> Just CGod+  Surveil -> Just CGod   -- ----------------------------------------------------------------   -- arithmetic   Eq -> Just CCompare
src/Swarm/Language/Context.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-}  -- |--- Module      :  Swarm.Language.Context--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Generic contexts (mappings from variables to other things, such as
+ src/Swarm/Language/Direction.hs view
@@ -0,0 +1,116 @@+{-# 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. "nearestDirection" and "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. "nearestDirection" and "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. 'north' or 'south').+isCardinal :: Direction -> Bool+isCardinal = \case+  DAbsolute _ -> True+  _ -> False++allDirs :: [Direction]+allDirs = map DAbsolute Util.listEnums <> map DRelative (DDown : map DPlanar Util.listEnums)
src/Swarm/Language/Elaborate.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}  -- |--- Module      :  Swarm.Language.Elaborate--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Term elaboration which happens after type checking.
+ src/Swarm/Language/Key.hs view
@@ -0,0 +1,137 @@+{-# 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 -> tail (show k)
src/Swarm/Language/LSP.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}  -- |--- Module      :  Swarm.Language.LSP--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Language Server Protocol (LSP) server for the Swarm language.@@ -22,11 +18,14 @@ 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+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 @@ -50,7 +49,7 @@                         (Just syncKind)                         (Just False)                         (Just False)-                        (Just $ J.InR $ J.SaveOptions $ Just True)+                        (Just . J.InR . J.SaveOptions $ Just True)                     )               }         }@@ -63,7 +62,7 @@ diagnosticSourcePrefix :: Text diagnosticSourcePrefix = "swarm-lsp" -debug :: MonadIO m => Text -> m ()+debug :: (MonadIO m) => Text -> m () debug msg = liftIO $ Text.hPutStrLn stderr $ "[swarm-lsp] " <> msg  validateSwarmCode :: J.NormalizedUri -> J.TextDocumentVersion -> Text -> LspM () ()@@ -128,6 +127,16 @@       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 =
src/Swarm/Language/LSP/Hover.hs view
@@ -17,9 +17,11 @@ 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.Maybe (fromMaybe)+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@@ -112,6 +114,10 @@   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@@ -178,10 +184,18 @@   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
src/Swarm/Language/LSP/VarUsage.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.Language.LSP.VarUsage where  import Control.Monad (guard)
src/Swarm/Language/Module.hs view
@@ -1,8 +1,4 @@ -- |--- Module      :  Swarm.Language.Module--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A 'Module' packages together a type-annotated syntax tree along
src/Swarm/Language/Parse.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}  -- |--- Module      :  Swarm.Language.Parse--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Parser for the Swarm language.  Note, you probably don't want to@@ -37,12 +34,17 @@ ) where  import Control.Lens (view, (^.))+import Control.Monad (guard, join) import Control.Monad.Combinators.Expr-import Control.Monad.Reader+import Control.Monad.Reader (+  MonadReader (ask),+  ReaderT (runReaderT),+ ) import Data.Bifunctor import Data.Foldable (asum)-import Data.List (nub)+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@@ -52,6 +54,8 @@ 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@@ -82,7 +86,7 @@ reservedWords :: [Text] reservedWords =   map (syntax . constInfo) (filter isUserFunc allConst)-    ++ map (dirSyntax . dirInfo) allDirs+    ++ map directionSyntax allDirs     ++ [ "void"        , "unit"        , "int"@@ -90,6 +94,7 @@        , "dir"        , "bool"        , "actor"+       , "key"        , "cmd"        , "delay"        , "let"@@ -100,6 +105,7 @@        , "false"        , "forall"        , "require"+       , "requirements"        ]  -- | Skip spaces and comments.@@ -138,12 +144,10 @@ locIdentifier = uncurry LV <$> parseLocG ((lexeme . try) (p >>= check) <?> "variable name")  where   p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'')-  check s+  check (into @Text -> t)     | toLower t `elem` reservedWords =-        fail $ "reserved word '" ++ s ++ "' cannot be used as variable name"+        failT ["reserved word", squote t, "cannot be used as variable name"]     | otherwise = return t-   where-    t = into @Text s  -- | Parse a text literal (including escape sequences) in double quotes. textLiteral :: Parser Text@@ -170,6 +174,9 @@ parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") +brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")+ -------------------------------------------------- -- Parser @@ -219,14 +226,24 @@     <|> 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 . dirSyntax . dirInfo) d+  alternative d = d <$ (reserved . directionSyntax) d  -- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@) parseConst :: Parser Const@@ -247,8 +264,17 @@ 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 =+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@@ -266,6 +292,7 @@                         <*> (textLiteral <?> "entity name in double quotes")                     )              )+        <|> uncurry SRequirements <$> (reserved "requirements" *> match parseTerm)         <|> SLam           <$> (symbol "\\" *> locIdentifier)           <*> optional (symbol ":" *> parseType)@@ -279,6 +306,7 @@           <$> (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.@@ -364,8 +392,16 @@     _ -> []  parseExpr :: Parser Syntax-parseExpr = fixDefMissingSemis <$> makeExprParser parseTermAtom table+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@@ -446,7 +482,7 @@ --   "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 p) AllowAntiquoting) initState) of+  case snd (runParser' (runReaderT (fully sc p) AllowAntiquoting) initState) of     Left err -> fail $ errorBundlePretty err     Right e -> return e  where@@ -470,29 +506,18 @@       , stateParseErrors = []       } --- | Run a parser "fully", consuming leading whitespace and ensuring---   that the parser extends all the way to eof.-fully :: Parser a -> Parser a-fully 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 :: Parser a -> Parser (Maybe a)-fullyMaybe = fully . optional- -- | 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 parseTerm)+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 parseTerm) DisallowAntiquoting) ""+readTerm' = parse (runReaderT (fullyMaybe sc parseTerm) DisallowAntiquoting) ""  -- | A utility for converting a ParserError into a one line message: --   <line-nr>: <error-msg>
src/Swarm/Language/Parse/QQ.hs view
@@ -1,8 +1,4 @@ -- |--- Module      :  Swarm.Language.Parse.QQ--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A quasiquoter for Swarm polytypes.
src/Swarm/Language/Pipeline.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}  -- |--- Module      :  Swarm.Language.Pipeline--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Some convenient functions for putting together the whole Swarm@@ -18,13 +14,14 @@   processParsedTerm,   processTerm',   processParsedTerm',-  showTypeErrorPos,+  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@@ -36,28 +33,30 @@ import Swarm.Language.Syntax import Swarm.Language.Typecheck import Swarm.Language.Types-import Witch+import Witch (into)  -- | A record containing the results of the language processing---   pipeline.  Put a 'Term' in, and get one of these out.-data ProcessedTerm-  = ProcessedTerm-      TModule-      -- ^ The elaborated + type-annotated term, plus types of any embedded definitions-      Requirements-      -- ^ Requirements of the term-      ReqCtx-      -- ^ Capability context for any definitions embedded in the term+--   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" tryProcess-   where-    tryProcess :: Text -> Y.Parser ProcessedTerm-    tryProcess t = case processTerm t of-      Left err -> fail $ "Could not parse term: " ++ from err-      Right Nothing -> fail "Term was only whitespace"-      Right (Just pt) -> return pt+  parseJSON = withText "Term" $ either (fail . into @String) return . processTermEither  instance ToJSON ProcessedTerm where   toJSON (ProcessedTerm t _ _) = String $ prettyText (moduleAST t)@@ -75,34 +74,17 @@ processTerm = processTerm' empty empty  -- | Like 'processTerm', but use a term that has already been parsed.-processParsedTerm :: Syntax -> Either TypeErr ProcessedTerm+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 (prettyTypeErr txt) $ traverse (processParsedTerm' ctx capCtx) mt--prettyTypeErr :: Text -> TypeErr -> Text-prettyTypeErr code te = teLoc <> prettyText te- where-  teLoc = case getTypeErrSrcLoc te of-    Just (SrcLoc s e) -> (from . show . fst . fst $ getLocRange code (s, e)) <> ": "-    _anyOtherLoc -> ""--showTypeErrorPos :: Text -> TypeErr -> ((Int, Int), (Int, Int), Text)-showTypeErrorPos code te = (minusOne start, minusOne end, msg)- where-  minusOne (x, y) = (x - 1, y - 1)--  (start, end) = case getTypeErrSrcLoc te of-    Just (SrcLoc s e) -> getLocRange code (s, e)-    _anyOtherLoc -> ((1, 1), (65535, 65535)) -- unknown loc spans the whole document-  msg = prettyText te+  first (prettyTypeErrText txt) $ traverse (processParsedTerm' ctx capCtx) mt  -- | Like 'processTerm'', but use a term that has already been parsed.-processParsedTerm' :: TCtx -> ReqCtx -> Syntax -> Either TypeErr ProcessedTerm+processParsedTerm' :: TCtx -> ReqCtx -> Syntax -> Either ContextualTypeErr ProcessedTerm processParsedTerm' ctx capCtx t = do   m <- inferTop ctx t   let (caps, capCtx') = requirements capCtx (t ^. sTerm)
src/Swarm/Language/Pipeline/QQ.hs view
@@ -1,8 +1,4 @@ -- |--- Module      :  Swarm.Language.Pipeline.QQ--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A quasiquoter for Swarm terms.@@ -13,10 +9,10 @@ import Language.Haskell.TH.Quote import Swarm.Language.Parse import Swarm.Language.Pipeline-import Swarm.Language.Pretty (prettyText)+import Swarm.Language.Pretty import Swarm.Language.Syntax import Swarm.Language.Types (Polytype)-import Swarm.Util (liftText)+import Swarm.Util (failT, liftText) import Witch (from)  -- | A quasiquoter for Swarm language terms, so we can conveniently@@ -46,7 +42,7 @@         )   parsed <- runParserTH pos parseTerm s   case processParsedTerm parsed of-    Left errMsg -> fail $ from $ prettyText errMsg+    Left err -> failT [prettyTypeErrText (from s) err]     Right ptm -> dataToExpQ ((fmap liftText . cast) `extQ` antiTermExp) ptm  antiTermExp :: Term' Polytype -> Maybe TH.ExpQ
src/Swarm/Language/Pretty.hs view
@@ -4,10 +4,6 @@ {-# LANGUAGE ViewPatterns #-}  -- |--- Module      :  Swarm.Language.Pretty--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Pretty-printing for the Swarm language.@@ -18,6 +14,9 @@ import Control.Unification.IntVar import Data.Bool (bool) import Data.Functor.Fixedpoint (Fix, unFix)+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@@ -26,27 +25,40 @@ 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 (showLowT) 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 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 = RT.renderStrict . layoutPretty defaultLayoutOptions . ppr+prettyText :: (PrettyPrec a) => a -> Text+prettyText = docToText . 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 = RS.renderString . layoutPretty defaultLayoutOptions . ppr+prettyString :: (PrettyPrec a) => a -> String+prettyString = docToString . ppr  -- | Optionally surround a document with parentheses depending on the --   @Bool@ argument.@@ -54,6 +66,33 @@ pparens True = parens pparens False = id +-- | Surround a document with backticks.+bquote :: Doc ann -> Doc ann+bquote d = "`" <> d <> "`"++-- | Turn a 'Show' instance into a @Doc@, lowercasing it in the+--   process.+prettyShowLow :: Show a => a -> Doc ann+prettyShowLow = pretty . showLowT++--------------------------------------------------+-- Bullet lists++data BulletList i = BulletList+  { bulletListHeader :: forall a. Doc a+  , bulletListItems :: [i]+  }++instance (PrettyPrec i) => PrettyPrec (BulletList i) where+  prettyPrec _ (BulletList hdr items) =+    nest 2 . vcat $ hdr : map (("-" <+>) . ppr) items++------------------------------------------------------------+-- PrettyPrec instances for terms, types, etc.++instance PrettyPrec Text where+  prettyPrec _ = pretty+ instance PrettyPrec BaseTy where   prettyPrec _ BVoid = "void"   prettyPrec _ BUnit = "unit"@@ -62,18 +101,28 @@   prettyPrec _ BText = "text"   prettyPrec _ BBool = "bool"   prettyPrec _ BActor = "actor"+  prettyPrec _ BKey = "key"  instance PrettyPrec IntVar where   prettyPrec _ = pretty . mkVarName "u" -instance PrettyPrec (t (Fix t)) => PrettyPrec (Fix t) where+-- | 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 (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 PrettyPrec t => PrettyPrec (TypeF t) where+instance (PrettyPrec t) => PrettyPrec (TypeF t) where   prettyPrec _ (TyBaseF b) = ppr b   prettyPrec _ (TyVarF v) = pretty v   prettyPrec p (TySumF ty1 ty2) =@@ -87,6 +136,7 @@   prettyPrec p (TyFunF ty1 ty2) =     pparens (p > 0) $       prettyPrec 1 ty1 <+> "->" <+> prettyPrec 0 ty2+  prettyPrec _ (TyRcdF m) = brackets $ hsep (punctuate "," (map prettyBinding (M.assocs m)))  instance PrettyPrec Polytype where   prettyPrec _ (Forall [] t) = ppr t@@ -96,14 +146,15 @@   prettyPrec _ (Forall [] t) = ppr t   prettyPrec _ (Forall xs t) = hsep ("∀" : map pretty xs) <> "." <+> ppr t -instance PrettyPrec t => PrettyPrec (Ctx t) where+instance (PrettyPrec t) => PrettyPrec (Ctx t) where   prettyPrec _ Empty = emptyDoc   prettyPrec _ (assocs -> bs) = brackets (hsep (punctuate "," (map prettyBinding bs)))-   where-    prettyBinding (x, ty) = pretty x <> ":" <+> ppr ty +prettyBinding :: (Pretty a, PrettyPrec b) => (a, b) -> Doc ann+prettyBinding (x, ty) = pretty x <> ":" <+> ppr ty+ instance PrettyPrec Direction where-  prettyPrec _ = pretty . dirSyntax . dirInfo+  prettyPrec _ = pretty . directionSyntax  instance PrettyPrec Capability where   prettyPrec _ c = pretty $ T.toLower (from (tail $ show c))@@ -127,6 +178,7 @@   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) = braces $ ppr t   prettyPrec _ t@TPair {} = prettyTuple t@@ -170,7 +222,16 @@   prettyPrec p (TBind (Just x) t1 t2) =     pparens (p > 0) $       pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <+> 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 = pparens True . hsep . punctuate "," . map ppr . unnestTuple  where@@ -188,25 +249,136 @@   _ -> appliedTermPrec f appliedTermPrec _ = 10 +------------------------------------------------------------+-- 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 _ (Mismatch _ ty1 ty2) =+  prettyPrec _ (UnifyErr ty1 ty2) =     "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2-  prettyPrec _ (EscapedSkolem _ x) =+  prettyPrec _ (Mismatch Nothing (getJoin -> (ty1, ty2))) =+    "Type mismatch: expected" <+> ppr ty1 <> ", but got" <+> ppr ty2+  prettyPrec _ (Mismatch (Just t) (getJoin -> (ty1, ty2))) =+    nest 2 . vcat $+      [ "Type mismatch:"+      , "From context, expected" <+> bquote (ppr t) <+> "to" <+> typeDescription Expected ty1 <> ","+      , "but it" <+> typeDescription Actual ty2+      ]+  prettyPrec _ (LambdaArgMismatch (getJoin -> (ty1, ty2))) =+    "Lambda argument has type annotation" <+> bquote (ppr ty2) <> ", but expected argument type" <+> bquote (ppr ty1)+  prettyPrec _ (FieldsMismatch (getJoin -> (expFs, actFs))) = fieldMismatchMsg expFs actFs+  prettyPrec _ (EscapedSkolem x) =     "Skolem variable" <+> pretty x <+> "would escape its scope"-  prettyPrec _ (UnboundVar _ x) =+  prettyPrec _ (UnboundVar x) =     "Unbound variable" <+> pretty x   prettyPrec _ (Infinite x uty) =     "Infinite type:" <+> ppr x <+> "=" <+> ppr uty-  prettyPrec _ (DefNotTopLevel _ t) =+  prettyPrec _ (DefNotTopLevel t) =     "Definitions may only be at the top level:" <+> ppr t-  prettyPrec _ (CantInfer _ t) =+  prettyPrec _ (CantInfer t) =     "Couldn't infer the type of term (this shouldn't happen; please report this as a bug!):" <+> ppr t-  prettyPrec _ (InvalidAtomic _ reason t) =+  prettyPrec _ (CantInferProj t) =+    "Can't infer the type of a record projection:" <+> ppr t+  prettyPrec _ (UnknownProj x t) =+    "Record does not have a field with name" <+> pretty x <> ":" <+> ppr t+  prettyPrec _ (InvalidAtomic reason t) =     "Invalid atomic block:" <+> ppr reason <> ":" <+> ppr t+  prettyPrec _ 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 ." +-- | 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 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"
src/Swarm/Language/Requirement.hs view
@@ -1,8 +1,4 @@ -- |--- Module      :  Swarm.Language.Requirement--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A requirement is something that is needed in order to successfully@@ -190,6 +186,9 @@     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)@@ -242,3 +241,10 @@     -- 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
src/Swarm/Language/Syntax.hs view
@@ -8,10 +8,6 @@ {-# LANGUAGE ViewPatterns #-}  -- |--- Module      :  Swarm.Language.Syntax--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Abstract syntax for terms of the Swarm programming language.@@ -20,17 +16,10 @@   Direction (..),   AbsoluteDir (..),   RelativeDir (..),-  DirInfo (..),-  applyTurn,-  toDirection,-  fromDirection,-  allDirs,+  PlanarRelativeDir (..),+  directionSyntax,   isCardinal,-  dirInfo,-  north,-  south,-  east,-  west,+  allDirs,    -- * Constants   Const (..),@@ -48,6 +37,9 @@   isBuiltinFunction,   isTangible,   isLong,+  maxSniffRange,+  maxScoutRange,+  maxStrideRange,    -- * Syntax   Syntax' (..),@@ -60,6 +52,7 @@   SrcLoc (..),   noLoc,   pattern STerm,+  pattern TRequirements,   pattern TPair,   pattern TLam,   pattern TApp,@@ -68,6 +61,9 @@   pattern TDef,   pattern TBind,   pattern TDelay,+  pattern TRcd,+  pattern TProj,+  pattern TAnnotate,    -- * Terms   Var,@@ -88,150 +84,39 @@   freeVarsV,   mapFreeS,   locVarToSyntax',+  asTree,+  measureAstSize, ) where -import Control.Arrow (Arrow ((&&&)))-import Control.Lens (Plated (..), Traversal', makeLenses, (%~), (^.))-import Data.Aeson.Types-import Data.Char qualified as C (toLower)+import Control.Lens (Plated (..), Traversal', makeLenses, para, universe, (%~), (^.))+import Data.Aeson.Types hiding (Key) import Data.Data (Data) import Data.Data.Lens (uniplate)-import Data.Hashable (Hashable)-import Data.List qualified as L (tail)+import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty-import Data.Map qualified as M+import Data.Map.Strict (Map) import Data.Set qualified as S import Data.String (IsString (fromString))-import Data.Text hiding (filter, map)+import Data.Text hiding (filter, length, map) import Data.Text qualified as T+import Data.Tree import GHC.Generics (Generic)-import Linear+import Swarm.Language.Direction import Swarm.Language.Types import Swarm.Util qualified as Util-import Swarm.Util.Location (Heading) 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.-data AbsoluteDir = DNorth | DSouth | DEast | DWest-  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON, Enum, Bounded)--cardinalDirectionKeyOptions :: JSONKeyOptions-cardinalDirectionKeyOptions =-  defaultJSONKeyOptions-    { keyModifier = map C.toLower . L.tail-    }--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 = DLeft | DRight | DBack | DForward | DDown-  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON, Enum, Bounded)---- | 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)--data DirInfo = DirInfo-  { dirSyntax :: Text-  , dirApplyTurn :: Heading -> Heading-  -- ^ the turning for the direction-  }--allDirs :: [Direction]-allDirs = map DAbsolute Util.listEnums <> map DRelative Util.listEnums--toHeading :: AbsoluteDir -> Heading-toHeading = \case-  DNorth -> north-  DSouth -> south-  DEast -> east-  DWest -> west---- | Information about all directions-dirInfo :: Direction -> DirInfo-dirInfo d = case d of-  DRelative e -> case e of-    DLeft -> relative perp-    DRight -> relative (fmap negate . perp)-    DBack -> relative (fmap negate)-    DDown -> relative (const down)-    DForward -> relative id-  DAbsolute e -> cardinal $ toHeading e- where-  -- name is generate from Direction data constuctor-  -- e.g. DLeft becomes "left"-  directionSyntax = toLower . T.tail . from $ case d of-    DAbsolute x -> show x-    DRelative x -> show x--  cardinal = DirInfo directionSyntax . const-  relative = DirInfo directionSyntax---- | Check if the direction is absolute (e.g. 'north' or 'south').-isCardinal :: Direction -> Bool-isCardinal = \case-  DAbsolute _ -> True-  _ -> False---- | 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 :: Direction -> Heading -> Heading-applyTurn = dirApplyTurn . dirInfo---- | Mapping from heading to their corresponding cardinal directions.---   Only absolute directions are mapped.-cardinalDirs :: M.Map Heading Direction-cardinalDirs =-  M.fromList $ map (toHeading &&& DAbsolute) Util.listEnums+-- | Maximum perception distance for+-- 'chirp' and 'sniff' commands+maxSniffRange :: Int32+maxSniffRange = 256 --- | 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 :: Heading -> Maybe Direction-toDirection v = M.lookup v cardinalDirs+maxScoutRange :: Int+maxScoutRange = 64 --- | 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+maxStrideRange :: Int+maxStrideRange = 64  ------------------------------------------------------------ -- Constants@@ -265,6 +150,12 @@      -- | Move forward one step.     Move+  | -- | Move backward one step.+    Backup+  | -- | Push an entity forward one step.+    Push+  | -- | Move forward multiple steps.+    Stride   | -- | Turn in some direction.     Turn   | -- | Grab an item from the current location.@@ -289,6 +180,8 @@     Count   | -- | Drill through an entity.     Drill+  | -- | Use an entity with another.+    Use   | -- | Construct a new robot.     Build   | -- | Deconstruct an old robot.@@ -309,12 +202,35 @@   | -- | 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.@@ -434,6 +350,14 @@     --   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.@@ -598,6 +522,16 @@       , "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."+  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 ->@@ -623,7 +557,13 @@       [ "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."@@ -650,7 +590,10 @@       , "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 "View the given actor."+  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)."@@ -659,8 +602,58 @@   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 ->@@ -747,6 +740,21 @@     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."@@ -849,6 +857,12 @@     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.@@ -876,6 +890,14 @@     --   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, Traversable, Data, Generic, FromJSON, ToJSON)  -- The Traversable instance for Term (and for Syntax') is used during@@ -944,6 +966,9 @@   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)@@ -986,8 +1011,21 @@ 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, TVar, TPair, TLam, TApp, TLet, TDef, TBind, TDelay #-}+{-# 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@).@@ -1040,6 +1078,7 @@ erase (TRef r) = TRef r erase (TRequireDevice d) = TRequireDevice d erase (TRequire n e) = TRequire n e+erase (SRequirements x s) = TRequirements x (eraseS s) erase (TVar s) = TVar s erase (SDelay x s) = TDelay x (eraseS s) erase (SPair s1 s2) = TPair (eraseS s1) (eraseS s2)@@ -1048,6 +1087,9 @@ erase (SLet r x mty s1 s2) = TLet r (lvVar x) mty (eraseS s1) (eraseS s2) erase (SDef r x mty s) = TDef r (lvVar x) mty (eraseS s) erase (SBind mx s1 s2) = TBind (lvVar <$> mx) (eraseS s1) (eraseS s2)+erase (SRcd m) = TRcd ((fmap . fmap) eraseS m)+erase (SProj s x) = TProj (eraseS s) x+erase (SAnnotate s pty) = TAnnotate (eraseS s) pty  ------------------------------------------------------------ -- Free variable traversals@@ -1077,6 +1119,7 @@     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@@ -1089,6 +1132,9 @@     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 @@ -1111,3 +1157,13 @@ -- | 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
+ src/Swarm/Language/Text/Markdown.hs view
@@ -0,0 +1,341 @@+{-# 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 Control.Monad (void)+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.Module (moduleAST)+import Swarm.Language.Parse (readTerm)+import Swarm.Language.Pipeline (ProcessedTerm (..), processParsedTerm)+import Swarm.Language.Pretty (PrettyPrec (..), prettyText, 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+    Left e -> Left (T.unpack $ prettyTypeErrText t e)+    Right (ProcessedTerm modul _req _reqCtx) -> Right $ void $ moduleAST modul++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 (prettyText 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
src/Swarm/Language/Typecheck.hs view
@@ -7,10 +7,6 @@ -- For 'Ord IntVar' instance  -- |--- Module      :  Swarm.Language.Typecheck--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Type inference for the Swarm language.  For the approach used here,@@ -18,19 +14,31 @@ -- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/ . module Swarm.Language.Typecheck (   -- * Type errors+  ContextualTypeErr (..),   TypeErr (..),   InvalidAtomicReason (..),-  getTypeErrSrcLoc, -  -- * Inference monad-  Infer,-  runInfer,-  lookup,+  -- * Type provenance+  Source (..),+  withSource,+  Join,+  getJoin,++  -- * Typechecking stack+  TCFrame (..),+  LocatedTCFrame (..),+  TCStack,+  withFrame,+  getTCStack,++  -- * Typechecking monad+  TC,+  runTC,   fresh,    -- * Unification   substU,-  (=:=),+  unify,   HasBindings (..),   instantiate,   skolemize,@@ -42,69 +50,171 @@   infer,   inferConst,   check,-  decomposeCmdTy,-  decomposeFunTy,   isSimpleUType, ) where +import Control.Arrow ((***)) import Control.Category ((>>>)) import Control.Lens ((^.))-import Control.Monad.Except-import Control.Monad.Reader-import Control.Unification hiding (applyBindings, (=:=))+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 (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)  --------------------------------------------------------------- Inference monad+-- Typechecking stack --- | The concrete monad used for type inference.  'IntBindingT' is a+-- | 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.-type Infer = ReaderT UCtx (ExceptT TypeErr (IntBindingT TypeF Identity))+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'.-runInfer :: TCtx -> Infer UModule -> Either TypeErr TModule-runInfer ctx =+runTC :: TCtx -> TC UModule -> Either ContextualTypeErr TModule+runTC ctx =   (>>= applyBindings)     >>> ( >>=             \(Module u uctx) ->               Module-                <$> mapM (fmap fromU . generalize) u-                <*> pure (fromU uctx)+                <$> 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 -> Infer UType+lookup :: SrcLoc -> Var -> TC UType lookup loc x = do-  ctx <- ask-  maybe (throwError $ UnboundVar loc x) instantiate (Ctx.lookup x ctx)+  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@@ -116,14 +226,14 @@  -- | A class for getting the free unification variables of a thing. class FreeVars a where-  freeVars :: a -> Infer (Set IntVar)+  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 $ getFreeVars ut+  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+instance (FreeVars t) => FreeVars (Poly t) where   freeVars (Forall _ t) = freeVars t  -- | We can get the free variables in any polytype in a context.@@ -131,8 +241,8 @@   freeVars = fmap S.unions . mapM freeVars . M.elems . unCtx  -- | Generate a fresh unification variable.-fresh :: Infer UType-fresh = UVar <$> lift (lift freeVar)+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@@ -147,15 +257,52 @@         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 =:= --- | Constrain two types to be equal.-(=:=) :: UType -> UType -> Infer UType-s =:= t = lift $ s U.=:= t+-- | @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@@ -163,10 +310,10 @@ --   unification variables in it and to which we can usefully apply --   'U.applyBindings'. class HasBindings u where-  applyBindings :: u -> Infer u+  applyBindings :: u -> TC u  instance HasBindings UType where-  applyBindings = lift . U.applyBindings+  applyBindings = lift . lift . U.applyBindings  instance HasBindings UPolytype where   applyBindings (Forall xs u) = Forall xs <$> applyBindings u@@ -189,7 +336,7 @@ -- | 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 -> Infer UType+instantiate :: UPolytype -> TC UType instantiate (Forall xs uty) = do   xs' <- mapM (const fresh) xs   return $ substU (M.fromList (zip (map Left xs) xs')) uty@@ -199,7 +346,7 @@ --   variables cannot unify with anything other than themselves.  This --   is used when checking something with a polytype explicitly --   specified by the user.-skolemize :: UPolytype -> Infer UType+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@@ -209,19 +356,48 @@  -- | 'generalize' is the opposite of 'instantiate': add a 'Forall' --   which closes over all free type and unification variables.-generalize :: UType -> Infer UPolytype+--+--   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 <- ask+  ctx <- getCtx   tmfvs <- freeVars uty'   ctxfvs <- freeVars ctx   let fvs = S.toList $ tmfvs \\ ctxfvs-      xs = map (mkVarName "a") fvs-  return $ Forall xs (substU (M.fromList (zip (map Right fvs) (map UTyVar xs))) uty')+      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@@ -229,20 +405,38 @@ --   separately be pretty-printed to display them to the user. data TypeErr   = -- | An undefined variable was encountered.-    UnboundVar SrcLoc Var+    UnboundVar Var   | -- | A Skolem variable escaped its local context.-    EscapedSkolem SrcLoc Var-  | Infinite IntVar UType-  | -- | The given term was expected to have a certain type, but has a-    -- different type instead.-    Mismatch SrcLoc (TypeF UType) (TypeF UType)+    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 SrcLoc Term+    DefNotTopLevel Term   | -- | A term was encountered which we cannot infer the type of.     --   This should never happen.-    CantInfer SrcLoc Term+    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 SrcLoc InvalidAtomicReason Term+    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.@@ -259,47 +453,82 @@     LongConst   deriving (Show) -instance Fallible TypeF IntVar TypeErr where-  occursFailure = Infinite-  mismatchFailure = Mismatch NoLoc+instance Fallible TypeF IntVar ContextualTypeErr where+  occursFailure v t = mkRawTypeErr (Infinite v t)+  mismatchFailure t1 t2 = mkRawTypeErr (UnifyErr t1 t2) -getTypeErrSrcLoc :: TypeErr -> Maybe SrcLoc-getTypeErrSrcLoc te = case te of-  UnboundVar l _ -> Just l-  EscapedSkolem l _ -> Just l-  Infinite _ _ -> Nothing-  Mismatch l _ _ -> Just l-  DefNotTopLevel l _ -> Just l-  CantInfer l _ -> Just l-  InvalidAtomic l _ _ -> Just l+------------------------------------------------------------+-- 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 TypeErr TModule-inferTop ctx = runInfer ctx . inferModule+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 -> Infer UModule-inferModule s@(Syntax l t) = (`catchError` addLocToTypeErr s) $ case t of+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 -> do+  SDef r x Nothing t1 -> withFrame l (TCDef (lvVar x)) $ do     xTy <- fresh     t1' <- withBinding (lvVar x) (Forall [] xTy) $ infer t1-    _ <- xTy =:= t1' ^. sType+    _ <- 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 -> do+  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@@ -310,8 +539,8 @@   -- correct context when checking the right-hand side in particular.   SBind mx c1 c2 -> do     -- First, infer the left side.-    Module c1' ctx1 <- inferModule c1-    a <- decomposeCmdTy (c1' ^. sType)+    Module c1' ctx1 <- withFrame l TCBindL $ inferModule c1+    a <- decomposeCmdTy c1 (Actual, c1' ^. sType)      -- Now infer the right side under an extended context: things in     -- scope on the right-hand side include both any definitions@@ -322,13 +551,13 @@     -- that binding /after/ (i.e. /within/) the application of @ctx1@.     withBindings ctx1 $       maybe id ((`withBinding` Forall [] a) . lvVar) mx $ do-        Module c2' ctx2 <- inferModule c2+        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' ^. sType)+        _ <- decomposeCmdTy c2 (Actual, c2' ^. sType)          -- Ctx.union is right-biased, so ctx1 `union` ctx2 means later         -- definitions will shadow previous ones.  Include the binder@@ -347,8 +576,18 @@  -- | Infer the type of a term which does not contain definitions, --   returning a type-annotated term.-infer :: Syntax -> Infer (Syntax' UType)-infer s@(Syntax l t) = (`catchError` addLocToTypeErr s) $ case t of+--+--   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@@ -358,140 +597,121 @@   TAntiText x -> return $ Syntax' l (TAntiText x) UTyText   TBool b -> return $ Syntax' l (TBool b) UTyBool   TRobot r -> return $ Syntax' l (TRobot r) UTyActor-  -- We should never encounter a TRef since they do not show up in-  -- surface syntax, only as values while evaluating (*after*-  -- typechecking).-  TRef _ -> throwError $ CantInfer l t   TRequireDevice d -> return $ Syntax' l (TRequireDevice d) (UTyCmd UTyUnit)   TRequire n d -> return $ Syntax' l (TRequire n d) (UTyCmd UTyUnit)-  -- To infer the type of a pair, just infer both components.-  SPair t1 t2 -> do-    t1' <- infer t1-    t2' <- infer t2-    return $ Syntax' l (SPair t1' t2') (UTyProd (t1' ^. sType) (t2' ^. sType))--  -- 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 t1 -> do+  SRequirements x t1 -> do     t1' <- infer t1-    return $ Syntax' l (SDelay d t1') (UTyDelay (t1' ^. sType))--  -- We need a special case for checking the argument to 'atomic'.-  -- 'atomic t' has the same type as 't', which must have a type of-  -- the form 'cmd a'.  't' must also be syntactically free of-  -- variables.--  TConst Atomic :$: at -> do-    argTy <- fresh-    at' <- check at (UTyCmd argTy)-    atomic' <- infer (Syntax l (TConst Atomic))-    -- 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.-    validAtomic at-    return $ Syntax' l (SApp atomic' at') (at' ^. sType)+    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-  -- To infer the type of a lambda if the type of the argument is-  -- provided, just infer the body under an extended context and return-  -- the appropriate function type.-  SLam x (Just argTy) lt -> do+  -- 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-    lt' <- withBinding (lvVar x) (Forall [] uargTy) $ infer lt-    return $ Syntax' l (SLam x (Just argTy) lt') (UTyFun uargTy (lt' ^. sType))--  -- If the type of the argument is not provided, create a fresh-  -- unification variable for it and proceed.-  SLam x Nothing lt -> do-    argTy <- fresh-    lt' <- withBinding (lvVar x) (Forall [] argTy) $ infer lt-    return $ Syntax' l (SLam x Nothing lt') (UTyFun argTy (lt' ^. sType))+    body' <- withBinding (lvVar x) (Forall [] uargTy) $ infer body+    return $ Syntax' l (SLam x (Just argTy) body') (UTyFun uargTy (body' ^. sType)) -  -- To infer the type of an application:+  -- 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-    (ty1, ty2) <- decomposeFunTy (f' ^. sType)+    (argTy, resTy) <- decomposeFunTy f (Actual, f' ^. sType)      -- Then check that the argument has the right type.-    x' <- check x ty1 `catchError` addLocToTypeErr x-    return $ Syntax' l (SApp f' x') ty2+    x' <- check x argTy -  -- We can infer the type of a let whether a type has been provided for-  -- the variable or not.-  SLet r x Nothing t1 t2 -> do-    xTy <- fresh-    t1' <- withBinding (lvVar x) (Forall [] xTy) $ infer t1-    let uty = t1' ^. sType-    _ <- xTy =:= uty-    upty <- generalize uty-    t2' <- withBinding (lvVar x) upty $ infer t2-    return $ Syntax' l (SLet r x Nothing t1' t2') (t2' ^. sType)-  SLet r x (Just pty) t1 t2 -> do-    let upty = toU pty-    -- If an explicit polytype has been provided, skolemize it and check-    -- definition and body under an extended context.-    uty <- skolemize upty-    (t1', t2') <- withBinding (lvVar x) upty $ do-      (,)-        <$> check t1 uty-        `catchError` addLocToTypeErr t1-        <*> infer t2-    -- Make sure no skolem variables have escaped.-    ask >>= mapM_ noSkolems-    return $ Syntax' l (SLet r x (Just pty) t1' t2') (t2' ^. sType)-  SDef {} -> throwError $ DefNotTopLevel l t+    -- 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' <- infer c1-    a <- decomposeCmdTy (c1' ^. sType)-    c2' <- maybe id ((`withBinding` Forall [] a) . lvVar) mx $ infer c2-    _ <- decomposeCmdTy (c2' ^. sType)+    c1' <- withFrame l TCBindL $ infer c1+    a <- decomposeCmdTy c1 (Actual, c1' ^. sType)+    c2' <-+      maybe id ((`withBinding` Forall [] a) . lvVar) mx+        . withFrame l TCBindR+        $ infer c2+    _ <- decomposeCmdTy c2 (Actual, c2' ^. sType)     return $ Syntax' l (SBind mx c1' c2') (c2' ^. sType)- where-  noSkolems :: UPolytype -> Infer ()-  noSkolems (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-    unless (S.null ftyvs) $-      throwError $-        EscapedSkolem l (head (S.toList ftyvs)) -addLocToTypeErr :: Syntax' ty -> TypeErr -> Infer a-addLocToTypeErr s te = case te of-  Mismatch NoLoc a b -> throwError $ Mismatch (s ^. sLoc) a b-  _ -> throwError te+  -- 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) --- | Decompose a type that is supposed to be a command type.-decomposeCmdTy :: UType -> Infer UType-decomposeCmdTy (UTyCmd a) = return a-decomposeCmdTy ty = do-  a <- fresh-  _ <- ty =:= UTyCmd a-  return a+  -- 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')) --- | Decompose a type that is supposed to be a function type.-decomposeFunTy :: UType -> Infer (UType, UType)-decomposeFunTy (UTyFun ty1 ty2) = return (ty1, ty2)-decomposeFunTy ty = do-  ty1 <- fresh-  ty2 <- fresh-  _ <- ty =:= UTyFun ty1 ty2-  return (ty1, ty2)+  -- 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@@ -499,6 +719,9 @@   Noop -> [tyQ| cmd unit |]   Selfdestruct -> [tyQ| cmd unit |]   Move -> [tyQ| cmd unit |]+  Backup -> [tyQ| cmd unit |]+  Push -> [tyQ| cmd unit |]+  Stride -> [tyQ| int -> cmd unit |]   Turn -> [tyQ| dir -> cmd unit |]   Grab -> [tyQ| cmd text |]   Harvest -> [tyQ| cmd text |]@@ -512,7 +735,8 @@   Count -> [tyQ| text -> cmd int |]   Reprogram -> [tyQ| actor -> {cmd a} -> cmd unit |]   Build -> [tyQ| {cmd a} -> cmd actor |]-  Drill -> [tyQ| dir -> cmd unit |]+  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 |]@@ -520,8 +744,18 @@   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) |]@@ -572,6 +806,9 @@   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 |]@@ -583,12 +820,146 @@  -- | @check t ty@ checks that @t@ has type @ty@, returning a --   type-annotated AST if so.-check :: Syntax -> UType -> Infer (Syntax' UType)-check t ty = do-  Syntax' l t' ty' <- infer t-  theTy <- ty =:= ty'-  return $ Syntax' l t' theTy+--+--   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@@ -614,15 +985,15 @@ --   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 -> Infer ()+validAtomic :: Syntax -> TC () validAtomic s@(Syntax l t) = do   n <- analyzeAtomic S.empty s-  when (n > 1) $ throwError (InvalidAtomic l (TooManyTicks n) t)+  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 -> Infer Int+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@@ -636,13 +1007,14 @@   TRobot {} -> return 0   TRequireDevice {} -> return 0   TRequire {} -> return 0+  SRequirements {} -> return 0   -- Constants.   TConst c     -- Nested 'atomic' is not allowed.-    | c == Atomic -> throwError $ InvalidAtomic l NestedAtomic t+    | 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 -> throwError $ InvalidAtomic l LongConst t+    | 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@@ -658,11 +1030,17 @@   -- 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 <- asks $ Ctx.lookup x+        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@@ -687,15 +1065,17 @@             xTy' <- applyBindings xTy             if isSimpleUPolytype xTy'               then return 0-              else throwError (InvalidAtomic l (NonSimpleVarType x xTy') t)+              else throwTypeErr l $ InvalidAtomic (NonSimpleVarType x xTy') t   -- No lambda, `let` or `def` allowed!-  SLam {} -> throwError (InvalidAtomic l AtomicDupingThing t)-  SLet {} -> throwError (InvalidAtomic l AtomicDupingThing t)-  SDef {} -> throwError (InvalidAtomic l AtomicDupingThing t)+  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 {} -> throwError (CantInfer l t)+  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
+ src/Swarm/Language/Typecheck/Unify.hs view
@@ -0,0 +1,90 @@+-- |+-- 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
src/Swarm/Language/Typed.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.Language.Typed (Typed (..), value, polytype, requires) where  import Control.Lens (makeLenses)
src/Swarm/Language/Types.hs view
@@ -5,10 +5,6 @@ -- for the Data IntVar instance  -- |--- Module      :  Swarm.Language.Types--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Types for the Swarm programming language and related utilities.@@ -30,9 +26,11 @@   pattern TyDir,   pattern TyBool,   pattern TyActor,+  pattern TyKey,   pattern (:+:),   pattern (:*:),   pattern (:->:),+  pattern TyRcd,   pattern TyCmd,   pattern TyDelay, @@ -47,9 +45,11 @@   pattern UTyDir,   pattern UTyBool,   pattern UTyActor,+  pattern UTyKey,   pattern UTySum,   pattern UTyProd,   pattern UTyFun,+  pattern UTyRcd,   pattern UTyCmd,   pattern UTyDelay, @@ -71,13 +71,18 @@   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.Maybe (fromJust)+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 (..))@@ -110,6 +115,8 @@     --   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.@@ -133,8 +140,21 @@     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@@ -202,7 +222,8 @@ -- | 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, Data, Generic, FromJSON, ToJSON)+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@@ -227,7 +248,7 @@ --   used only on inputs that are safe. class WithU t where   -- | The associated "@U@-version" of the type @t@.-  type U 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@@ -238,20 +259,20 @@   --   Generally, this direction requires somehow knowing that there   --   are no longer any unification variables in the value being   --   converted.-  fromU :: U t -> t+  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 = fromJust . freeze+  fromU = freeze  -- | A 'WithU' instance can be lifted through any functor (including, --   in particular, 'Ctx' and 'Poly').-instance (WithU t, Functor f) => WithU (f t) where+instance (WithU t, Traversable f) => WithU (f t) where   type U (f t) = f (U t)   toU = fmap toU-  fromU = fmap fromU+  fromU = traverse fromU  ------------------------------------------------------------ -- Pattern synonyms@@ -284,6 +305,9 @@ pattern TyActor :: Type pattern TyActor = Fix (TyBaseF BActor) +pattern TyKey :: Type+pattern TyKey = Fix (TyBaseF BKey)+ infixr 5 :+:  pattern (:+:) :: Type -> Type -> Type@@ -299,6 +323,9 @@ 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) @@ -332,6 +359,9 @@ 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) @@ -340,6 +370,9 @@  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)
src/Swarm/Language/Value.hs view
@@ -2,10 +2,6 @@ {-# LANGUAGE GADTs #-}  -- |--- Module      :  Swarm.Language.Value--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Values and environments used for interpreting the Swarm language.@@ -23,15 +19,16 @@ 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-import Prelude  -- | A /value/ is a term that cannot (or does not) take any more --   evaluation steps on its own.@@ -85,6 +82,12 @@   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'.@@ -117,6 +120,9 @@ 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
+ src/Swarm/ReadableIORef.hs view
@@ -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.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
src/Swarm/TUI/Attr.hs view
@@ -1,11 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}  -- |--- Module      :  Swarm.TUI.Attr--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Rendering attributes (/i.e./ foreground and background colors,@@ -20,6 +15,7 @@   swarmAttrMap,   worldAttributes,   worldPrefix,+  toAttrName,    -- ** Terrain attributes   dirtAttr,@@ -39,6 +35,7 @@   notifAttr,   infoAttr,   boldAttr,+  italicAttr,   dimAttr,   magentaAttr,   cyanAttr,@@ -48,17 +45,27 @@   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 import Data.Bifunctor (bimap)-import Data.Yaml+import Data.Text (unpack) import Graphics.Vty qualified as V-import Witch (from)+import Swarm.Game.Display (Attribute (..)) +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 =@@ -73,12 +80,14 @@            (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 50 50 50))          , (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)@@ -154,6 +163,7 @@   , notifAttr   , infoAttr   , boldAttr+  , italicAttr   , dimAttr   , defAttr ::     AttrName@@ -161,9 +171,13 @@ 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"@@ -173,9 +187,3 @@ cyanAttr = attrName "cyan" lightCyanAttr = attrName "lightCyan" magentaAttr = attrName "magenta"--instance ToJSON AttrName where-  toJSON = toJSON . head . attrNameComponents--instance FromJSON AttrName where-  parseJSON = withText "AttrName" (pure . attrName . from)
src/Swarm/TUI/Border.hs view
@@ -1,12 +1,6 @@------------------------------------------------------------------------------------------------------------------------------------------------------------ {-# LANGUAGE TemplateHaskell #-}  -- |--- Module      :  Swarm.TUI.Border--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Special border drawing functions that can include labels in more
src/Swarm/TUI/Controller.hs view
@@ -2,10 +2,6 @@ {-# LANGUAGE QuasiQuotes #-}  -- |--- Module      :  Swarm.TUI.Controller--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Event handlers for the TUI.@@ -17,12 +13,14 @@   -- ** Handling 'Frame' events   runFrameUI,   runFrame,+  ticksPerFrameCap,   runFrameTicks,   runGameTickUI,   runGameTick,   updateUI,    -- ** REPL panel+  runBaseWebCode,   handleREPLEvent,   validateREPLForm,   adjReplHistIndex,@@ -36,22 +34,26 @@    -- ** Info panel   handleInfoPanelEvent,++  -- ** Utils+  getTutorials, ) where  import Brick hiding (Direction, Location)-import Brick qualified 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-import Control.Lens.Extras (is)-import Control.Monad.Except+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.State+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.State (MonadState, execState) import Data.Bits import Data.Either (isRight) import Data.Foldable (toList)@@ -59,7 +61,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M-import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.String (fromString) import Data.Text qualified as T import Data.Text.IO qualified as T@@ -67,45 +69,63 @@ import Data.Vector qualified as V import Graphics.Vty qualified as V import Linear-import Swarm.Game.CESK (cancel, emptyStore, initMachine)+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.Scenario.Objective.Presentation.Model-import Swarm.Game.Scenario.Objective.Presentation.Render qualified as GR import Swarm.Game.ScenarioInfo import Swarm.Game.State-import Swarm.Game.Step (gameTick)-import Swarm.Game.World qualified as W-import Swarm.Language.Capability (Capability (CMake))+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+import Swarm.Language.Syntax hiding (Key) import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Types-import Swarm.Language.Value (Value (VUnit), prettyValue, stripVResult)+import Swarm.Language.Value (Value (VKey, VUnit), prettyValue, stripVResult) 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.Achievement.Definitions-import Swarm.TUI.Model.Achievement.Persistence+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 (generateModal)-import Swarm.Util hiding ((<<.=))-import Swarm.Util.Location+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" @@ -131,7 +151,12 @@           -- quitGame function would have already halted the app).           NoMenu -> const halt           MainMenu l -> handleMainMenuEvent l-          NewGameMenu l -> handleNewGameMenuEvent 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))@@ -146,12 +171,12 @@       Just x0 -> case x0 of         NewGame -> do           cheat <- use $ uiState . uiCheatMode-          ss <- use $ gameState . scenarios+          ss <- use $ runtimeState . scenarios           uiState . uiMenu .= NewGameMenu (NE.fromList [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 $ gameState . scenarios+          ss <- use $ runtimeState . scenarios           let tutorialCollection = getTutorials ss               topMenu =                 BL.listFindBy@@ -186,7 +211,7 @@ getTutorials :: ScenarioCollection -> ScenarioCollection getTutorials sc = case M.lookup tutorialsDirname (scMap sc) of   Just (SICollection _ c) -> c-  _ -> error "No tutorials exist!"+  _ -> error $ "No tutorials exist: " ++ show sc  -- | If we are in a New Game menu, advance the menu to the next item in order. --@@ -220,7 +245,10 @@  where   returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages) -handleNewGameMenuEvent :: NonEmpty (BL.List Name ScenarioItem) -> BrickEvent Name AppEvent -> EventM Name AppState ()+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@@ -229,6 +257,8 @@       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@@ -236,6 +266,10 @@     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@@ -255,15 +289,21 @@   s <- get   mt <- preuse $ uiState . uiModal . _Just . modalType   let isRunning = maybe True isRunningModal mt+  let isPaused = s ^. gameState . paused+  let isCreative = s ^. gameState . creativeMode+  let hasDebug = fromMaybe isCreative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug   case ev of-    AppEvent Frame-      | s ^. gameState . paused -> continueWithoutRedraw-      | otherwise -> runFrameUI+    AppEvent ae -> case ae of+      Frame+        | s ^. gameState . paused -> continueWithoutRedraw+        | otherwise -> runFrameUI+      Web (RunWebCode c) -> runBaseWebCode c+      _ -> continueWithoutRedraw     -- ctrl-q works everywhere     ControlChar 'q' ->       case s ^. gameState . winCondition of-        WinConditions (Won _) _ -> toggleModal WinModal-        WinConditions (Unwinnable _) _ -> toggleModal LoseModal+        WinConditions (Won _) _ -> toggleModal $ ScenarioEndModal WinModal+        WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal         _ -> toggleModal QuitModal     VtyEvent (V.EvResize _ _) -> invalidateCacheEntry WorldCache     Key V.KEsc@@ -287,10 +327,12 @@     FKey 5 | not (null (s ^. gameState . messageNotifications . notificationsContent)) -> do       toggleModal MessagesModal       gameState . lastSeenMessageTime .= s ^. gameState . 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@@ -301,6 +343,12 @@         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 . gameStep .= RobotStep SBefore+        else zoomGameState finishGameTick >> void updateUI     -- pausing and stepping     ControlChar 'p' | isRunning -> safeTogglePause     ControlChar 'o' | isRunning -> do@@ -318,18 +366,47 @@     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 . 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)-          uiState . uiWorldCursor .= mouseCoordsM+          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.@@ -340,6 +417,7 @@         InventoryListItem _ -> Just RobotPanel         InfoViewport -> Just InfoPanel         REPLInput -> Just REPLPanel+        WorldEditorPanelControl _ -> Just WorldEditorPanel         _ -> Nothing       case n of         FocusablePanel x -> setFocus x@@ -351,23 +429,11 @@         Just (FocusablePanel x) -> ($ ev) $ case x of           REPLPanel -> handleREPLEvent           WorldPanel -> handleWorldEvent+          WorldEditorPanel -> EC.handleWorldEditorPanelEvent           RobotPanel -> handleRobotPanelEvent           InfoPanel -> handleInfoPanelEvent infoScroll         _ -> continueWithoutRedraw -mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe 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))-      let regionStart = W.unCoords (fst region)-          mouseLoc' = bimap fromIntegral fromIntegral mouseLoc-          mx = snd mouseLoc' + fst regionStart-          my = fst mouseLoc' + snd regionStart-       in pure . Just $ W.Coords (mx, my)- -- | 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@@ -378,7 +444,9 @@ safeTogglePause = do   curTime <- liftIO $ getTime Monotonic   uiState . lastFrameTime .= curTime-  gameState . runStatus %= toggleRunStatus+  uiState . uiShowDebug .= False+  p <- gameState . runStatus Lens.<%= toggleRunStatus+  when (p == Running) $ zoomGameState finishGameTick  -- | Only unpause the game if leaving autopaused modal. --@@ -411,6 +479,10 @@     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@@ -419,47 +491,93 @@             Just (GoalWidgets w) -> case w of               ObjectivesList -> do                 lw <- use $ uiState . uiGoal . listWidget-                newList <- refreshList lw+                newList <- refreshGoalList lw                 uiState . uiGoal . listWidget .= newList               GoalSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev)             _ -> handleInfoPanelEvent modalScroll (VtyEvent ev)       _ -> handleInfoPanelEvent modalScroll (VtyEvent ev)    where-    refreshList lw = nestEventM' lw $ handleListEventWithSeparators ev isHeader+    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 . initiallyRunCode+  t <- liftIO getZonedTime+  wc <- use $ gameState . winCondition+  let won = case wc of+        WinConditions (Won _) _ -> True+        _ -> False+  ts <- use $ gameState . 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-    -- the path should be normalized and good to search in scenario collection-    mp' <- use $ gameState . currentScenarioPath-    case mp' of+    getNormalizedCurrentScenarioPath >>= \case       Nothing -> return ()-      Just p' -> do-        gs <- use $ gameState . scenarios-        p <- liftIO $ normalizeScenarioPath gs p'-        t <- liftIO getZonedTime-        wc <- use $ gameState . winCondition-        let won = case wc of-              WinConditions (Won _) _ -> True-              _ -> False-        ts <- use $ gameState . ticks-        let currentScenarioInfo :: Traversal' AppState ScenarioInfo-            currentScenarioInfo = gameState . scenarios . scenarioItemByPath p . _SISingle . _2-        currentScenarioInfo %= updateScenarioInfoOnQuit 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+      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@@ -467,7 +585,7 @@         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 $ gameState . scenarios+        sc <- use $ runtimeState . scenarios         forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=)  -- | Quit a game.@@ -593,7 +711,8 @@   a <- use (uiState . accumulatedTime)   t <- use (uiState . frameTickCount) -  -- Is there still time left?  Or have we hit the cap on ticks per frame?+  -- 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!@@ -608,11 +727,12 @@ 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 ()+zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (Fused.LiftC IO) a -> m a zoomGameState f = do   gs <- use gameState-  gs' <- liftIO (Fused.runM (Fused.execState gs f))+  (gs', a) <- liftIO (Fused.runM (Fused.runState gs f))   gameState .= gs'+  return a  updateAchievements :: EventM Name AppState () updateAchievements = do@@ -636,8 +756,8 @@ --   etc.). runGameTick :: EventM Name AppState () runGameTick = do-  zoomGameState gameTick-  updateAchievements+  ticked <- zoomGameState gameTick+  when ticked updateAchievements  -- | Update the UI.  This function is used after running the --   game for some number of ticks.@@ -650,22 +770,31 @@   g <- use gameState   when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache -  -- Check if the inventory list needs to be updated.-  listRobotHash <- fmap fst <$> use (uiState . uiInventory)   -- 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-  -- The hash of the focused robot (if any) +  -- Check if the inventory list needs to be updated.   shouldUpdate <- use (uiState . uiInventoryShouldUpdate)-  -- If the hashes don't match (either because which robot (or-  -- whether any robot) is focused changed, or the focused robot's-  -- inventory changed), regenerate the list.++  -- 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 . 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 listRobotHash /= focusedRobotHash || shouldUpdate+    if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate       then do-        Brick.zoom uiState $ populateInventoryList fr+        Brick.zoom uiState $ populateInventoryList (if tooFar then Nothing else fr)         (uiState . uiInventoryShouldUpdate) .= False         pure True       else pure False@@ -746,13 +875,19 @@    goalOrWinUpdated <- doGoalUpdates -  let redraw = g ^. needsRedraw || inventoryUpdated || replUpdated || logUpdated || infoPanelUpdated || goalOrWinUpdated+  let redraw =+        g ^. needsRedraw+          || inventoryUpdated+          || replUpdated+          || logUpdated+          || infoPanelUpdated+          || 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 precendence if the player+-- 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@@ -776,14 +911,14 @@     WinConditions (Unwinnable False) x -> do       -- This clears the "flag" that the Lose dialog needs to pop up       gameState . winCondition .= WinConditions (Unwinnable True) x-      openModal LoseModal-+      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 WinModal-+      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@@ -794,7 +929,7 @@       return True     WinConditions _ oc -> do       let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc-          -- The "uiGoal" field is intialized with empty members, so we know that+          -- 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)@@ -818,7 +953,8 @@          -- 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+        uiState+          . uiGoal           .= GoalDisplay             newGoalTracking             (GR.makeListWidget newGoalTracking)@@ -828,21 +964,12 @@         -- automatically popped up.         gameState . announcementQueue .= mempty -        openModal GoalModal+        hideGoals <- use $ uiState . uiHideGoals+        unless hideGoals $+          openModal GoalModal        return goalWasUpdated --- | Make sure all tiles covering the visible part of the world are---   loaded.-loadVisibleRegion :: EventM Name AppState ()-loadVisibleRegion = do-  mext <- lookupExtent WorldExtent-  case mext of-    Nothing -> return ()-    Just (Extent _ _ size) -> do-      gs <- use gameState-      gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size))- -- | Strips top-level `cmd` from type (in case of REPL evaluation), --   and returns a boolean to indicate if it happened stripCmd :: Polytype -> Polytype@@ -870,15 +997,59 @@       controlMode = repl ^. replControlMode       uinput = repl ^. 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-        if T.null uinput-          then uiState . uiREPL . replControlMode %= cycleEnum-          else uiState . uiError ?= "Please clear the REPL first."+        curMode <- use $ uiState . uiREPL . replControlMode+        case curMode of+          Piloting -> uiState . uiREPL . replControlMode .= Typing+          _ ->+            if T.null uinput+              then uiState . uiREPL . replControlMode .= Piloting+              else uiState . uiError ?= "Please clear the REPL first."+    MetaChar 'k' -> do+      when (isJust (s ^. gameState . 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 . 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 . 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@@ -894,9 +1065,11 @@   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@@ -909,52 +1082,64 @@       & replPromptText .~ nt       & replPromptType .~ CmdPrompt [] +runBaseWebCode :: (MonadState AppState m) => T.Text -> m ()+runBaseWebCode uinput = do+  s <- get+  let topCtx = topContext s+  unless (s ^. gameState . replWorking) $+    runBaseCode topCtx uinput++runBaseCode :: (MonadState AppState m) => RobotContext -> T.Text -> m ()+runBaseCode topCtx uinput =+  case processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput of+    Right mt -> do+      uiState %= resetREPL "" (CmdPrompt [])+      uiState . uiREPL . replHistory %= addREPLItem (REPLEntry uinput)+      uiState . uiREPL . replHistory . replHasExecutedManualInput .= True+      runBaseTerm topCtx mt+    Left err -> do+      uiState . uiError ?= 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 . 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-  ControlChar 'c' -> do-    gameState . baseRobot . machine %= cancel-    uiState . uiREPL . replPromptType .= CmdPrompt []-    uiState . uiREPL . replPromptText .= ""   Key V.KEnter -> do     s <- get     let topCtx = topContext s         repl = s ^. uiState . uiREPL         uinput = repl ^. replPromptText -        -- 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 . 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))-     if not $ s ^. gameState . replWorking       then case repl ^. replPromptType of-        CmdPrompt _ ->-          case processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput of-            Right mt -> do-              uiState %= resetREPL "" (CmdPrompt [])-              uiState . uiREPL . replHistory %= addREPLItem (REPLEntry uinput)-              modify $ maybe id startBaseProgram mt-            Left err -> uiState . uiError ?= err+        CmdPrompt _ -> runBaseCode topCtx uinput         SearchPrompt hist ->           case lastEntry uinput hist of             Nothing -> uiState %= resetREPL "" (CmdPrompt [])@@ -1117,16 +1302,19 @@ worldScrollDist :: Int32 worldScrollDist = 8 -onlyCreative :: MonadState AppState m => m () -> m ()+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 ()--- scrolling the world view in Creative mode handleWorldEvent = \case-  Key k | k `elem` moveKeys -> onlyCreative $ scrollView (.+^ (worldScrollDist *^ keyToDir k))+  Key k+    | k `elem` moveKeys -> do+        c <- use $ gameState . creativeMode+        s <- use $ gameState . worldScrollable+        when (c || s) $ scrollView (.+^ (worldScrollDist *^ keyToDir k))   CharKey 'c' -> do     invalidateCacheEntry WorldCache     gameState . viewCenterRule .= VCRobot 0@@ -1154,7 +1342,7 @@   -- 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 update+  gameState %= modifyViewCenter (fmap update)  -- | Convert a directional key into a direction. keyToDir :: V.Key -> Heading@@ -1178,29 +1366,70 @@  -- | Handle user input events in the robot panel. handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleRobotPanelEvent = \case-  (Key V.KEnter) ->-    gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal-  (CharKey 'm') ->-    gets focusedEntity >>= maybe continueWithoutRedraw makeEntity-  (CharKey '0') -> do+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 . uiShowZero %= not-  (CharKey ';') -> do+    uiState . uiInventorySearch .= Nothing+  -- Enter: return to regular inventory mode, and pop out the selected item+  Key V.KEnter -> do     uiState . uiInventoryShouldUpdate .= True-    uiState . uiInventorySort %= cycleSortOrder-  (CharKey ':') -> do+    uiState . uiInventorySearch .= Nothing+    gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal+  -- Any old character: append to the current search string+  CharKey c -> do     uiState . uiInventoryShouldUpdate .= True-    uiState . uiInventorySort %= cycleSortDirection-  (VtyEvent ev) -> do-    -- This does not work we want to skip redrawing in the no-list case-    -- Brick.zoom (uiState . uiInventory . _Just . _2) (handleListEventWithSeparators ev (is _Separator))-    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'+    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
src/Swarm/TUI/Controller/Util.hs view
@@ -1,13 +1,19 @@ {-# 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 (unless)+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)@@ -27,6 +33,9 @@ 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) []) @@ -35,6 +44,12 @@   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@@ -51,3 +66,31 @@  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 (over both fromIntegral size)+    gameState . 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))+      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)
+ src/Swarm/TUI/Editor/Controller.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedStrings #-}++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.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 ^. isWorldEditorEnabled+    let getSelected x = snd <$> BL.listSelectedElement x+        maybeTerrainType = getSelected $ worldEditor ^. terrainList+        maybeEntityPaint = getSelected $ worldEditor ^. entityPaintList+    -- TODO (#1151): Use hoistMaybe when available+    terrain <- MaybeT . pure $ maybeTerrainType+    mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc+    uiState . uiWorldEditor . 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 ^. isWorldEditorEnabled+    mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc+    uiState . uiWorldEditor . 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 ^. isWorldEditorEnabled) $ do+    w <- use $ gameState . multiWorld+    let setTerrainPaint coords = do+          let (terrain, maybeElementPaint) =+                EU.getContentAt+                  worldEditor+                  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 . multiWorld+  let mapCellGrid = EU.getEditedMapRectangle worldEditor maybeBounds w++  let fp = worldEditor ^. outputFilePath+  maybeScenarioPair <- use $ uiState . scenarioRef+  liftIO $ Y.encodeFile fp $ constructScenario (fst <$> maybeScenarioPair) mapCellGrid++  uiState . uiWorldEditor . lastWorldEditorMessage .= Just "Saved."
+ src/Swarm/TUI/Editor/Json.hs view
@@ -0,0 +1,20 @@+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++data SkeletonScenario = SkeletonScenario+  { version :: Int+  , name :: Text+  , description :: Text+  , creative :: Bool+  , entities :: [Entity]+  , world :: WorldDescriptionPaint+  , robots :: [String]+  }+  deriving (Generic)++instance ToJSON SkeletonScenario
+ src/Swarm/TUI/Editor/Masking.hs view
@@ -0,0 +1,31 @@+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
+ src/Swarm/TUI/Editor/Model.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++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 -> 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 WorldEditor n = WorldEditor+  { _isWorldEditorEnabled :: Bool+  , _terrainList :: BL.List n TerrainType+  , _entityPaintList :: BL.List n EntityFacade+  -- ^ This field has deferred initialization; it gets populated when a game+  -- is initialized.+  , _paintedTerrain :: M.Map W.Coords (TerrainWith EntityFacade)+  , _editingBounds :: MapEditingBounds+  , _editorFocusRing :: FocusRing n+  , _outputFilePath :: FilePath+  , _lastWorldEditorMessage :: Maybe String+  }++makeLenses ''WorldEditor++initialWorldEditor :: TimeSpec -> WorldEditor Name+initialWorldEditor ts =+  WorldEditor+    False+    (BL.list TerrainList (V.fromList listEnums) 1)+    (BL.list EntityPaintList (V.fromList []) 1)+    mempty+    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
+ src/Swarm/TUI/Editor/Palette.hs view
@@ -0,0 +1,146 @@+{-# 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 (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.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 "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
+ src/Swarm/TUI/Editor/Util.hs view
@@ -0,0 +1,122 @@+module Swarm.TUI.Editor.Util where++import Control.Applicative ((<|>))+import Control.Lens hiding (Const, from)+import Control.Monad (guard)+import Data.Int (Int32)+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.TUI.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 ::+  WorldEditor Name ->+  W.MultiWorld Int Entity ->+  Cosmic W.Coords ->+  (TerrainType, Maybe EntityPaint)+getContentAt editor 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 $ editor ^. isWorldEditorEnabled+    Map.lookup (coords ^. planar) pm++  pm = editor ^. paintedTerrain++  entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride+  underlyingCellEntity = W.lookupCosmicEntity coords w+  underlyingCellTerrain = W.lookupCosmicTerrain coords w++getTerrainAt ::+  WorldEditor Name ->+  W.MultiWorld Int Entity ->+  Cosmic W.Coords ->+  TerrainType+getTerrainAt editor w coords =+  fst $ getContentAt 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 ::+  WorldEditor Name ->+  Maybe (Cosmic W.BoundsRectangle) ->+  W.MultiWorld Int Entity ->+  [[CellPaintDisplay]]+getEditedMapRectangle _ Nothing _ = []+getEditedMapRectangle worldEditor (Just (Cosmic subworldName coords)) w =+  map renderRow [yTop .. yBottom]+ where+  (W.Coords (yTop, xLeft), W.Coords (yBottom, xRight)) = coords++  getContent = getContentAt worldEditor w . Cosmic subworldName++  drawCell :: Int32 -> Int32 -> CellPaintDisplay+  drawCell rowIndex colIndex =+    Cell+      terrain+      (toFacade <$> maybeToErasable erasableEntity)+      []+   where+    (terrain, erasableEntity) = getContent $ W.Coords (rowIndex, colIndex)++  renderRow rowIndex = map (drawCell rowIndex) [xLeft .. xRight]
+ src/Swarm/TUI/Editor/View.hs view
@@ -0,0 +1,160 @@+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.Attr+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.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 ^. 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
src/Swarm/TUI/Inventory/Sorting.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.Inventory.Sorting (   InventorySortOptions (..),   InventorySortDirection (..),
+ src/Swarm/TUI/Launch/Controller.hs view
@@ -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.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++-- | Split this 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
+ src/Swarm/TUI/Launch/Model.hs view
@@ -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
+ src/Swarm/TUI/Launch/Prep.hs view
@@ -0,0 +1,130 @@+{-# 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 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 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 FileBrowser widget.+-- * We re-instantiate the 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 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
+ src/Swarm/TUI/Launch/View.hs view
@@ -0,0 +1,185 @@+{-# 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.Attr+import Swarm.TUI.Launch.Model+import Swarm.TUI.Launch.Prep+import Swarm.TUI.Model.Name+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 "<none>"++  fileEntryWidget = case initialCode launchParams of+    Left _ -> str "<invalid>"+    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+        ]
src/Swarm/TUI/List.hs view
@@ -1,8 +1,4 @@ -- |--- Module      :  Swarm.TUI.List--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A special modified version of 'Brick.Widgets.List.handleListEvent'@@ -11,92 +7,28 @@  import Brick (EventM) import Brick.Widgets.List qualified as BL-import Control.Lens (set, (&), (^.))-import Control.Monad.State.Strict (modify)-import Data.Foldable (toList)-import Data.List (find)+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) =>+  (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 =-  case e of-    V.EvKey V.KUp [] -> modify backward-    V.EvKey (V.KChar 'k') [] -> modify backward-    V.EvKey V.KDown [] -> modify forward-    V.EvKey (V.KChar 'j') [] -> modify forward-    V.EvKey V.KHome [] ->-      modify $ listFindByStrategy fwdInclusive isItem . BL.listMoveToBeginning-    V.EvKey V.KEnd [] ->-      modify $ listFindByStrategy bwdInclusive isItem . BL.listMoveToEnd-    V.EvKey V.KPageDown [] -> do-      BL.listMovePageDown-      modify $ listFindByStrategy bwdInclusive isItem-    V.EvKey V.KPageUp [] -> do-      BL.listMovePageUp-      modify $ listFindByStrategy fwdInclusive isItem-    _ -> return ()+  listSkip isSep movement  where-  isItem = not . isSep-  backward = listFindByStrategy bwdExclusive isItem-  forward = listFindByStrategy fwdExclusive isItem---- | Which direction to search: forward or backward from the current location.-data FindDir = FindFwd | FindBwd deriving (Eq, Ord, Show, Enum)---- | Should we include or exclude the current location in the search?-data FindStart = IncludeCurrent | ExcludeCurrent deriving (Eq, Ord, Show, Enum)---- | A 'FindStrategy' is a pair of a 'FindDir' and a 'FindStart'.-data FindStrategy = FindStrategy FindDir FindStart---- | Some convenient synonyms for various 'FindStrategy' values.-fwdInclusive, fwdExclusive, bwdInclusive, bwdExclusive :: FindStrategy-fwdInclusive = FindStrategy FindFwd IncludeCurrent-fwdExclusive = FindStrategy FindFwd ExcludeCurrent-bwdInclusive = FindStrategy FindBwd IncludeCurrent-bwdExclusive = FindStrategy FindBwd ExcludeCurrent---- | Starting from the currently selected element, attempt to find and---   select the next element matching the predicate. How the search---   proceeds depends on the 'FindStrategy': the 'FindDir' says---   whether to search forward or backward from the selected element,---   and the 'FindStart' says whether the currently selected element---   should be included in the search or not.-listFindByStrategy ::-  (Foldable t, BL.Splittable t) =>-  FindStrategy ->-  (e -> Bool) ->-  BL.GenericList n t e ->-  BL.GenericList n t e-listFindByStrategy (FindStrategy dir cur) test l =-  -- Figure out what index to split on.  We will call splitAt on-  -- (current selected index + adj).-  let adj =-        -- If we're search forward, split on current index; if-        -- finding backward, split on current + 1 (so that the-        -- left-hand split will include the current index).-        case dir of FindFwd -> 0; FindBwd -> 1-          -- ... but if we're excluding the current index, swap that, so-          -- the current index will be excluded rather than included in-          -- the part of the split we're going to look at.-          & case cur of IncludeCurrent -> id; ExcludeCurrent -> (1 -)--      -- Split at the index we computed.-      start = maybe 0 (+ adj) (l ^. BL.listSelectedL)-      (h, t) = BL.splitAt start (l ^. BL.listElementsL)--      -- Now look at either the right-hand split if searching-      -- forward, or the reversed left-hand split if searching-      -- backward.-      headResult = find (test . snd) . reverse . zip [0 ..] . toList $ h-      tailResult = find (test . snd) . zip [start ..] . toList $ t-      result = case dir of FindFwd -> tailResult; FindBwd -> headResult-   in maybe id (set BL.listSelectedL . Just . fst) result l+  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
src/Swarm/TUI/Model.hs view
@@ -5,10 +5,6 @@ {-# LANGUAGE ViewPatterns #-}  -- |--- Module      :  Swarm.TUI.Model--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Application state for the @brick@-based Swarm TUI.@@ -16,11 +12,13 @@   -- * Custom UI label types   -- $uilabel   AppEvent (..),+  WebCommand (..),   FocusablePanel (..),   Name (..),    -- * Menus and dialogs   ModalType (..),+  ScenarioOutcome (..),   Button (..),   ButtonAction (..),   Modal (..),@@ -86,7 +84,17 @@   webPort,   upstreamRelease,   eventLog,+  worlds,+  scenarios,+  stdEntityMap,+  stdRecipes,+  appData,+  stdAdjList,+  stdNameList,++  -- ** Utility   logEvent,+  mkGameStateConfig,    -- * App state   AppState (AppState),@@ -96,6 +104,7 @@    -- ** Initialization   AppOpts (..),+  defaultAppOpts,   Seed,    -- *** Re-exported types used in options@@ -111,31 +120,46 @@  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.Except-import Control.Monad.State+import Control.Monad ((>=>))+import Control.Monad.State (MonadState)+import Data.Array (Array, listArray) import Data.List (findIndex) import Data.List.NonEmpty (NonEmpty (..))+import Data.Map (Map)+import Data.Map qualified as M import Data.Maybe (fromMaybe)+import Data.Sequence (Seq) import Data.Text (Text)+import Data.Text qualified as T (lines) import Data.Vector qualified as V import GitHash (GitInfo) import Graphics.Vty (ColorMode (..))-import Linear (zero) 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 (readAppData) import Swarm.Game.Robot-import Swarm.Game.ScenarioInfo (-  ScenarioInfoPair,-  _SISingle,- )+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.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 System.FilePath ((<.>))+import Text.Fuzzy qualified as Fuzzy+import Witch (into)  ------------------------------------------------------------ -- Custom UI label types@@ -144,12 +168,15 @@ -- $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.  At the moment, we only have one custom event, but it's---   very important: a separate thread sends 'Frame' events as fast as+--   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) @@ -167,18 +194,52 @@   { _webPort :: Maybe Port   , _upstreamRelease :: Either NewReleaseFailure String   , _eventLog :: Notifications LogEntry+  , _worlds :: WorldMap+  , _scenarios :: ScenarioCollection+  , _stdEntityMap :: EntityMap+  , _stdRecipes :: [Recipe Entity]+  , _appData :: Map Text Text+  , _stdAdjList :: Array Int Text+  , _stdNameList :: Array Int Text   } -initRuntimeState :: RuntimeState-initRuntimeState =-  RuntimeState-    { _webPort = Nothing-    , _upstreamRelease = Left (NoMainUpstreamRelease [])-    , _eventLog = mempty-    }+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 -makeLensesWith (lensRules & generateSignatures .~ False) ''RuntimeState+  let getDataLines f = case M.lookup f appDataMap of+        Nothing ->+          throwError $+            AssetNotLoaded (Data NameGeneration) (into @FilePath f <.> ".txt") (DoesNotExist File)+        Just content -> return . tail . T.lines $ content+  adjs <- getDataLines "adjectives"+  names <- getDataLines "names" +  return $+    RuntimeState+      { _webPort = Nothing+      , _upstreamRelease = Left (NoMainUpstreamRelease [])+      , _eventLog = mempty+      , _worlds = worlds+      , _scenarios = scenarios+      , _stdEntityMap = entities+      , _stdRecipes = recipes+      , _appData = appDataMap+      , _stdAdjList = listArray (0, length adjs - 1) adjs+      , _stdNameList = listArray (0, length names - 1) names+      }++makeLensesNoSigs ''RuntimeState+ -- | The port on which the HTTP debug service is running. webPort :: Lens' RuntimeState (Maybe Port) @@ -192,6 +253,36 @@ -- 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)++-- | List of words for use in building random robot names.+stdAdjList :: Lens' RuntimeState (Array Int Text)++-- | List of words for use in building random robot names.+stdNameList :: Lens' RuntimeState (Array Int Text)++--------------------------------------------------+-- Utility+ -- | Simply log to the runtime event log. logEvent :: LogSource -> (Text, RID) -> Text -> Notifications LogEntry -> Notifications LogEntry logEvent src (who, rid) msg el =@@ -199,8 +290,19 @@     & notificationsCount %~ succ     & notificationsContent %~ (l :)  where-  l = LogEntry 0 src who rid zero msg+  l = LogEntry (TickNumber 0) src who rid Omnipresent msg +-- | Create a 'GameStateConfig' record from the 'RuntimeState'.+mkGameStateConfig :: RuntimeState -> GameStateConfig+mkGameStateConfig rs =+  GameStateConfig+    { initAdjList = rs ^. stdAdjList+    , initNameList = rs ^. stdNameList+    , initEntities = rs ^. stdEntityMap+    , initRecipes = rs ^. stdRecipes+    , initWorldMap = rs ^. worlds+    }+ -- ---------------------------------------------------------------------------- --                                   APPSTATE                                -- -- ----------------------------------------------------------------------------@@ -219,7 +321,7 @@ -------------------------------------------------- -- Lenses for AppState -makeLensesWith (lensRules & generateSignatures .~ False) ''AppState+makeLensesNoSigs ''AppState  -- | The 'GameState' record. gameState :: Lens' AppState GameState@@ -257,19 +359,20 @@  -- | 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 :: (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 shouldDisplay+          . filter ((&&) <$> matchesSearch <*> shouldDisplay)           . elems        where         -- Display items if we have a positive number of them, or they@@ -282,8 +385,11 @@               && 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 "Inventory"))+        (r ^. robotInventory . to (itemList True mkInvEntry "Compendium"))           ++ (r ^. equippedDevices . to (itemList False mkInstEntry "Equipped devices"))        -- Attempt to keep the selected element steady.@@ -321,6 +427,8 @@   -- ^ 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@@ -330,6 +438,21 @@   , 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
− src/Swarm/TUI/Model/Achievement/Attainment.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Swarm.TUI.Model.Achievement.Attainment 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.TUI.Model.Achievement.Definitions--data Attainment = Attainment-  { _achievement :: CategorizedAchievement-  , _maybeScenarioPath :: Maybe FilePath-  -- ^ from which scenario was it obtained?-  , _obtainedAt :: ZonedTime-  }-  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 = tail -- drops leading underscore-    }
− src/Swarm/TUI/Model/Achievement/Definitions.hs 
@@ -1,89 +0,0 @@-module Swarm.TUI.Model.Achievement.Definitions where--import Data.Aeson-import Data.Text (Text)-import GHC.Generics (Generic)-import Swarm.Util--data ExpectedEffort-  = Trivial-  | Easy-  | Moderate-  | Gruelling-  deriving (Eq, Ord, Show, Bounded, Enum, Generic, FromJSON, ToJSON)--data Quotation = Quotation-  { attribution :: Text-  , content :: Text-  }-  deriving (Eq, Show, Generic, FromJSON, ToJSON)--data FlavorText-  = Freeform Text-  | FTQuotation Quotation-  deriving (Eq, Show, Generic, FromJSON, ToJSON)--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 :: Text-  -- ^ Precisely what must be done to obtain this achievement.-  , effort :: ExpectedEffort-  , 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)--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-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-  deriving (Eq, Ord, Show, Bounded, Enum, Generic)--instance FromJSON GameplayAchievement-instance ToJSON GameplayAchievement--listAchievements :: [CategorizedAchievement]-listAchievements =-  map GlobalAchievement listEnums-    <> map GameplayAchievement listEnums
− src/Swarm/TUI/Model/Achievement/Description.hs 
@@ -1,70 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Swarm.TUI.Model.Achievement.Description where--import Swarm.TUI.Model.Achievement.Definitions--describe :: CategorizedAchievement -> AchievementInfo-describe (GlobalAchievement CompletedSingleTutorial) =-  AchievementInfo-    "Welcome Freshmen"-    (Just $ Freeform "School is in session!")-    "Complete one of the tutorials."-    Easy-    False-describe (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-describe (GlobalAchievement LookedAtAboutScreen) =-  AchievementInfo-    "About time!"-    Nothing-    "View the About screen."-    Trivial-    True-describe (GameplayAchievement CraftedBitcoin) =-  -- Bitcoin is the deepest level of the recipes-  -- hierarchy.-  AchievementInfo-    "Master of Your Craft"-    Nothing-    "Make a Bitcoin"-    Moderate-    True-describe (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-describe (GameplayAchievement AttemptSelfDestructBase) =-  AchievementInfo-    "Call of the Void"-    (Just $ Freeform "What does that big red button do?")-    "Attempt to self-destruct your base."-    Easy-    True-describe (GameplayAchievement DestroyedBase) =-  AchievementInfo-    "That Could Have Gone Better"-    (Just $ Freeform "Boom.")-    "Actually destroy your base."-    Moderate-    True-describe (GameplayAchievement LoseScenario) =-  AchievementInfo-    "Silver Lining"-    (Just $ Freeform "Here's your consolation prize.")-    "Lose at a scenario."-    Easy-    True
− src/Swarm/TUI/Model/Achievement/Persistence.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Swarm.TUI.Model.Achievement.Persistence where--import Control.Arrow (left)-import Control.Carrier.Lift (sendIO)-import Control.Monad (forM, forM_)-import Data.Either (partitionEithers)-import Data.Yaml qualified as Y-import Swarm.TUI.Model.Achievement.Attainment-import Swarm.TUI.Model.Achievement.Definitions-import Swarm.TUI.Model.Failure-import Swarm.Util-import System.Directory (-  doesDirectoryExist,-  doesFileExist,-  listDirectory,- )-import System.FilePath ((</>))---- | Get path to swarm achievements, optionally creating necessary---   directories.-getSwarmAchievementsPath :: Bool -> IO FilePath-getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement"---- | Load saved info about achievements from XDG data directory.--- Returns a tuple of warnings and attained achievements.-loadAchievementsInfo ::-  IO ([SystemFailure], [Attainment])-loadAchievementsInfo = do-  savedAchievementsPath <- getSwarmAchievementsPath False-  doesParentExist <- doesDirectoryExist savedAchievementsPath-  if doesParentExist-    then do-      contents <- listDirectory savedAchievementsPath-      eithersList <- forM contents $ \p -> do-        let fullPath = savedAchievementsPath </> p-        isFile <- doesFileExist fullPath-        if isFile-          then do-            eitherDecodedFile <- sendIO (Y.decodeFileEither fullPath)-            return $ left (AssetNotLoaded Achievement p . CanNotParse) eitherDecodedFile-          else return . Left $ AssetNotLoaded Achievement p (EntryNot File)-      return $ partitionEithers eithersList-    else return ([AssetNotLoaded Achievement "." (DoesNotExist Directory)], [])---- | 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
− src/Swarm/TUI/Model/Failure.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- Module      :  Swarm.Game.Failure--- Copyright   :  Ondřej Šebek--- Maintainer  :  ondras98@icloud.com------ SPDX-License-Identifier: BSD-3-Clause------ A data type to represent system failures.------ These failures are often not fatal and serve--- to create common infrastructure for logging.-module Swarm.TUI.Model.Failure where--import Data.Char (toLower)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Yaml (ParseException, prettyPrintParseException)--data SystemFailure-  = AssetNotLoaded Asset FilePath LoadingFailure--data Asset = Achievement | Data | History | Save-  deriving (Eq, Show)--data Entry = Directory | File-  deriving (Eq, Show)--data LoadingFailure-  = DoesNotExist Entry-  | EntryNot Entry-  | CanNotParse ParseException--tShowLow :: Show a => a -> Text-tShowLow = T.pack . map toLower . show--tShow :: Show a => a -> Text-tShow = T.pack . show--prettyLoadingFailure :: LoadingFailure -> Text-prettyLoadingFailure = \case-  DoesNotExist e -> "The " <> tShowLow e <> " is missing!"-  EntryNot e -> "The entry is not a " <> tShowLow e <> "!"-  CanNotParse p -> "Parse failure:\n" <> T.pack (indent 8 $ prettyPrintParseException p)- where-  indent n = unlines . map (replicate n ' ' ++) . lines--prettyFailure :: SystemFailure -> Text-prettyFailure = \case-  AssetNotLoaded a fp l -> T.unwords ["Failed to acquire", tShowLow a, tShow fp] <> ": " <> prettyLoadingFailure l
+ src/Swarm/TUI/Model/Goal.hs view
@@ -0,0 +1,121 @@+{-# 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.noSamples++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
src/Swarm/TUI/Model/Menu.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.Model.Menu where  import Brick.Widgets.Dialog (Dialog)@@ -14,6 +16,7 @@ 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,@@ -24,7 +27,6 @@   scenarioCollectionToList,  ) import Swarm.Game.State-import Swarm.TUI.Model.Achievement.Definitions import Swarm.TUI.Model.Name import Swarm.Util import System.FilePath (dropTrailingPathSeparator, splitPath, takeFileName)@@ -34,14 +36,18 @@ -- Menus and dialogs ------------------------------------------------------------ +data ScenarioOutcome = WinModal | LoseModal+  deriving (Show)+ data ModalType   = HelpModal   | RecipesModal   | CommandsModal   | MessagesModal+  | EntityPaletteModal+  | TerrainPaletteModal   | RobotsModal-  | WinModal-  | LoseModal+  | ScenarioEndModal ScenarioOutcome   | QuitModal   | KeepPlayingModal   | DescriptionModal Entity@@ -72,9 +78,10 @@   deriving (Eq, Ord, Show, Read, Bounded, Enum)  data Menu-  = NoMenu -- We started playing directly from command line, no menu to show+  = -- | 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+  | -- | 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.@@ -100,13 +107,17 @@ mkNewGameMenu :: Bool -> ScenarioCollection -> FilePath -> Maybe Menu mkNewGameMenu cheat sc path = NewGameMenu . NE.fromList <$> go (Just sc) (splitPath path) []  where-  go :: Maybe ScenarioCollection -> [FilePath] -> [BL.List Name ScenarioItem] -> Maybe [BL.List Name ScenarioItem]+  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 (SISingle (_, ScenarioInfo pth _)) = takeFileName pth == thing     hasName (SICollection nm _) = nm == into @Text (dropTrailingPathSeparator thing)      lst = BL.listFindBy hasName (mkScenarioList cheat curSC)
src/Swarm/TUI/Model/Name.hs view
@@ -1,16 +1,41 @@+-- |+-- SPDX-License-Identifier: BSD-3-Clause 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@@ -29,12 +54,24 @@ --   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 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@@ -44,6 +81,8 @@     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.
src/Swarm/TUI/Model/Repl.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.Model.Repl (   -- ** REPL   REPLHistItem (..),@@ -13,6 +15,7 @@   REPLHistory,   replIndex,   replLength,+  replHasExecutedManualInput,   replSeq,   newREPLHistory,   addREPLItem,@@ -48,7 +51,8 @@  import Brick.Widgets.Edit (Editor, applyEdit, editorText, getEditContents) import Control.Applicative (Applicative (liftA2))-import Control.Lens hiding (from, (<.>))+import Control.Lens hiding (from, (.=), (<.>))+import Data.Aeson (ToJSON, object, toJSON, (.=)) import Data.Foldable (toList) import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq)@@ -56,8 +60,12 @@ 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@@ -71,6 +79,14 @@     REPLOutput Text   deriving (Eq, Ord, Show, Read) +instance ToSample REPLHistItem where+  toSamples _ = SD.noSamples++instance ToJSON REPLHistItem where+  toJSON e = case e of+    REPLEntry x -> object ["in" .= x]+    REPLOutput x -> object ["out" .= x]+ -- | Useful helper function to only get user input text. getREPLEntry :: REPLHistItem -> Maybe Text getREPLEntry = \case@@ -95,9 +111,11 @@   { _replSeq :: Seq REPLHistItem   , _replIndex :: Int   , _replStart :: Int+  , _replHasExecutedManualInput :: Bool   }+  deriving (Show) -makeLensesWith (lensRules & generateSignatures .~ False) ''REPLHistory+makeLensesNoSigs ''REPLHistory  -- | Sequence of REPL inputs and outputs, oldest entry is leftmost. replSeq :: Lens' REPLHistory (Seq REPLHistItem)@@ -111,6 +129,25 @@ -- It will be set on load and reset on save (happens during exit). replStart :: Lens' REPLHistory Int +-- | 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 input not commands 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 here:+-- https://github.com/swarm-game/swarm/pull/974#discussion_r1112380380+replHasExecutedManualInput :: Lens' REPLHistory Bool+ -- | Create new REPL history (i.e. from loaded history file lines). newREPLHistory :: [REPLHistItem] -> REPLHistory newREPLHistory xs =@@ -119,6 +156,7 @@         { _replSeq = s         , _replStart = length s         , _replIndex = length s+        , _replHasExecutedManualInput = False         }  -- | Point the start of REPL history after current last line. See 'replStart'.@@ -206,10 +244,15 @@ defaultPrompt :: REPLPrompt defaultPrompt = CmdPrompt [] +-- | What is being done with user input to the REPL panel? data ReplControlMode-  = Piloting-  | Typing-  deriving (Enum, Bounded, Eq)+  = -- | 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@@ -229,9 +272,18 @@   gotoEnd = if null ls then id else TZ.moveCursor pos  initREPLState :: REPLHistory -> REPLState-initREPLState = REPLState defaultPrompt (newREPLEditor "") True "" Nothing Typing+initREPLState hist =+  REPLState+    { _replPromptType = defaultPrompt+    , _replPromptEditor = newREPLEditor ""+    , _replValid = True+    , _replLast = ""+    , _replType = Nothing+    , _replControlMode = Typing+    , _replHistory = hist+    } -makeLensesWith (lensRules & generateSignatures .~ False) ''REPLState+makeLensesNoSigs ''REPLState  -- | The way we interpret text typed by the player in the REPL prompt. replPromptType :: Lens' REPLState REPLPrompt@@ -258,7 +310,8 @@ --   This is used to restore the repl form after the user visited the history. replLast :: Lens' REPLState Text --- | Piloting or Typing mode+-- | 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
src/Swarm/TUI/Model/StateUpdate.hs view
@@ -1,9 +1,16 @@ {-# 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',@@ -11,69 +18,132 @@ ) 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.Except-import Control.Monad.State+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.Log (ErrorLevel (..), LogSource (ErrorTrace))-import Swarm.Game.Scenario (loadScenario, scenarioAttrs)-import Swarm.Game.Scenario.Objective.Presentation.Model (emptyGoalDisplay)+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 (-  ScenarioInfo (..),-  ScenarioInfoPair,-  ScenarioStatus (..),+  loadScenarioInfo,   normalizeScenarioPath,   scenarioItemByPath,-  scenarioPath,   scenarioSolution,-  scenarioStatus,   _SISingle,  ) import Swarm.Game.State+import Swarm.Language.Pretty (prettyText) import Swarm.TUI.Attr (swarmAttrMap)+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.Achievement.Attainment-import Swarm.TUI.Model.Achievement.Definitions-import Swarm.TUI.Model.Achievement.Persistence-import Swarm.TUI.Model.Failure (prettyFailure)+import Swarm.TUI.Model.Goal (emptyGoalDisplay) import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI import Swarm.TUI.View.CustomStyling (toAttrPair)+import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock --- | Initialize the 'AppState'.-initAppState :: AppOpts -> ExceptT Text IO AppState-initAppState AppOpts {..} = do-  let isRunningInitialProgram = isJust scriptToRun || autoPlay-      skipMenu = isJust userScenario || isRunningInitialProgram || isJust userSeed-  gs <- initGameState-  (warnings, ui) <- initUIState (not skipMenu) cheatMode-  let logWarning rs w = rs & eventLog %~ logEvent (ErrorTrace Error) ("UI Loading", -8) (prettyFailure w)-  let rs = List.foldl' logWarning initRuntimeState warnings-  case skipMenu of-    False -> return $ AppState gs ui rs+-- | 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 (ErrorTrace Error) ("UI Loading", -8) (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 ^. entityMap)+      (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap) (rs ^. worlds)+      maybeRunScript <- traverse parseCodeFile scriptToRun        let maybeAutoplay = do             guard autoPlay             soln <- scenario ^. scenarioSolution-            return $ SuggestedSolution soln-      let realToRun = maybeAutoplay <|> (ScriptPath <$> scriptToRun)+            return $ CodeToRun ScenarioSuggested soln+          codeToRun = maybeAutoplay <|> maybeRunScript -      execStateT-        (startGameWithSeed userSeed (scenario, ScenarioInfo path NotStarted NotStarted NotStarted) realToRun)-        (AppState gs ui rs)+      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 = startGameWithSeed Nothing+startGame siPair = startGameWithSeed siPair . LaunchParams (pure Nothing) . pure  -- | Re-initialize the game from the stored reference to the current scenario. --@@ -85,37 +155,60 @@ -- Since scenarios are stored as a Maybe in the UI state, we handle the Nothing -- case upstream so that the Scenario passed to this function definitely exists. restartGame :: (MonadIO m, MonadState AppState m) => Seed -> ScenarioInfoPair -> m ()-restartGame currentSeed siPair = startGameWithSeed (Just currentSeed) siPair Nothing+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) => Maybe Seed -> ScenarioInfoPair -> Maybe CodeToRun -> m ()-startGameWithSeed userSeed siPair@(_scene, si) toRun = do+startGameWithSeed ::+  (MonadIO m, MonadState AppState m) =>+  ScenarioInfoPair ->+  ValidatedLaunchParams ->+  m ()+startGameWithSeed siPair@(_scene, si) lp = do   t <- liftIO getZonedTime-  ss <- use $ gameState . scenarios+  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-  gameState . scenarios . scenarioItemByPath p . _SISingle . _2 . scenarioStatus .= InProgress t 0 0-  scenarioToAppState siPair userSeed toRun---- TODO: #516 do we need to keep an old entity map around???+ 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 ->-  Maybe Seed ->-  Maybe CodeToRun ->+  ValidatedLaunchParams ->   m ()-scenarioToAppState siPair@(scene, _) userSeed toRun = do-  withLensIO gameState $ scenarioToGameState scene userSeed toRun-  withLensIO uiState $ scenarioToUIState siPair+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-  withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m ()+  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@@ -138,21 +231,57 @@   liftIO $ saveAchievementsInfo $ M.elems newAchievements  -- | Modify the UI state appropriately when starting a new scenario.-scenarioToUIState :: ScenarioInfoPair -> UIState -> IO UIState-scenarioToUIState siPair u = do+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-      & lgTicksPerSecond .~ initLgTicksPerSecond       & 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 ^. 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
src/Swarm/TUI/Model/UI.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.Model.UI (   UIState (..),   GoalDisplay (..),@@ -11,16 +13,20 @@   uiPlaying,   uiCheatMode,   uiFocusRing,+  uiLaunchConfig,   uiWorldCursor,+  uiWorldEditor,   uiREPL,   uiInventory,   uiInventorySort,+  uiInventorySearch,   uiMoreInfoTop,   uiMoreInfoBot,   uiScrollToEnd,   uiError,   uiModal,   uiGoal,+  uiHideGoals,   uiAchievements,   lgTicksPerSecond,   lastFrameTime,@@ -30,7 +36,9 @@   frameTickCount,   lastInfoTime,   uiShowFPS,+  uiShowREPL,   uiShowZero,+  uiShowDebug,   uiShowRobots,   uiHideRobotsUntil,   uiInventoryShouldUpdate,@@ -38,11 +46,10 @@   uiFPS,   uiAttrMap,   scenarioRef,-  appData,    -- ** Initialization   initFocusRing,-  initLgTicksPerSecond,+  defaultInitLgTicksPerSecond,   initUIState, ) where @@ -50,28 +57,36 @@ 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 Control.Monad.Except 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.Scenario.Objective.Presentation.Model+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.Attr (swarmAttrMap)+import Swarm.TUI.Editor.Model import Swarm.TUI.Inventory.Sorting-import Swarm.TUI.Model.Achievement.Attainment-import Swarm.TUI.Model.Achievement.Definitions-import Swarm.TUI.Model.Achievement.Persistence-import Swarm.TUI.Model.Failure (SystemFailure)+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.Util+import Swarm.Util.Lens (makeLensesExcluding) import System.Clock  ------------------------------------------------------------@@ -85,19 +100,25 @@   , _uiPlaying :: Bool   , _uiCheatMode :: Bool   , _uiFocusRing :: FocusRing Name-  , _uiWorldCursor :: Maybe W.Coords+  , _uiLaunchConfig :: LaunchOptions+  , _uiWorldCursor :: Maybe (Cosmic W.Coords)+  , _uiWorldEditor :: WorldEditor Name   , _uiREPL :: REPLState   , _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry)   , _uiInventorySort :: InventorySortOptions+  , _uiInventorySearch :: Maybe Text   , _uiMoreInfoTop :: Bool   , _uiMoreInfoBot :: Bool   , _uiScrollToEnd :: Bool   , _uiError :: Maybe Text   , _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@@ -109,7 +130,6 @@   , _lastFrameTime :: TimeSpec   , _accumulatedTime :: TimeSpec   , _lastInfoTime :: TimeSpec-  , _appData :: Map Text Text   , _uiAttrMap :: AttrMap   , _scenarioRef :: Maybe ScenarioInfoPair   }@@ -117,14 +137,7 @@ -------------------------------------------------- -- Lenses for UIState -let exclude = ['_lgTicksPerSecond]- in makeLensesWith-      ( lensRules-          & generateSignatures .~ False-          & lensField . mapped . mapped %~ \fn n ->-            if n `elem` exclude then [] else fn n-      )-      ''UIState+makeLensesExcluding ['_lgTicksPerSecond] ''UIState  -- | The current menu state. uiMenu :: Lens' UIState Menu@@ -137,19 +150,28 @@ -- | 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 W.Coords)+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.@@ -177,15 +199,28 @@ --   has been displayed to the user initially. uiGoal :: Lens' UIState GoalDisplay +-- | When running with --autoplay, suppress the goal dialogs.+--+-- For developement, 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 @@ -248,65 +283,76 @@ --   See https://gafferongames.com/post/fix_your_timestep/ . accumulatedTime :: Lens' UIState TimeSpec --- | Free-form data loaded from the @data@ directory, for things like---   the logo, about page, tutorial story, etc.-appData :: Lens' UIState (Map Text Text)- -------------------------------------------------- -- 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.-initLgTicksPerSecond :: Int-initLgTicksPerSecond = 4 -- 2^4 = 16 ticks / second+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 :: Bool -> Bool -> ExceptT Text IO ([SystemFailure], UIState)-initUIState showMainMenu cheatMode = do-  historyT <- liftIO $ readFileMayT =<< getSwarmHistoryPath False-  appDataMap <- liftIO readAppData+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 <- liftIO $ getTime Monotonic-  (warnings, achievements) <- liftIO loadAchievementsInfo+  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           , _uiMoreInfoTop = False           , _uiMoreInfoBot = False           , _uiScrollToEnd = False           , _uiError = Nothing           , _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 = initLgTicksPerSecond+          , _lgTicksPerSecond = speedFactor           , _lastFrameTime = startTime           , _accumulatedTime = 0           , _lastInfoTime = 0           , _tickCount = 0           , _frameCount = 0           , _frameTickCount = 0-          , _appData = appDataMap           , _uiAttrMap = swarmAttrMap           , _scenarioRef = Nothing           }-  return (warnings, out)+  return out
src/Swarm/TUI/Panel.hs view
@@ -3,10 +3,6 @@ {-# LANGUAGE TemplateHaskell #-}  -- |--- Module      :  Swarm.TUI.Panel--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A small custom "panel widget" for use in the Swarm TUI. Panels draw
src/Swarm/TUI/View.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}  -- |--- Module      :  Swarm.TUI.View--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Code for drawing the TUI.@@ -14,7 +10,6 @@    -- * Dialog box   drawDialog,-  generateModal,   chooseCursor,    -- * Key hint menu@@ -41,13 +36,18 @@ import Brick hiding (Direction, Location) import Brick.Focus import Brick.Forms-import Brick.Widgets.Border (hBorder, hBorderWithLabel, joinableBorder, vBorder)+import Brick.Widgets.Border (+  hBorder,+  hBorderWithLabel,+  joinableBorder,+  vBorder,+ ) import Brick.Widgets.Center (center, centerLayer, hCenter) import Brick.Widgets.Dialog import Brick.Widgets.Edit (getEditContents, renderEditor) import Brick.Widgets.List qualified as BL import Brick.Widgets.Table qualified as BT-import Control.Lens hiding (Const, from)+import Control.Lens as Lens hiding (Const, from) import Control.Monad (guard) import Data.Array (range) import Data.Bits (shiftL, shiftR, (.&.))@@ -60,7 +60,7 @@ import Data.List.NonEmpty qualified as NE import Data.List.Split (chunksOf) import Data.Map qualified as M-import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)+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)@@ -68,42 +68,49 @@ import Data.Text qualified as T import Data.Time (NominalDiffTime, defaultTimeLocale, formatTime) import Linear-import Linear.Affine (Point) import Network.Wai.Handler.Warp (Port)-import Swarm.Game.CESK (CESK (..))+import Swarm.Constant+import Swarm.Game.CESK (CESK (..), TickNumber (..)) 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, scenarioDescription, scenarioName, scenarioObjectives)-import Swarm.Game.Scenario.Objective.Presentation.Model (goalsContent, hasAnythingToShow)-import Swarm.Game.Scenario.Objective.Presentation.Render qualified as GR+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 (..),-  ScenarioStatus (..),-  scenarioBestTicks,-  scenarioBestTime,   scenarioItemName,-  scenarioStatus,  ) import Swarm.Game.State+import Swarm.Game.Universe import Swarm.Game.World qualified as W-import Swarm.Language.Capability (constCaps)+import Swarm.Language.Capability (Capability (..), constCaps) import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax import Swarm.Language.Typecheck (inferConst) import Swarm.TUI.Attr 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.Repl+import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow)+import Swarm.TUI.Model.Repl (lastEntry) import Swarm.TUI.Model.UI import Swarm.TUI.Panel import Swarm.TUI.View.Achievement import Swarm.TUI.View.CellDisplay-import Swarm.TUI.View.Util+import Swarm.TUI.View.Objective qualified as GR+import Swarm.TUI.View.Util as VU import Swarm.Util-import Swarm.Util.Location import Swarm.Version (NewReleaseFailure (..)) import System.Clock (TimeSpec (..)) import Text.Printf@@ -120,10 +127,10 @@       -- 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]+      NewGameMenu stk -> drawNewGameMenuUI stk $ s ^. uiState . uiLaunchConfig       AchievementsMenu l -> [drawAchievementsMenuUI s l]       MessagesMenu -> [drawMainMessages s]-      AboutMenu -> [drawAboutMenuUI (s ^. uiState . appData . at "about")]+      AboutMenu -> [drawAboutMenuUI (s ^. runtimeState . appData . at "about")]  drawMainMessages :: AppState -> Widget Name drawMainMessages s = renderDialog dial . padBottom Max . scrollList $ drawLogs ls@@ -142,7 +149,7 @@         BL.renderList (const (hCenter . drawMainMenuEntry s)) True l     ]  where-  logo = s ^. uiState . appData . at "logo"+  logo = s ^. runtimeState . appData . at "logo"   version = s ^. runtimeState . upstreamRelease  newVersionWidget :: Either NewReleaseFailure String -> Maybe (Widget n)@@ -168,50 +175,52 @@   attrFor '▒' = dirtAttr   attrFor _ = defAttr -drawNewGameMenuUI :: NonEmpty (BL.List Name ScenarioItem) -> Widget Name-drawNewGameMenuUI (l :| ls) =-  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))-      ]+-- | 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 ^. scenarioBestTime of+  drawStatusInfo s si = case si ^. scenarioStatus of     NotStarted -> txt " ○ "-    InProgress {} -> case s ^. scenarioObjectives of+    Played _initialScript (Metric Attempted _) _ -> case s ^. scenarioObjectives of       [] -> withAttr cyanAttr $ txt " ◉ "       _ -> withAttr yellowAttr $ txt " ◎ "-    Complete {} -> withAttr greenAttr $ txt " ● "+    Played _initialScript (Metric Completed _) _ -> withAttr greenAttr $ txt " ● " +  describeStatus :: ScenarioStatus -> Widget n   describeStatus = \case-    NotStarted -> txt "none"-    InProgress _s e _t ->-      withAttr yellowAttr . vBox $-        [ txt "in progress"-        , txt $ "(played for " <> formatTimeDiff e <> ")"-        ]-    Complete _s e t ->-      withAttr greenAttr . vBox $-        [ txt $ "completed in " <> formatTimeDiff e-        , hBox-            [ txt "("-            , drawTime t True-            , txt " ticks)"-            ]-        ]--  formatTimeDiff :: NominalDiffTime -> Text-  formatTimeDiff = T.pack . formatTime defaultTimeLocale "%hh %Mm %Ss"+    NotStarted -> withAttr cyanAttr $ txt "not started"+    Played _initialScript pm _best -> describeProgress pm    breadcrumbs :: [BL.List Name ScenarioItem] -> Text   breadcrumbs =@@ -222,32 +231,128 @@    drawDescription :: ScenarioItem -> Widget Name   drawDescription (SICollection _ _) = txtWrap " "-  drawDescription (SISingle (s, si)) = do-    let oneBest = si ^. scenarioBestTime == si ^. scenarioBestTicks-    let bestRealTime = if oneBest then "best:" else "best real time:"-    let noSame = if oneBest then const Nothing else Just-    let lastText = let la = "last:" in padRight (Pad $ T.length bestRealTime - T.length la) (txt la)-    vBox . catMaybes $-      [ Just $ txtWrap (nonBlank (s ^. scenarioDescription))-      , padTop (Pad 1)-          . withAttr dimAttr-          . (txt "Author: " <+>)-          . txt-          <$> (s ^. scenarioAuthor)-      , Just $-          padTop (Pad 3) $-            padRight (Pad 1) (txt bestRealTime) <+> describeStatus (si ^. scenarioBestTime)-      , noSame $ -- hide best game time if it is same as best real time-          padTop (Pad 1) $-            txt "best game time: " <+> describeStatus (si ^. scenarioBestTicks)-      , Just $-          padTop (Pad 1) $-            padRight (Pad 1) lastText <+> describeStatus (si ^. scenarioStatus)+  drawDescription (SISingle (s, si)) =+    vBox+      [ txtWrap (nonBlank (s ^. scenarioDescription))+      , padTop (Pad 1) table       ]+   where+    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"@@ -280,7 +385,18 @@       hBox         [ hLimitPercent 25 $             vBox-              [ vLimitPercent 50 $ panel highlightAttr fr (FocusablePanel RobotPanel) plainBorder $ drawRobotPanel s+              [ vLimitPercent 50+                  $ panel+                    highlightAttr+                    fr+                    (FocusablePanel RobotPanel)+                    ( plainBorder+                        & bottomLabels . centerLabel+                          .~ fmap+                            (txt . (" Search: " <>) . (<> " "))+                            (s ^. uiState . uiInventorySearch)+                    )+                  $ drawRobotPanel s               , panel                   highlightAttr                   fr@@ -292,81 +408,100 @@                         .~ (if moreBot then Just (txt " · · · ") else Nothing)                   )                   $ drawInfoPanel s+              , hCenter+                  . clickable (FocusablePanel WorldEditorPanel)+                  . EV.drawWorldEditor fr+                  $ s ^. uiState               ]-        , vBox-            [ panel-                highlightAttr-                fr-                (FocusablePanel WorldPanel)-                ( plainBorder-                    & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s)-                    & topLabels . leftLabel ?~ drawModalMenu s-                    & addCursorPos-                    & addClock-                )-                (drawWorld (s ^. uiState . uiShowRobots) (s ^. gameState))-            , drawKeyMenu s-            , clickable (FocusablePanel REPLPanel) $-                panel-                  highlightAttr-                  fr-                  (FocusablePanel REPLPanel)-                  ( plainBorder-                      & topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiREPL . replType))-                  )-                  ( vLimit replHeight-                      . padBottom Max-                      . padLeftRight 1-                      $ drawREPL s-                  )-            ]+        , vBox rightPanel         ]   ]  where-  addCursorPos = case s ^. uiState . uiWorldCursor of-    Nothing -> id-    Just coord ->-      let worldCursorInfo = drawWorldCursorInfo (s ^. gameState) coord-       in bottomLabels . leftLabel ?~ padLeftRight 1 worldCursorInfo+  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) (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 ^. gameState)+  addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay (s ^. uiState . lgTicksPerSecond) $ s ^. gameState)   fr = s ^. uiState . uiFocusRing   moreTop = s ^. uiState . uiMoreInfoTop   moreBot = s ^. uiState . uiMoreInfoBot+  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+        )+        (drawWorld (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+              . padLeftRight 1+              $ drawREPL s+          )+    ] -drawWorldCursorInfo :: GameState -> W.Coords -> Widget Name-drawWorldCursorInfo g coords@(W.Coords (y, x)) =-  hBox $ tileMemberWidgets ++ [coordsWidget]+renderCoordsString :: Cosmic Location -> String+renderCoordsString (Cosmic sw coords) =+  unwords $ VU.locationToString coords : suffix  where-  coordsWidget =-    txt $-      T.unwords-        [ from $ show x-        , from $ show $ y * (-1)-        ]+  suffix = case sw of+    DefaultRootSubworld -> []+    SubworldName swName -> ["in", T.unpack swName] +drawWorldCursorInfo :: WorldEditor Name -> 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"]+    map (padRight $ Pad 1)+      . concat+      . reverse+      . zipWith f tileMembers+      $ ["at", "on", "with"]    where     f cell preposition = [renderDisplay cell, txt preposition] -  terrain = displayTerrainCell g coords-  entity = displayEntityCell g coords-  robot = displayRobotCell g coords+  terrain = displayTerrainCell worldEditor g cCoords+  entity = displayEntityCell worldEditor g 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 :: GameState -> Widget n-drawClockDisplay gs = hBox . intersperse (txt " ") $ catMaybes [clockWidget, pauseWidget]+drawClockDisplay :: Int -> GameState -> Widget n+drawClockDisplay lgTPS gs = hBox . intersperse (txt " ") $ catMaybes [clockWidget, pauseWidget]  where-  clockWidget = maybeDrawTime (gs ^. ticks) (gs ^. paused) gs+  clockWidget = maybeDrawTime (gs ^. ticks) (gs ^. paused || lgTPS < 3) gs   pauseWidget = guard (gs ^. paused) $> txt "(PAUSED)"  -- | Check whether the currently focused robot (if any) has a clock@@ -379,15 +514,15 @@     | otherwise -> False  -- | Format a ticks count as a hexadecimal clock.-drawTime :: Integer -> Bool -> Widget n-drawTime t showTicks =-  str . mconcat $-    [ printf "%x" (t `shiftR` 20)-    , ":"-    , printf "%02x" ((t `shiftR` 12) .&. ((1 `shiftL` 8) - 1))-    , ":"-    , printf "%02x" ((t `shiftR` 4) .&. ((1 `shiftL` 8) - 1))-    ]+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@@ -395,8 +530,8 @@ --   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 :: Integer -> Bool -> GameState -> Maybe (Widget n)-maybeDrawTime t showTicks gs = guard (clockEquipped gs) $> drawTime t showTicks+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@@ -409,7 +544,9 @@   rateInfo     | s ^. uiState . uiShowFPS =         [ txt " ("-        , str (printf "%0.1f" (s ^. uiState . uiTPF))+        , 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)"@@ -453,19 +590,25 @@   RecipesModal -> availableListWidget (s ^. gameState) RecipeList   CommandsModal -> commandsListWidget (s ^. gameState)   MessagesModal -> availableListWidget (s ^. gameState) MessageList-  WinModal -> padBottom (Pad 1) $ hCenter $ txt "Congratulations!"-  LoseModal ->+  ScenarioEndModal outcome ->     padBottom (Pad 1) $       vBox $         map           (hCenter . txt)-          [ "Condolences!"-          , "This scenario is no longer winnable."-          ]+          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 ["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  robotsListWidget :: AppState -> Widget Name robotsListWidget s = hCenter table@@ -515,11 +658,16 @@       | robot ^. robotLogUpdated = "x"       | otherwise = " " -    locWidget = hBox [worldCell, txt $ " " <> locStr]+    locWidget = hBox [worldCell, str $ " " <> locStr]      where-      rloc@(Location x y) = robot ^. robotLocation-      worldCell = drawLoc (s ^. uiState . uiShowRobots) g (W.locToCoords rloc)-      locStr = from (show x) <> " " <> from (show y)+      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"@@ -528,11 +676,11 @@         | otherwise -> withAttr greenAttr $ txt "idle"    basePos :: Point V2 Double-  basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation)+  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) basePos < 32+  isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation . planar) basePos < 32   robots :: [Robot]   robots =     filter (\robot -> debugging || (isRelevant robot && isNear robot))@@ -553,7 +701,7 @@     vBox       [ txt "Have questions? Want some tips? Check out:"       , txt " "-      , txt "  - The Swarm wiki, https://github.com/swarm-game/swarm/wiki"+      , txt $ "  - The Swarm wiki, " <> wikiUrl       , txt "  - The #swarm IRC channel on Libera.Chat"       ]   info =@@ -588,6 +736,7 @@     , ("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")@@ -624,7 +773,7 @@     vBox       [ table       , padTop (Pad 1) $ txt "For the full list of available commands see the Wiki at:"-      , txt "https://github.com/swarm-game/swarm/wiki/Commands-Cheat-Sheet"+      , txt wikiCheatSheet       ]  where   commands = gs ^. availableCommands . notificationsContent@@ -682,7 +831,7 @@     withAttr (colorLogs e) $       hBox         [ fromMaybe (txt "") $ maybeDrawTime (e ^. leTime) True gs-        , padLeft (Pad 2) . txt $ "[" <> e ^. leRobotName <> "]"+        , padLeft (Pad 2) . txt $ brackets $ e ^. leRobotName         , padLeft (Pad 1) . txt2 $ e ^. leText         ]   txt2 = txtWrapWith indent2@@ -725,7 +874,7 @@       ]  -- | Draw a menu explaining what key commands are available for the---   current panel.  This menu is displayed as a single line in+--   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.@@ -735,34 +884,47 @@     hBox       [ vBox           [ mkCmdRow globalKeyCmds-          , padLeft (Pad 2) $ mkCmdRow focusedPanelCmds+          , padLeft (Pad 2) contextCmds           ]       , gameModeWidget       ]  where   mkCmdRow = hBox . map drawPaddedCmd   drawPaddedCmd = padLeftRight 1 . drawKeyCmd+  contextCmds+    | ctrlMode == Handling = txt $ fromMaybe "" (s ^? gameState . inputHandler . _Just . _1)+    | otherwise = mkCmdRow focusedPanelCmds   focusedPanelCmds =-    map highlightKeyCmds $-      keyCmdsFor $-        focusGetCurrent $-          view (uiState . uiFocusRing) s+    map highlightKeyCmds+      . keyCmdsFor+      . focusGetCurrent+      . view (uiState . uiFocusRing)+      $ s    isReplWorking = s ^. gameState . replWorking   isPaused = s ^. gameState . 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 . worldScrollable)+  handlerInstalled = isJust (s ^. gameState . inputHandler) -  renderControlModeSwitch :: ReplControlMode -> T.Text-  renderControlModeSwitch = \case+  renderPilotModeSwitch :: ReplControlMode -> T.Text+  renderPilotModeSwitch = \case     Piloting -> "REPL"-    Typing -> "pilot"+    _ -> "pilot" +  renderHandlerModeSwitch :: ReplControlMode -> T.Text+  renderHandlerModeSwitch = \case+    Handling -> "REPL"+    _ -> "key handler"+   gameModeWidget =     padLeft Max       . padLeftRight 1@@ -775,9 +937,12 @@     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")-      , Just (NoHighlight, "^o", "step")+      , 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@@ -786,23 +951,30 @@     "pop out" | (s ^. uiState . uiMoreInfoBot) || (s ^. uiState . uiMoreInfoTop) -> Alert     _ -> PanelSpecific +  keyCmdsFor (Just (FocusablePanel WorldEditorPanel)) =+    [("^s", "save map")]   keyCmdsFor (Just (FocusablePanel REPLPanel)) =     [ ("↓↑", "history")     ]       ++ [("Enter", "execute") | not isReplWorking]       ++ [("^c", "cancel") | isReplWorking]-      ++ [("M-p", renderControlModeSwitch ctrlMode) | creative]+      ++ [("M-p", renderPilotModeSwitch ctrlMode) | creative]+      ++ [("M-k", renderHandlerModeSwitch ctrlMode) | handlerInstalled]   keyCmdsFor (Just (FocusablePanel WorldPanel)) =-    [ ("←↓↑→ / hjkl", "scroll") | creative+    [ ("←↓↑→ / hjkl", "scroll") | canScroll     ]       ++ [("c", "recenter") | not viewingBase]       ++ [("f", "FPS")]   keyCmdsFor (Just (FocusablePanel RobotPanel)) =-    [ ("Enter", "pop out")-    , ("m", "make")-    , ("0", (if showZero then "hide" else "show") <> " 0")-    , (":/;", T.unwords ["Sort:", renderSortMethod inventorySort])-    ]+    ("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 _ = [] @@ -826,8 +998,8 @@ ------------------------------------------------------------  -- | Draw the current world view.-drawWorld :: Bool -> GameState -> Widget Name-drawWorld showRobots g =+drawWorld :: UIState -> GameState -> Widget Name+drawWorld ui g =   center     . cached WorldCache     . reportExtent WorldExtent@@ -838,32 +1010,41 @@       ctx <- getContext       let w = ctx ^. availWidthL           h = ctx ^. availHeightL-          ixs = range (viewingRegion g (fromIntegral w, fromIntegral h))-      render . vBox . map hBox . chunksOf w . map (drawLoc showRobots g) $ ixs+          vr = viewingRegion g (fromIntegral w, fromIntegral h)+          ixs = range $ vr ^. planar+      render . vBox . map hBox . chunksOf w . map (drawLoc ui g . Cosmic (vr ^. subworld)) $ ixs  ------------------------------------------------------------ -- Robot inventory panel ------------------------------------------------------------  -- | Draw info about the currently focused robot, such as its name,---   position, orientation, and inventory.+--   position, orientation, and inventory, as long as it is not too+--   far away. drawRobotPanel :: AppState -> Widget Name-drawRobotPanel s = case (s ^. gameState . to focusedRobot, s ^. uiState . uiInventory) of-  (Just r, Just (_, lst)) ->-    let Location x y = r ^. robotLocation-        drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb-     in padBottom Max $-          vBox-            [ hCenter $-                hBox-                  [ txt (r ^. robotName)-                  , padLeft (Pad 2) $ str (printf "(%d, %d)" x y)-                  , padLeft (Pad 2) $ renderDisplay (r ^. robotDisplay)-                  ]-            , padAll 1 (BL.renderListWithIndex drawClickableItem True lst)-            ]-  _ -> padRight Max . padBottom Max $ str " "+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 Cosmic _subworldName (Location x y) = r ^. robotLocation+          drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb+       in padBottom Max $+            vBox+              [ hCenter $+                  hBox+                    [ txt (r ^. robotName)+                    , padLeft (Pad 2) $ str (printf "(%d, %d)" x y)+                    , padLeft (Pad 2) $ renderDisplay (r ^. robotDisplay)+                    ]+              , padAll 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@@ -905,29 +1086,30 @@ -- | Draw the info panel in the bottom-left corner, which shows info --   about the currently focused inventory item. drawInfoPanel :: AppState -> Widget Name-drawInfoPanel s =-  viewport InfoViewport Vertical-    . padLeftRight 1-    $ explainFocusedItem s+drawInfoPanel s+  | Just Far <- s ^. gameState . to focusedRange = blank+  | otherwise =+      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-      -- Special case: equipped logger device displays the robot's log.-      <=> if e ^. entityName == "logger" then drawRobotLog s else emptyWidget+  Just (EquippedEntry e) -> explainEntry s e   _ -> txt " "  explainEntry :: AppState -> Entity -> Widget Name explainEntry s e =-  vBox+  vBox $     [ displayProperties $ Set.toList (e ^. entityProperties)-    , displayParagraphs (e ^. entityDescription)+    , 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@@ -936,6 +1118,7 @@   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@@ -956,10 +1139,10 @@   | otherwise =       vBox         [ padBottom (Pad 1) (hBorderWithLabel (txt "Recipes"))-        , padLeftRight 2 $-            hCenter $-              vBox $-                map (hLimit widthLimit . padBottom (Pad 1) . drawRecipe (Just e) inv) recipes+        , padLeftRight 2+            . hCenter+            . vBox+            $ map (hLimit widthLimit . padBottom (Pad 1) . drawRecipe (Just e) inv) recipes         ]  where   recipes = recipesWith s e@@ -1068,7 +1251,7 @@  -- | Ad-hoc entity to represent time - only used in recipe drawing timeE :: Entity-timeE = mkEntity (defaultEntityDisplay '.') "ticks" [] [] []+timeE = mkEntity (defaultEntityDisplay '.') "ticks" mempty [] []  drawReqs :: IngredientList Entity -> Widget Name drawReqs = vBox . map (hCenter . drawReq)@@ -1097,6 +1280,20 @@     (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@@ -1133,17 +1330,20 @@  -- | Draw the REPL. drawREPL :: AppState -> Widget Name-drawREPL s = vBox $ latestHistory <> [currentPrompt]+drawREPL s = vBox $ latestHistory <> [currentPrompt] <> mayDebug  where   -- rendered history lines fitting above REPL prompt   latestHistory :: [Widget n]-  latestHistory = map fmt (getLatestREPLHistoryItems (replHeight - inputLines) (repl ^. replHistory))+  latestHistory = map fmt (getLatestREPLHistoryItems (replHeight - inputLines - debugLines) (repl ^. replHistory))   currentPrompt :: Widget Name-  currentPrompt = case isActive <$> base of-    Just False -> renderREPLPrompt (s ^. uiState . uiFocusRing) repl+  currentPrompt = case (isActive <$> base, repl ^. replControlMode) of+    (_, Handling) -> padRight Max $ txt "[key handler running, M-k to toggle]"+    (Just False, _) -> renderREPLPrompt (s ^. uiState . uiFocusRing) repl     _running -> padRight Max $ txt "..."   inputLines = 1+  debugLines = 3 * fromEnum (s ^. uiState . uiShowDebug)   repl = s ^. uiState . uiREPL   base = s ^. gameState . robotMap . at 0   fmt (REPLEntry e) = txt $ "> " <> e   fmt (REPLOutput t) = txt t+  mayDebug = [drawRobotMachine s True | s ^. uiState . uiShowDebug]
src/Swarm/TUI/View/Achievement.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.View.Achievement where  import Brick@@ -10,11 +12,11 @@ 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.Attr import Swarm.TUI.Model-import Swarm.TUI.Model.Achievement.Attainment-import Swarm.TUI.Model.Achievement.Definitions-import Swarm.TUI.Model.Achievement.Description import Swarm.TUI.Model.UI import Text.Wrap @@ -68,10 +70,10 @@   renderFlavorTextWidget (FTQuotation (Quotation author quoteContent)) =     vBox       [ txtWrap quoteContent-      , padLeft Max $-          padRight (Pad 2) $-            txtWrapWith (defaultWrapSettings {fillStrategy = FillIndent 2}) $-              "--" <> author+      , padLeft Max+          . padRight (Pad 2)+          . txtWrapWith (defaultWrapSettings {fillStrategy = FillIndent 2})+          $ "--" <> author       ]    innerContent =@@ -85,17 +87,25 @@           Nothing -> emptyWidget           Just attainment ->             padTop (Pad 1) $-              hBox-                [ txt "Obtained: "-                , withAttr cyanAttr $-                    str $-                      formatTime defaultTimeLocale "%l:%M%P on %b %e, %Y" $-                        attainment ^. obtainedAt+              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+            , withAttr boldAttr . str . show $ effort details             ]       ]
src/Swarm/TUI/View/CellDisplay.hs view
@@ -1,59 +1,194 @@+{-# 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+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.Word (Word32)+import Linear.Affine ((.-.))+import Swarm.Game.CESK (TickNumber (..)) import Swarm.Game.Display-import Swarm.Game.Entity as E+import Swarm.Game.Entity import Swarm.Game.Robot+import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.State-import Swarm.Game.Terrain (terrainMap)+import Swarm.Game.Terrain+import Swarm.Game.Universe import Swarm.Game.World qualified as W+import Swarm.TUI.Attr+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 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 :: Bool -> GameState -> W.Coords -> Widget Name-drawLoc showRobots g = renderDisplay . displayLoc showRobots g+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+  drawCell = renderDisplay $ displayLoc showRobots we g cCoords -displayTerrainCell :: GameState -> W.Coords -> Display-displayTerrainCell g coords = terrainMap M.! toEnum (W.lookupTerrain coords (g ^. world))+displayTerrainCell ::+  WorldEditor Name ->+  GameState ->+  Cosmic W.Coords ->+  Display+displayTerrainCell worldEditor g coords =+  terrainMap M.! EU.getTerrainAt worldEditor (g ^. multiWorld) coords -displayEntityCell, displayRobotCell :: GameState -> W.Coords -> [Display]-displayRobotCell g coords = map (view robotDisplay) (robotsAtLocation (W.coordsToLoc coords) g)-displayEntityCell g coords = maybeToList (displayForEntity <$> W.lookupEntity coords (g ^. world))+displayRobotCell ::+  GameState ->+  Cosmic W.Coords ->+  [Display]+displayRobotCell g coords =+  map (view robotDisplay) $+    robotsAtLocation (fmap W.coordsToLoc coords) g++displayEntityCell :: WorldEditor Name -> GameState -> Cosmic W.Coords -> [Display]+displayEntityCell worldEditor g coords =+  maybeToList $ displayForEntity <$> maybeEntity  where-  displayForEntity :: Entity -> Display-  displayForEntity e = (if known e then id else hidden) (e ^. entityDisplay)+  (_, maybeEntity) = EU.getContentAt worldEditor (g ^. multiWorld) coords -  known e =+  displayForEntity :: EntityPaint -> Display+  displayForEntity e = (if known e then id else hidden) $ getDisplay e++  known (Facade (EntityFacade _ _)) = True+  known (Ref e) =     e       `hasProperty` Known       || (e ^. entityName)-      `elem` (g ^. knownEntities)+        `elem` (g ^. knownEntities)       || case hidingMode g of         HideAllEntities -> False         HideNoEntity -> True         HideEntityUnknownTo ro -> ro `robotKnows` e +data HideEntity = HideAllEntities | HideNoEntity | HideEntityUnknownTo Robot++hidingMode :: GameState -> HideEntity+hidingMode g+  | g ^. creativeMode = HideNoEntity+  | otherwise = maybe HideAllEntities HideEntityUnknownTo $ focusedRobot g+ -- | 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 -> WorldEditor Name -> GameState -> Cosmic W.Coords -> Display+displayLoc showRobots we g cCoords@(Cosmic _ coords) =+  staticDisplay g coords+    <> displayLocRaw showRobots we g cCoords++-- | Get the 'Display' for a specific location, by combining the --   'Display's for the terrain, entity, and robots at the location.-displayLoc :: Bool -> GameState -> W.Coords -> Display-displayLoc showRobots g coords =-  sconcat $ terrain NE.:| entity <> robots+displayLocRaw ::+  Bool ->+  WorldEditor Name ->+  GameState ->+  Cosmic W.Coords ->+  Display+displayLocRaw showRobots worldEditor g coords = sconcat $ terrain NE.:| entity <> robots  where-  terrain = displayTerrainCell g coords-  entity = displayEntityCell g coords+  terrain = displayTerrainCell worldEditor g coords+  entity = displayEntityCell worldEditor g coords   robots =     if showRobots       then displayRobotCell g coords       else [] -data HideEntity = HideAllEntities | HideNoEntity | HideEntityUnknownTo Robot+-- | 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) -hidingMode :: GameState -> HideEntity-hidingMode g-  | g ^. creativeMode = HideNoEntity-  | otherwise = maybe HideAllEntities HideEntityUnknownTo $ focusedRobot g+-- | 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 ^. 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
src/Swarm/TUI/View/CustomStyling.hs view
@@ -1,10 +1,12 @@+-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.View.CustomStyling where  import Brick (AttrName, attrName)+import Data.Colour.SRGB (Colour, RGB (..), sRGB24read, toSRGB24) import Data.Set (toList) import Data.Text qualified as T import Graphics.Vty.Attributes-import Numeric (readHex) import Swarm.Game.Scenario.Style import Swarm.TUI.Attr (worldPrefix) @@ -21,16 +23,15 @@  toAttrColor :: HexColor -> Color toAttrColor (HexColor colorText) =-  case nums of-    [r, g, b] -> RGBColor r g b-    _ -> RGBColor 255 255 255+  RGBColor r g b  where-  chunks = T.chunksOf 2 $ T.dropWhile (== '#') colorText-  nums = map (fst . head . readHex . T.unpack) chunks+  RGB r g b = toSRGB24 c+  c :: Colour Double+  c = sRGB24read $ T.unpack colorText  toAttrPair :: CustomAttr -> (AttrName, Attr) toAttrPair ca =-  (worldPrefix <> attrName (name ca), addStyle $ addFg $ addBg currentAttr)+  (worldPrefix <> attrName (name ca), addStyle $ addFg $ addBg defAttr)  where   addFg = maybe id (flip withForeColor . toAttrColor) $ fg ca   addBg = maybe id (flip withBackColor . toAttrColor) $ bg ca
+ src/Swarm/TUI/View/Objective.hs view
@@ -0,0 +1,97 @@+{-# 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.Attr+import Swarm.TUI.Model.Goal+import Swarm.TUI.Model.Name+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+      hBox+        [ leftSide+        , hLimitPercent 70 $ padLeft (Pad 2) goalElaboration+        ]+    else goalElaboration+ where+  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
src/Swarm/TUI/View/Util.hs view
@@ -1,26 +1,35 @@ {-# LANGUAGE OverloadedStrings #-} +-- |+-- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.View.Util where -import Brick hiding (Direction)+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.Attr import Swarm.TUI.Model import Swarm.TUI.Model.UI+import Swarm.TUI.View.CellDisplay+import Swarm.Util (listEnums) import Witch (from, into)  -- | Generate a fresh modal window of the requested type.@@ -41,7 +50,7 @@       RecipesModal -> ("Available Recipes", Nothing, descriptionWidth)       CommandsModal -> ("Available Commands", Nothing, descriptionWidth)       MessagesModal -> ("Messages", Nothing, descriptionWidth)-      WinModal ->+      ScenarioEndModal WinModal ->         let nextMsg = "Next challenge!"             stopMsg = fromMaybe "Return to the menu" haltingMessage             continueMsg = "Keep playing"@@ -57,7 +66,7 @@                 )             , sum (map length [nextMsg, stopMsg, continueMsg]) + 32             )-      LoseModal ->+      ScenarioEndModal LoseModal ->         let stopMsg = fromMaybe "Return to the menu" haltingMessage             continueMsg = "Keep playing"             maybeStartOver = do@@ -97,11 +106,46 @@               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) ++ " " @@ -124,13 +168,24 @@     NoMenu -> "quit"     _ -> "return to the menu" --- | Display a list of text-wrapped paragraphs with one blank line after---   each.+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 = vBox . map (padBottom (Pad 1) . txtWrap)+displayParagraphs = layoutParagraphs . map txtWrap -withEllipsis :: Text -> Widget Name-withEllipsis t =+-- | 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@@ -138,7 +193,9 @@         tLength = T.length t         newText =           if tLength > w-            then T.take (w - T.length ellipsis) t <> ellipsis+            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 @@ -152,8 +209,8 @@     if V.imageHeight (result ^. imageL) <= ctx ^. availHeightL       then return result       else-        render $-          withVScrollBars OnRight $-            viewport vpName Vertical $-              Widget Fixed Fixed $-                return result+        render+          . withVScrollBars OnRight+          . viewport vpName Vertical+          . Widget Fixed Fixed+          $ return result
src/Swarm/Util.hs view
@@ -3,10 +3,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- |--- Module      :  Swarm.Util--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- A random collection of small, useful functions that are (or could@@ -14,36 +10,40 @@ module Swarm.Util (   -- * Miscellaneous utilities   (?),+  sortPair,   maxOn,   maximum0,   cycleEnum,   listEnums,+  indexWrapNonEmpty,   uniq,-  getElemsInArea,-  manhattan,   binTuples,+  histogram,+  findDup,+  both,+  allEqual,+  surfaceEmpty,+  applyWhen,    -- * Directory utilities   readFileMay,   readFileMayT,-  getSwarmXdgDataSubdir,-  getSwarmXdgDataFile,-  getSwarmSavePath,-  getSwarmHistoryPath,-  readAppData,-  getDataDirSafe,-  getDataFileNameSafe,-  dataNotFound,+  acquireAllWithExt,    -- * Text utilities   isIdentChar,   replaceLast,+  failT,+  showT,+  showLowT,    -- * English language utilities   reflow,   quote,   squote,   bquote,+  parens,+  brackets,   commaList,   indefinite,   indefiniteQ,@@ -68,28 +68,25 @@   (<>=),   _NonEmpty, -  -- * Utilities for NP-hard approximation+  -- * Set utilities+  removeSupersets,   smallHittingSet, ) where -import Control.Algebra (Has)+import Control.Applicative (Alternative)+import Control.Carrier.Throw.Either import Control.Effect.State (State, modify, state)-import Control.Effect.Throw (Throw, throwError)-import Control.Exception (catch)-import Control.Exception.Base (IOException)-import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<>~))-import Control.Lens.Lens ((&))-import Control.Monad (forM, unless, when)-import Data.Bifunctor (first)-import Data.Char (isAlphaNum)+import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<&>), (<>~))+import Control.Monad (filterM, guard, unless)+import Data.Bifunctor (Bifunctor (bimap), first)+import Data.Char (isAlphaNum, toLower) import Data.Either.Validation-import Data.Int (Int32)-import Data.List (maximumBy, partition)-import Data.List.NonEmpty (NonEmpty (..))+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, mapMaybe)+import Data.Maybe (fromMaybe) import Data.Ord (comparing) import Data.Set (Set) import Data.Set qualified as S@@ -102,25 +99,11 @@ import Language.Haskell.TH.Syntax (lift) import NLP.Minimorph.English qualified as MM import NLP.Minimorph.Util ((<+>))-import Paths_swarm (getDataDir)-import Swarm.Util.Location import System.Clock (TimeSpec)-import System.Directory (-  XdgDirectory (XdgData),-  createDirectoryIfMissing,-  doesDirectoryExist,-  doesFileExist,-  getXdgDirectory,-  listDirectory,- )-import System.FilePath-import System.IO+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath (takeExtension, (</>)) import System.IO.Error (catchIOError)-import Witch---- $setup--- >>> import qualified Data.Map as M--- >>> import Swarm.Util.Location+import Witch (from)  infixr 1 ? infix 4 %%=, <+=, <%=, <<.=, <>=@@ -132,6 +115,10 @@ (?) :: 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@@ -155,6 +142,13 @@ listEnums :: (Enum e, Bounded e) => [e] listEnums = [minBound .. maxBound] +-- | Guaranteed to yield an element of the list+indexWrapNonEmpty :: Integral b => NonEmpty a -> 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 []@@ -170,43 +164,6 @@   [] -> []   (x : xs) -> x : uniq (dropWhile (== x) xs) --- | Manhattan distance between world locations.-manhattan :: Location -> Location -> Int32-manhattan (Location x1 y1) (Location x2 y2) = abs (x1 - x2) + abs (y1 - y2)---- | Get elements that are in 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 (M.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- -- | Place the second element of the tuples into bins by -- the value of the first element. binTuples ::@@ -217,6 +174,38 @@  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))++-- 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+ ------------------------------------------------------------ -- Directory stuff @@ -228,98 +217,24 @@ 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) --- | 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 :: FilePath -> IO (Maybe FilePath)-getDataDirSafe p = do-  d <- (`appDir` p) <$> getDataDir-  de <- doesDirectoryExist d-  if de-    then return $ Just d-    else do-      xd <- (`appDir` p) <$> getSwarmXdgDataSubdir False "data"-      xde <- doesDirectoryExist xd-      return $ if xde then Just xd else Nothing- where-  appDir r = \case-    "" -> r-    "." -> r-    d -> r </> d---- | Get file from swarm data directory.------ See the note in 'getDataDirSafe'.-getDataFileNameSafe :: FilePath -> IO (Maybe FilePath)-getDataFileNameSafe name = do-  dir <- getDataDirSafe "."-  case dir of-    Nothing -> return Nothing-    Just d -> do-      let fp = d </> name-      fe <- doesFileExist fp-      return $ if fe then Just fp else Nothing---- | Get a nice message suggesting to download `data` directory to 'XdgData'.-dataNotFound :: FilePath -> IO Text-dataNotFound f = do-  d <- getSwarmXdgDataSubdir False ""-  let squotes = squote . T.pack-  return $-    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 :: IO (Map Text Text)-readAppData = do-  md <- getDataDirSafe "."-  case md of-    Nothing -> fail . T.unpack =<< dataNotFound "<the data directory itself>"-    Just d -> do-      fs <--        filter ((== ".txt") . takeExtension)-          <$> ( listDirectory d `catch` \e ->-                  hPutStr stderr (show (e :: IOException)) >> return []-              )-      M.fromList . mapMaybe sequenceA-        <$> forM fs (\f -> (into @Text (dropExtension f),) <$> readFileMayT (d </> f))- ------------------------------------------------------------ -- Some Text-y stuff @@ -345,6 +260,19 @@ 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 @@ -413,6 +341,14 @@ 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 [] = ""@@ -487,7 +423,30 @@ _NonEmpty = lens (\(x :| xs) -> (x, xs)) (const (uncurry (:|)))  --------------------------------------------------------------- Some utilities for NP-hard approximation+-- 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
+ src/Swarm/Util/Effect.hs view
@@ -0,0 +1,80 @@+-- |+-- 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
+ src/Swarm/Util/Erasable.hs view
@@ -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
+ src/Swarm/Util/Lens.hs view
@@ -0,0 +1,42 @@+-- |+-- 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+    )
− src/Swarm/Util/Location.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- Orphan JSON instances for Location and Heading---- |--- Module      :  Swarm.Util.Location--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com------ SPDX-License-Identifier: BSD-3-Clause------ Locations and headings.-module Swarm.Util.Location (Location, pattern Location, Heading, origin, Affine (..)) where--import Data.Aeson (FromJSONKey, ToJSONKey)-import Data.Int (Int32)-import Data.Yaml (FromJSON (parseJSON), ToJSON (toJSON))-import Linear (V2 (..))-import Linear.Affine (Affine (..), Point (..), origin)---- | A 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 '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 'Coords'.-type Location = Point V2 Int32---- | A convenient way to pattern-match on 'Location' values.-pattern Location :: Int32 -> Int32 -> Location-pattern Location x y = P (V2 x y)--{-# COMPLETE Location #-}---- | A @Heading@ is a 2D vector, with 32-bit coordinates.------   '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 'Location's is a 'Heading' (via '.-.').---   * A 'Location' plus a 'Heading' is another 'Location' (via '.^+').-type Heading = V2 Int32--deriving instance ToJSON (V2 Int32)-deriving instance FromJSON (V2 Int32)--deriving instance FromJSONKey (V2 Int32)-deriving instance ToJSONKey (V2 Int32)--instance FromJSON Location where-  parseJSON = fmap P . parseJSON--instance ToJSON Location where-  toJSON (P v) = toJSON v
+ src/Swarm/Util/Parse.hs view
@@ -0,0 +1,19 @@+-- |+-- 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
src/Swarm/Util/Yaml.hs view
@@ -1,12 +1,9 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-}  -- |--- Module      :  Swarm.Util.Yaml--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Various utilities related to parsing YAML files.@@ -27,6 +24,7 @@   withArrayE, ) where +import Control.Applicative (Alternative) import Control.Monad.Reader import Data.Aeson.Key (fromText) import Data.Aeson.Types (explicitParseField, explicitParseFieldMaybe)@@ -35,6 +33,7 @@ import Data.Text (Text) import Data.Vector qualified as V import Data.Yaml as Y+import Swarm.Util (failT, showT)  ------------------------------------------------------------ -- WithEntities wrapper@@ -44,7 +43,7 @@ --   value of type @e@. newtype With e f a = E {runE :: e -> f a}   deriving (Functor)-  deriving (Applicative, Monad, MonadFail) via (ReaderT e f)+  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@@ -100,7 +99,7 @@             (,)               <$> parseJSONE (V.unsafeIndex t 0)               <*> parseJSONE (V.unsafeIndex t 1)-          else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 2"+          else failT ["cannot unpack array of length", showT n, "into a tuple of length 2"]  ------------------------------------------------------------ -- Decoding
src/Swarm/Version.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}  -- |--- Module      :  Swarm.Version--- Copyright   :  Brent Yorgey--- Maintainer  :  byorgey@gmail.com--- -- SPDX-License-Identifier: BSD-3-Clause -- -- Query current and upstream Swarm version.@@ -28,6 +24,7 @@ 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)@@ -42,6 +39,7 @@ 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@@ -108,7 +106,7 @@         t <- o .: "tag_name"         if isSwarmReleaseTag t           then return t-          else fail $ "The release '" <> t <> "' is not main Swarm release!"+          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
src/Swarm/Web.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeApplications #-}+{-# 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,@@ -19,42 +22,102 @@ --   * TODO: #493 export the whole game state module Swarm.Web 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.Lens import Control.Monad (void) import Control.Monad.IO.Class (liftIO)+import Data.ByteString.Lazy (ByteString) import Data.Foldable (toList)-import Data.IORef (IORef, readIORef) 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 Swarm.Game.Robot import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph-import Swarm.Game.Scenario.Objective.Presentation.Model import Swarm.Game.Scenario.Objective.WinCheck import Swarm.Game.State+import Swarm.Language.Module+import Swarm.Language.Pipeline+import Swarm.Language.Pretty (prettyString)+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) -type SwarmApi =+newtype RobotID = RobotID Int++instance FromHttpApiData RobotID where+  parseUrlPiece = fmap RobotID . left T.pack . readEither . T.unpack++instance SD.ToSample T.Text where+  toSamples _ = SD.noSamples++type SwarmAPI =   "robots" :> Get '[JSON] [Robot]-    :<|> "robot" :> Capture "id" Int :> Get '[JSON] (Maybe 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-    :<|> "repl" :> "history" :> "full" :> Get '[JSON] [T.Text]+    :<|> "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] -mkApp :: IORef AppState -> Servant.Server SwarmApi-mkApp appStateRef =+instance ToCapture (Capture "id" RobotID) where+  toCapture _ =+    SD.DocCapture+      "id" -- name+      "(integer) robot ID" -- description++swarmApi :: Proxy SwarmAPI+swarmApi = Proxy++type ToplevelAPI = SwarmAPI :<|> Raw++api :: Proxy ToplevelAPI+api = Proxy++docsBS :: ByteString+docsBS =+  encodeUtf8+    . either (error . show) (Mark.renderHtml @())+    . Mark.commonmark ""+    . T.pack+    . SD.markdownWith+      ( SD.defRenderingOptions+          & SD.requestExamples .~ SD.FirstContentType+          & SD.responseExamples .~ SD.FirstContentType+      )+    $ SD.docsWithIntros [intro] swarmApi+ where+  intro = SD.DocIntro "Swarm Web API" ["All of the valid endpoints are documented below."]++mkApp ::+  ReadableIORef AppState ->+  -- | Writable+  BChan AppEvent ->+  Servant.Server SwarmAPI+mkApp appStateRef chan =   robotsHandler     :<|> robotHandler     :<|> prereqsHandler@@ -62,12 +125,14 @@     :<|> goalsGraphHandler     :<|> uiGoalHandler     :<|> goalsHandler+    :<|> codeRenderHandler+    :<|> codeRunHandler     :<|> replHandler  where   robotsHandler = do     appState <- liftIO (readIORef appStateRef)     pure $ IM.elems $ appState ^. gameState . robotMap-  robotHandler rid = do+  robotHandler (RobotID rid) = do     appState <- liftIO (readIORef appStateRef)     pure $ IM.lookup rid (appState ^. gameState . robotMap)   prereqsHandler = do@@ -91,24 +156,50 @@   goalsHandler = do     appState <- liftIO (readIORef appStateRef)     return $ appState ^. gameState . winCondition+  codeRenderHandler contents = do+    return $ case processTermEither contents of+      Right (ProcessedTerm (Module stx@(Syntax' _srcLoc _term _) _) _ _) ->+        into @Text . drawTree . fmap prettyString . para Node $ stx+      Left x -> x+  codeRunHandler contents = do+    liftIO . writeBChan chan . Web $ RunWebCode contents+    return $ T.pack "Sent\n"   replHandler = do     appState <- liftIO (readIORef appStateRef)     let replHistorySeq = appState ^. uiState . uiREPL . replHistory . replSeq-        items = [x | REPLEntry x <- toList replHistorySeq]+        items = toList replHistorySeq     pure items -webMain :: Maybe (MVar (Either String ())) -> Warp.Port -> IORef AppState -> IO ()-webMain baton port appStateRef = catch (Warp.runSettings settings app) handleErr+-- | Simple result type to report errors from forked startup thread.+data WebStartResult = WebStarted | WebStartError String++webMain ::+  Maybe (MVar WebStartResult) ->+  Warp.Port ->+  ReadableIORef AppState ->+  -- | Writable+  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 (Right ())+    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] docsBS+    plain = ("Content-Type", "text/html")+   app :: Network.Wai.Application-  app = Servant.serve (Proxy @SwarmApi) (mkApp appStateRef)+  app = Servant.serve api server+   handleErr :: IOException -> IO ()   handleErr e = case baton of-    Just mv -> putMVar mv (Left $ displayException e)+    Just mv -> putMVar mv (WebStartError $ displayException e)     Nothing -> throwIO e  defaultPort :: Warp.Port@@ -120,21 +211,25 @@ --   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 -> IORef AppState -> IO (Either String Warp.Port)+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 portM appStateRef = do+startWebThread (Just 0) _ _ = pure $ Left "The web port has been turned off."+startWebThread userPort appStateRef chan = do   baton <- newEmptyMVar-  let port = fromMaybe defaultPort portM-  void $ forkIO $ webMain (Just baton) port appStateRef+  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 (portM, res) of-    -- User requested explicit port but server didn't start: fail-    (Just _, Nothing) -> fail $ failMsg port-    -- If we are using the default port, we just report the timeout-    (Nothing, Nothing) -> return . Left $ failMsg port <> " (timeout)"-    (_, Just (Left e)) -> return . Left $ failMsg port <> " - " <> e-    -- If all works, we report on what port the web server is running-    (_, Just _) -> return (Right port)- where-  failMsg p = "Failed to start the web API on :" <> show p+  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)"
swarm.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               swarm-version:            0.3.0.1+version:            0.4 synopsis:           2D resource gathering game with programmable robots  description:        Swarm is a 2D programming and resource gathering@@ -18,13 +18,13 @@ bug-reports:        https://github.com/swarm-game/swarm/issues copyright:          Brent Yorgey 2021 category:           Game-tested-with:        GHC ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2+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 data-dir:           data/-data-files:         *.yaml, scenarios/**/*.yaml, scenarios/**/*.txt, scenarios/**/*.sw, *.txt, test/language-snippets/**/*.sw+data-files:         *.yaml, worlds/*.world, scenarios/**/*.yaml, scenarios/**/*.txt, scenarios/**/*.sw, *.txt, test/language-snippets/**/*.sw  source-repository head     type:     git@@ -81,38 +81,73 @@  library     import:           stan-config, common, ghc2021-extensions-    exposed-modules:  Data.BoolExpr+    exposed-modules:  Control.Carrier.Accum.FixedStrict                       Data.BoolExpr.Simplify                       Swarm.App-                      Swarm.DocGen+                      Swarm.Constant+                      Swarm.Doc.Gen+                      Swarm.Doc.Pedagogy+                      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.Log                       Swarm.Game.Recipe+                      Swarm.Game.ResourceLoading                       Swarm.Game.Robot                       Swarm.Game.Scenario-                      Swarm.Game.Scenario.Cell-                      Swarm.Game.Scenario.Objective.Logic+                      Swarm.Game.Scenario.Topography.Cell+                      Swarm.Game.Universe+                      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.Presentation.Model-                      Swarm.Game.Scenario.Objective.Presentation.Render+                      Swarm.Game.Scenario.Objective.Logic                       Swarm.Game.Scenario.Objective.Validation                       Swarm.Game.Scenario.Objective.WinCheck-                      Swarm.Game.Scenario.Objective                       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.WorldDescription+                      Swarm.Game.Scenario.Topography.EntityFacade+                      Swarm.Game.Scenario.Topography.Navigation.Portal+                      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.Terrain+                      Swarm.Game.Value                       Swarm.Game.World-                      Swarm.Game.WorldGen-                      Swarm.Language.Context+                      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.Parse+                      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@@ -124,23 +159,29 @@                       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.Attr                       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.View.CustomStyling                       Swarm.TUI.Inventory.Sorting                       Swarm.TUI.List                       Swarm.TUI.Model-                      Swarm.TUI.Model.Achievement.Attainment-                      Swarm.TUI.Model.Achievement.Definitions-                      Swarm.TUI.Model.Achievement.Description-                      Swarm.TUI.Model.Achievement.Persistence-                      Swarm.TUI.Model.Failure+                      Swarm.TUI.Model.Goal                       Swarm.TUI.Model.Menu                       Swarm.TUI.Model.Name                       Swarm.TUI.Model.Repl@@ -150,21 +191,32 @@                       Swarm.TUI.View                       Swarm.TUI.View.Achievement                       Swarm.TUI.View.CellDisplay+                      Swarm.TUI.View.CustomStyling+                      Swarm.TUI.View.Objective                       Swarm.TUI.View.Util                       Swarm.Util-                      Swarm.Util.Location+                      Swarm.Util.Effect+                      Swarm.Util.Erasable+                      Swarm.Util.Lens+                      Swarm.Util.Parse                       Swarm.Util.Yaml                       Swarm.Version                       Swarm.Web     other-modules:    Paths_swarm     autogen-modules:  Paths_swarm -    build-depends:    base                          >= 4.14 && < 4.18,+    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,-                      brick                         >= 1.5 && < 1.7,+                      blaze-html                    >= 0.9.1 && < 0.9.2,+                      boolexpr                      >= 0.2 && < 0.3,+                      brick                         >= 1.5 && < 1.10,                       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,@@ -173,6 +225,7 @@                       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,@@ -182,35 +235,40 @@                       lens                          >= 4.19 && < 5.3,                       linear                        >= 1.21.6 && < 1.23,                       lsp                           >= 1.6 && < 1.7,-                      megaparsec                    >= 9.0 && < 9.4,+                      megaparsec                    >= 9.0 && < 9.5,                       minimorph                     >= 0.3 && < 0.4,-                      mtl                           >= 2.2.2 && < 2.3,+                      transformers                  >= 0.5 && < 0.7,+                      mtl                           >= 2.2.2 && < 2.4,                       murmur3                       >= 1.0.4 && < 1.1,                       natural-sort                  >= 0.1.2 && < 0.2,                       parser-combinators            >= 1.2 && < 1.4,                       prettyprinter                 >= 1.7.0 && < 1.8,                       random                        >= 1.2.0 && < 1.3,-                      servant                       >= 0.19 && < 0.20,-                      servant-server                >= 0.19 && < 0.20,+                      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.20,+                      template-haskell              >= 2.16 && < 2.21,                       text                          >= 1.2.4 && < 2.1,                       text-rope                     >= 0.2 && < 0.3,-                      text-zipper                   >= 0.10 && < 0.13,+                      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.38,+                      vty                           >= 5.33 && < 5.39,                       wai                           >= 3.2 && < 3.3,                       warp                          >= 3.2 && < 3.4,-                      witch                         >= 1.1.1.0 && < 1.2,+                      witch                         >= 1.1.1.0 && < 1.3,+                      witherable                    >= 0.4 && < 0.5,                       word-wrap                     >= 0.5 && < 0.6,-                      yaml                          >= 0.11 && < 0.12,+                      yaml                          >= 0.11 && < 0.11.12.0,     hs-source-dirs:   src     default-language: Haskell2010     default-extensions:@@ -221,7 +279,7 @@ executable swarm     import:           stan-config, common     main-is:          Main.hs-    build-depends:    optparse-applicative          >= 0.16 && < 0.18,+    build-depends:    optparse-applicative          >= 0.16 && < 0.19,                       githash                       >= 0.1.6 && < 0.2,                       -- Imports shared with the library don't need bounds                       base,@@ -239,11 +297,14 @@     other-modules:    TestEval                       TestInventory                       TestModel+                      TestPedagogy                       TestNotification                       TestLanguagePipeline                       TestPretty                       TestBoolExpr+                      TestCommand                       TestLSP+                      TestScoring                       TestUtil      build-depends:    tasty                         >= 0.10 && < 1.5,@@ -253,6 +314,7 @@                       -- Imports shared with the library don't need bounds                       aeson,                       base,+                      boolexpr,                       containers,                       filepath,                       hashable,@@ -261,7 +323,9 @@                       mtl,                       swarm,                       text,-                      witch+                      time,+                      witch,+                      vty     hs-source-dirs:   test/unit     default-language: Haskell2010     ghc-options:      -threaded@@ -279,6 +343,7 @@                       containers,                       directory,                       filepath,+                      fused-effects,                       lens,                       linear,                       mtl,@@ -304,6 +369,7 @@                   mtl,                   random,                   swarm,-                  text+                  text,+                  containers   default-language: Haskell2010   ghc-options:      -threaded
test/integration/Main.hs view
@@ -1,14 +1,19 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} --- | Swarm integration tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm integration tests module Main where -import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<&>), (<>~), (^.), (^..), (^?!))-import Control.Monad (filterM, forM_, unless, when)+import Control.Carrier.Lift (runM)+import Control.Carrier.Throw.Either (runThrow)+import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<>~), (^.), (^..), (^?!))+import Control.Monad (forM_, unless, when) import Control.Monad.State (StateT (runStateT), gets)-import Control.Monad.Trans.Except (runExceptT) import Data.Char (isSpace) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (Foldable (toList), find)@@ -21,10 +26,11 @@ import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Yaml (ParseException, prettyPrintParseException)-import Swarm.DocGen (EditorType (..))-import Swarm.DocGen qualified as DocGen-import Swarm.Game.CESK (emptyStore, initMachine)-import Swarm.Game.Entity (EntityMap, loadEntities, lookupByName)+import Swarm.Doc.Gen (EditorType (..))+import Swarm.Doc.Gen qualified as DocGen+import Swarm.Game.CESK (emptyStore, getTickNumber, initMachine)+import Swarm.Game.Entity (EntityMap, lookupByName)+import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Robot (LogEntry, defReqs, equippedDevices, leText, machine, robotContext, robotLog, waitingUntil) import Swarm.Game.Scenario (Scenario) import Swarm.Game.State (@@ -33,7 +39,6 @@   WinStatus (Won),   activeRobots,   baseRobot,-  initGameStateForScenario,   messageQueue,   robotMap,   ticks,@@ -42,13 +47,16 @@   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.Language.Pretty (prettyString)+import Swarm.TUI.Model (RuntimeState, defaultAppOpts, gameState, stdEntityMap, userScenario, worlds)+import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState)+import Swarm.TUI.Model.UI (UIState)+import Swarm.Util (acquireAllWithExt) import Swarm.Util.Yaml (decodeFileEitherE)-import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)-import System.Environment (getEnvironment)-import System.FilePath (splitDirectories)-import System.FilePath.Posix (takeExtension, (</>))+import System.FilePath.Posix (splitDirectories) import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase)@@ -59,25 +67,24 @@  main :: IO () main = do-  examplePaths <- acquire "example" "sw"-  scenarioPaths <- acquire "data/scenarios" "yaml"+  examplePaths <- acquireAllWithExt "example" "sw"+  scenarioPaths <- acquireAllWithExt "data/scenarios" "yaml"   let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths-  scenarioPrograms <- acquire "data/scenarios" "sw"-  ci <- any (("CI" ==) . fst) <$> getEnvironment-  entities <- loadEntities-  case entities of-    Left t -> fail $ "Couldn't load entities: " <> into @String t-    Right em -> do-      defaultMain $-        testGroup-          "Tests"-          [ exampleTests examplePaths-          , exampleTests scenarioPrograms-          , scenarioParseTests em parseableScenarios-          , scenarioParseInvalidTests em unparseableScenarios-          , testScenarioSolution ci em-          , testEditorFiles-          ]+  scenarioPrograms <- acquireAllWithExt "data/scenarios" "sw"+  (rs, ui) <- do+    out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts+    either (assertFailure . prettyString) return out+  let em = rs ^. stdEntityMap+  defaultMain $+    testGroup+      "Tests"+      [ exampleTests examplePaths+      , exampleTests scenarioPrograms+      , scenarioParseTests em (rs ^. worlds) parseableScenarios+      , scenarioParseInvalidTests em (rs ^. worlds) unparseableScenarios+      , testScenarioSolutions rs ui+      , testEditorFiles+      ]  exampleTests :: [(FilePath, String)] -> TestTree exampleTests inputs = testGroup "Test example" (map exampleTest inputs)@@ -89,27 +96,27 @@  where   value = processTerm $ into @Text fileContent -scenarioParseTests :: EntityMap -> [(FilePath, String)] -> TestTree-scenarioParseTests em inputs =+scenarioParseTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree+scenarioParseTests em worldMap inputs =   testGroup     "Test scenarios parse"-    (map (scenarioTest Parsed em) inputs)+    (map (scenarioTest Parsed em worldMap) inputs) -scenarioParseInvalidTests :: EntityMap -> [(FilePath, String)] -> TestTree-scenarioParseInvalidTests em inputs =+scenarioParseInvalidTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree+scenarioParseInvalidTests em worldMap inputs =   testGroup     "Test invalid scenarios fail to parse"-    (map (scenarioTest Failed em) inputs)+    (map (scenarioTest Failed em worldMap) inputs)  data ParseResult = Parsed | Failed -scenarioTest :: ParseResult -> EntityMap -> (FilePath, String) -> TestTree-scenarioTest expRes em (path, _) =-  testCase ("parse scenario " ++ show path) (getScenario expRes em path)+scenarioTest :: ParseResult -> EntityMap -> WorldMap -> (FilePath, String) -> TestTree+scenarioTest expRes em worldMap (path, _) =+  testCase ("parse scenario " ++ show path) (getScenario expRes em worldMap path) -getScenario :: ParseResult -> EntityMap -> FilePath -> IO ()-getScenario expRes em p = do-  res <- decodeFileEitherE em p :: IO (Either ParseException Scenario)+getScenario :: ParseResult -> EntityMap -> WorldMap -> FilePath -> IO ()+getScenario expRes em worldMap p = do+  res <- decodeFileEitherE (em, worldMap) p :: IO (Either ParseException Scenario)   case expRes of     Parsed -> case res of       Left err -> assertFailure (prettyPrintParseException err)@@ -118,18 +125,6 @@       Left _err -> return ()       Right _s -> assertFailure "Unexpectedly parsed invalid scenario!" -acquire :: FilePath -> String -> IO [(FilePath, String)]-acquire 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 (`acquire` ext) sub-  return $ children <> transChildren- where-  hasExt path = takeExtension path == ("." ++ ext)- data Time   = -- | One second should be enough to run most programs.     Default@@ -149,8 +144,8 @@  data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show) -testScenarioSolution :: Bool -> EntityMap -> TestTree-testScenarioSolution _ci _em =+testScenarioSolutions :: RuntimeState -> UIState -> TestTree+testScenarioSolutions rs ui =   testGroup     "Test scenario solutions"     [ testGroup@@ -166,11 +161,12 @@         , testTutorialSolution Default "Tutorials/build"         , testTutorialSolution Default "Tutorials/bind2"         , testTutorialSolution' Default "Tutorials/crash" CheckForBadErrors $ \g -> do-            let rs = toList $ g ^. robotMap+            let robots = toList $ g ^. robotMap             let hints = any (T.isInfixOf "you will win" . view leText) . toList . view robotLog-            let win = isJust $ find hints rs+            let win = isJust $ find hints robots             assertBool "Could not find a robot with winning instructions!" win         , testTutorialSolution Default "Tutorials/scan"+        , testTutorialSolution Default "Tutorials/give"         , testTutorialSolution Default "Tutorials/def"         , testTutorialSolution Default "Tutorials/lambda"         , testTutorialSolution Default "Tutorials/require"@@ -182,10 +178,18 @@         "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 5) "Challenges/bridge-building"         , testSolution (Sec 3) "Challenges/ice-cream"+        , testSolution (Sec 3) "Challenges/arbitrage"+        , testSolution (Sec 5) "Challenges/gopher"+        , testSolution (Sec 5) "Challenges/hackman"+        , testSolution (Sec 5) "Challenges/blender"         , testSolution (Sec 10) "Challenges/hanoi"+        , testSolution (Sec 3) "Challenges/lights-out"+        , testSolution (Sec 10) "Challenges/Sliding Puzzles/3x3"         , testSolution Default "Challenges/friend"         , testGroup             "Mazes"@@ -196,8 +200,21 @@             ]         , testGroup             "Ranching"-            [ testSolution (Sec 30) "Challenges/Ranching/gated-paddock"+            [ testSolution Default "Challenges/Ranching/capture"+            , testSolution (Sec 5) "Challenges/Ranching/powerset"+            , testSolution (Sec 30) "Challenges/Ranching/gated-paddock"             ]+        , testGroup+            "Sokoban"+            [ testSolution Default "Challenges/Sokoban/foresight.yaml"+            , testSolution Default "Challenges/Sokoban/Gadgets/no-reverse.yaml"+            , testSolution Default "Challenges/Sokoban/Gadgets/one-way.yaml"+            , testSolution Default "Challenges/Sokoban/Simple/trapdoor.yaml"+            ]+        , testGroup+            "Mechanics"+            [ testSolution Default "Mechanics/active-trapdoor.yaml"+            ]         ]     , testGroup         "Regression tests"@@ -209,7 +226,7 @@                 r1Waits = g ^?! robotMap . ix 1 . to waitingUntil                 active = IS.member 1 $ g ^. activeRobots                 waiting = elem 1 . concat . M.elems $ g ^. waitingRobots-            assertBool "The game should only take two ticks" $ t == 2+            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             assertBool "Robot 1 should not be in waiting set" $ not waiting@@ -257,6 +274,35 @@         , testSolution Default "Testing/961-custom-capabilities"         , testSolution Default "Testing/956-GPS"         , testSolution Default "Testing/958-isempty"+        , testSolution Default "Testing/1007-use-command"+        , testSolution Default "Testing/1024-sand"+        , testSolution Default "Testing/1140-detect-command"+        , testSolution Default "Testing/1157-drill-return-value"+        , testSolution Default "Testing/1171-sniff-command"+        , testSolution Default "Testing/1171-chirp-command"+        , testSolution Default "Testing/1171-resonate-command"+        , testSolution Default "Testing/1207-scout-command"+        , testSolution Default "Testing/1218-stride-command"+        , testSolution Default "Testing/1234-push-command"+        , 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/1379-single-world-portal-reorientation"+        , testSolution Default "Testing/1399-backup-command"+        , testGroup+            -- Note that the description of the classic world in+            -- data/worlds/classic.yaml (automatically tested to some+            -- extent by the solution to Tutorial/world101 and+            -- Tutorial/farming) also constitutes a fairly+            -- comprehensive test of world DSL features.+            "World DSL (#1320)"+            [ testSolution Default "Testing/1320-world-DSL/constant"+            , testSolution Default "Testing/1320-world-DSL/erase"+            , testSolution Default "Testing/1320-world-DSL/override"+            ]         ]     ]  where@@ -268,10 +314,10 @@    testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree   testSolution' s p shouldCheckBadErrors verify = testCase p $ do-    out <- runExceptT $ initGameStateForScenario p Nothing Nothing+    out <- runM . runThrow @SystemFailure $ constructAppState rs ui $ defaultAppOpts {userScenario = Just p}     case out of-      Left x -> assertFailure $ unwords ["Failure in initGameStateForScenario:", T.unpack x]-      Right gs -> case gs ^. winSolution of+      Left err -> assertFailure $ prettyString err+      Right (view gameState -> gs) -> case gs ^. winSolution of         Nothing -> assertFailure "No solution to test!"         Just sol@(ProcessedTerm _ _ reqCtx) -> do           let gs' =
test/unit/Main.hs view
@@ -1,15 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} --- | Swarm unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm unit tests module Main where +import Control.Lens ((^.)) import Control.Monad.Except (runExceptT) import Data.List (subsequences) import Data.Set (Set) import Data.Set qualified as S-import Swarm.Game.State (GameState, classicGame0)-import Swarm.Util (smallHittingSet)+import Swarm.TUI.Model (AppState, gameState, runtimeState)+import Swarm.TUI.Model.StateUpdate (classicGame0)+import Swarm.Util (removeSupersets, smallHittingSet) import Test.QuickCheck qualified as QC import Test.QuickCheck.Poly qualified as QC import Test.Tasty (TestTree, defaultMain, testGroup)@@ -21,33 +27,39 @@   (==>),  ) import TestBoolExpr (testBoolExpr)+import TestCommand (testCommands) import TestEval (testEval) import TestInventory (testInventory) import TestLSP (testLSP) import TestLanguagePipeline (testLanguagePipeline) import TestModel (testModel) import TestNotification (testNotification)+import TestPedagogy (testPedagogy) import TestPretty (testPrettyConst)+import TestScoring (testHighScores) import Witch (from)  main :: IO () main = do-  mg <- runExceptT classicGame0-  case mg of+  ms <- runExceptT classicGame0+  case ms of     Left err -> assertFailure (from err)-    Right g -> defaultMain (tests g)+    Right s -> defaultMain (tests s) -tests :: GameState -> TestTree-tests g =+tests :: AppState -> TestTree+tests s =   testGroup     "Tests"     [ testLanguagePipeline     , testPrettyConst     , testBoolExpr-    , testEval g+    , testCommands+    , testHighScores+    , testEval (s ^. gameState)     , testModel+    , testPedagogy (s ^. runtimeState)     , testInventory-    , testNotification g+    , testNotification (s ^. gameState)     , testMisc     , testLSP     ]@@ -59,6 +71,15 @@     [ testProperty         "smallHittingSet produces hitting sets"         (prop_hittingSet @QC.OrdA)+    , testGroup+        "removeSupersets"+        [ testProperty+            "no two output sets are in a subset relation"+            (prop_removeSupersets_unrelated @QC.OrdA)+        , testProperty+            "all input sets are a superset of some output set"+            (prop_removeSupersets_all_inputs @QC.OrdA)+        ]     ]  prop_hittingSet :: Ord a => [Set a] -> Property@@ -86,3 +107,14 @@  instance QC.Arbitrary El where   arbitrary = QC.arbitraryBoundedEnum++prop_removeSupersets_unrelated :: Ord a => Set (Set a) -> Bool+prop_removeSupersets_unrelated (removeSupersets -> ss) =+  (`all` ss) $ \s1 ->+    (`all` ss) $ \s2 ->+      (s1 == s2) || (not (s1 `S.isSubsetOf` s2) && not (s2 `S.isSubsetOf` s1))++prop_removeSupersets_all_inputs :: Ord a => Set (Set a) -> Bool+prop_removeSupersets_all_inputs (removeSupersets -> ss) =+  (`all` ss) $ \s1 ->+    (`any` ss) $ \s2 -> s2 `S.isSubsetOf` s1
test/unit/TestBoolExpr.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} --- | Boolean expression unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Boolean expression unit tests module TestBoolExpr where  import Data.BoolExpr qualified as BE@@ -82,12 +85,12 @@         "Prerequisite expressions"         [ testCase             "A negated goal is completed"-            $ assertBool "Should have returned true"+            . assertBool "Should have returned true"             $ WC.isUnwinnablePrereq (Set.singleton "b") demoPrereqs         , testCase             "A non-negated goal is completed"-            $ assertBool "Should have returned false"-            $ not+            . assertBool "Should have returned false"+            . not             $ WC.isUnwinnablePrereq (Set.singleton "c") demoPrereqs         ]     ]
+ test/unit/TestCommand.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm command implementation unit tests+module TestCommand where++import Data.Set qualified as S+import Data.Text (Text)+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 Test.QuickCheck qualified as QC+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (testProperty)+import Witch++testCommands :: TestTree+testCommands =+  testGroup+    "Command implementations"+    [ testGroup+        "Directions"+        [ testGroup+            "Relative direction"+            [ testCase+                "West to East"+                $ assertEqual "Incorrect relative dir" (relativeTo DWest DEast) DBack+            , testCase+                "South to South"+                $ assertEqual "Incorrect relative dir" (relativeTo DSouth DSouth) DForward+            , testCase+                "South to West"+                $ assertEqual "Incorrect relative dir" (DSouth `relativeTo` DWest) DLeft+            , testCase+                "West to South"+                $ assertEqual "Incorrect relative dir" (DWest `relativeTo` DSouth) DRight+            ]+        ]+    , testGroup+        "Keys"+        [ testGroup+            "Parsing"+            ( let parseKeyTest input 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')+                  , testCase "parse F" $ parseKeyTest "F" [] (V.KChar 'F')+                  , testCase "parse F3" $ parseKeyTest "F3" [] (V.KFun 3)+                  , testCase "parse F12" $ parseKeyTest "F12" [] (V.KFun 12)+                  , testCase "parse Down" $ parseKeyTest "Down" [] V.KDown+                  , testCase "parse DownLeft" $ parseKeyTest "DownLeft" [] V.KDownLeft+                  , testCase "parse C-x" $ parseKeyTest "C-x" [V.MCtrl] (V.KChar 'x')+                  , testCase "parse S-x" $ parseKeyTest "S-x" [V.MShift] (V.KChar 'x')+                  , testCase "parse A-x" $ parseKeyTest "A-x" [V.MAlt] (V.KChar 'x')+                  , testCase "parse M-x" $ parseKeyTest "M-x" [V.MMeta] (V.KChar 'x')+                  , testCase "parse M-C-x" $ parseKeyTest "M-C-x" [V.MCtrl, V.MMeta] (V.KChar 'x')+                  , testCase "parse C-M-x" $ parseKeyTest "C-M-x" [V.MCtrl, V.MMeta] (V.KChar 'x')+                  ]+            )+        , testGroup+            "Pretty-printing"+            [ testProperty+                "(parse . pretty) key round trip"+                prop_parse_pretty_key+            ]+        ]+    ]++instance QC.Arbitrary KeyCombo where+  arbitrary = mkKeyCombo <$> arbitraryModifiers <*> arbitraryKey++arbitraryKey :: QC.Gen V.Key+arbitraryKey =+  QC.frequency $+    [ (10, V.KChar <$> QC.arbitrary)+    , (3, V.KFun . QC.getPositive <$> QC.arbitrary)+    ]+      ++ map ((1,) . pure . read . ('K' :) . from @Text) (S.toList specialKeyNames)++arbitraryModifiers :: QC.Gen [V.Modifier]+arbitraryModifiers = QC.sublistOf [V.MAlt, V.MCtrl, V.MMeta, V.MShift]++prop_parse_pretty_key :: KeyCombo -> Bool+prop_parse_pretty_key kc =+  runParser parseKeyCombo (prettyKeyCombo kc) == Right kc
test/unit/TestEval.hs view
@@ -1,11 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} --- | Swarm unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm unit tests module TestEval where  import Control.Lens ((^.), _3) import Data.Char (ord)+import Data.Map qualified as M import Data.Text (Text) import Data.Text qualified as T import Swarm.Game.State@@ -259,6 +263,46 @@             ( \(NonNegative i) ->                 T.concat ["charAt 0 (toChar ", from @String (show i), ")"]                   `evaluatesToP` VInt i+            )+        ]+    , testGroup+        "records - #1093"+        [ testCase+            "empty record"+            ("[]" `evaluatesTo` VRcd M.empty)+        , testCase+            "singleton record"+            ("[y = 3 + 4]" `evaluatesTo` VRcd (M.singleton "y" (VInt 7)))+        , testCase+            "record equality up to reordering"+            ("[x = 2, y = 3] == [y = 3, x = 2]" `evaluatesTo` VBool True)+        , testCase+            "record projection"+            ("[x = 2, y = 3].x" `evaluatesTo` VInt 2)+        , testCase+            "nested record projection"+            ("let r = [x=2, y=3] in let z = [q = r, n=\"hi\"] in z.q.y" `evaluatesTo` VInt 3)+        , testCase+            "record punning"+            ( "let x = 2 in let y = 3 in [x,y,z=\"hi\"]"+                `evaluatesTo` VRcd (M.fromList [("x", VInt 2), ("y", VInt 3), ("z", VText "hi")])+            )+        , testCase+            "record comparison"+            ("[y=1, x=2] < [x=3,y=0]" `evaluatesTo` VBool True)+        , testCase+            "record comparison"+            ("[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)+        , testCase+            "format record"+            ("format [y = 2, x = 1+2]" `evaluatesTo` VText "[x = 3, y = 2]")+        , testCase+            "record fields don't scope over other fields"+            ( "let x = 1 in [x = x + 1, y = x]"+                `evaluatesTo` VRcd (M.fromList [("x", VInt 2), ("y", VInt 1)])             )         ]     ]
test/unit/TestInventory.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} --- | Swarm unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm unit tests module TestInventory where  import Control.Lens ((^.))@@ -106,6 +109,6 @@         )     ]  where-  x = E.mkEntity (defaultEntityDisplay 'X') "fooX" [] [] []-  y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" [] [] []-  z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" [] [] []+  x = E.mkEntity (defaultEntityDisplay 'X') "fooX" mempty [] []+  y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" mempty [] []+  z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" mempty [] []
test/unit/TestLSP.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} --- | LSP unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- LSP unit tests module TestLSP (testLSP) where  import Data.Text (Text)@@ -25,26 +28,26 @@ testLSP =   testGroup     "Unused variable warnings"-    [ testCase "outer lambda" $-        checkFile "multiple-lambda-first-unused.sw" $-          pure $-            UnusedVar "x" VU.Lambda-    , testCase "inner lambda" $-        checkFile "multiple-lambda-second-unused.sw" $-          pure $-            UnusedVar "y" VU.Lambda-    , testCase "shadowed variable name" $-        checkFile "shadowed-variable-lambda-unused.sw" $-          pure $-            UnusedVar "x" VU.Lambda-    , testCase "outer let" $-        checkFile "multiple-let-first-unused.sw" $-          pure $-            UnusedVar "x" VU.Let-    , testCase "outer let" $-        checkFile "multiple-let-second-unused.sw" $-          pure $-            UnusedVar "y" VU.Let+    [ testCase "outer lambda"+        . checkFile "multiple-lambda-first-unused.sw"+        . pure+        $ UnusedVar "x" VU.Lambda+    , testCase "inner lambda"+        . checkFile "multiple-lambda-second-unused.sw"+        . pure+        $ UnusedVar "y" VU.Lambda+    , testCase "shadowed variable name"+        . checkFile "shadowed-variable-lambda-unused.sw"+        . pure+        $ UnusedVar "x" VU.Lambda+    , testCase "outer let"+        . checkFile "multiple-let-first-unused.sw"+        . pure+        $ UnusedVar "x" VU.Let+    , testCase "outer let"+        . checkFile "multiple-let-second-unused.sw"+        . pure+        $ UnusedVar "y" VU.Let     , testCase "multiple unused let" $         checkFile           "multiple-let-all-unused.sw"
test/unit/TestLanguagePipeline.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-} --- | Swarm unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm unit tests module TestLanguagePipeline where  import Control.Arrow ((&&&))@@ -92,19 +94,19 @@             "located type error"             ( process                 "def a =\n 42 + \"oops\"\nend"-                "2: Can't unify int and 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: Can't unify int and cmd"+                "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: Can't unify {u0} and 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"@@ -178,49 +180,49 @@             "atomic move+move"             ( process                 "atomic (move; move)"-                "1: Invalid atomic block: block could take too many ticks (2): move; move"+                "1:8: Invalid atomic block: block could take too many ticks (2): move; move"             )         , testCase             "atomic lambda"             ( process                 "atomic ((\\c. c;c) move)"-                "1: Invalid atomic block: def, let, and lambda are not allowed: \\c. c; c"+                "1:9: Invalid atomic block: def, let, and lambda are not allowed: \\c. c; c"             )         , testCase             "atomic non-simple"             ( process                 "def dup = \\c. c; c end; atomic (dup (dup move))"-                "1: Invalid atomic block: reference to variable with non-simple type ∀ a3. cmd a3 -> cmd a3: dup"+                "1:33: Invalid atomic block: reference to variable with non-simple type ∀ a. cmd a -> cmd a: dup"             )         , testCase             "atomic nested"             ( process                 "atomic (move; atomic (if true {} {}))"-                "1: Invalid atomic block: nested atomic block"+                "1:15: Invalid atomic block: nested atomic block"             )         , testCase             "atomic wait"             ( process                 "atomic (wait 1)"-                "1: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: wait"+                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: wait"             )         , testCase             "atomic make"             ( process                 "atomic (make \"PhD thesis\")"-                "1: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: make"+                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: make"             )         , testCase             "atomic drill"             ( process                 "atomic (drill forward)"-                "1: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: drill"+                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: drill"             )         , testCase             "atomic salvage"             ( process                 "atomic (salvage)"-                "1: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: salvage"+                "1:8: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: salvage"             )         ]     , testGroup@@ -247,14 +249,41 @@     , testGroup         "void type"         [ testCase-            "void - isSimpleUType"+            "isSimpleUType"             ( assertBool "" $ isSimpleUType UTyVoid             )         , testCase-            "void - valid type signature"+            "valid type signature"             (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])")+        , testCase+            "infer record type"+            (valid "[x = 3, y = \"hi\"]")+        , testCase+            "field mismatch - missing"+            ( process+                "(\\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]"+                "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]"+                "1:26: Field mismatch; record literal has:\n  - Extra field(s) `z`\n  - Missing field(s) `y`"+            )+        ]+    , testGroup         "type annotations"         [ testCase             "annotate 1 + 1"@@ -275,10 +304,81 @@                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")+        , 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`")+        , 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`")+        , testCase+            "type specialization through type ascription"+            (valid "fst:(int + b) * a -> int + b")+        , testCase+            "type ascription doesn't allow rank 2 types"+            ( process+                "\\f. (f:forall a. a->a) 3"+                "1:5: Skolem variable s3 would escape its scope"+            )+        , 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`"+            )+        ]+    , 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"+            )+        , 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"+            )+        , 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`"+            )+        , 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"+            )+        , 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"+            )+        , 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"+            )+        , testCase+            "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"             )         ]     ]
test/unit/TestModel.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} --- | Swarm unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm unit tests module TestModel where  import Data.String (fromString)
test/unit/TestNotification.hs view
@@ -1,11 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} --- | Swarm unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm unit tests module TestNotification where  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.State import Test.Tasty@@ -31,14 +35,14 @@         assertNew gs' 2 "messages" messageNotifications     , testCase "one new message and one old message" $ do         gs' <- goodPlay "say \"Hello!\"; say \"Goodbye!\""-        assertEqual "There should be two messages in queue" [0, 1] (view leTime <$> gs' ^. messageNotifications . notificationsContent)-        assertNew (gs' & lastSeenMessageTime .~ 0) 1 "message" messageNotifications+        assertEqual "There should be two messages in queue" [TickNumber 0, TickNumber 1] (view leTime <$> gs' ^. messageNotifications . notificationsContent)+        assertNew (gs' & 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)         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" [2] (view leTime <$> gs' ^. messageNotifications . notificationsContent)+        assertEqual "There should be one log notification" [TickNumber 2] (view leTime <$> gs' ^. messageNotifications . notificationsContent)         assertNew gs' 1 "message" messageNotifications     , testCase "new message after build say" $ do         gs' <- goodPlay "build {say \"Hello world!\"}; turn back; turn back;"
+ test/unit/TestPedagogy.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm pedagogical tests+module TestPedagogy where++import Control.Lens (view)+import Data.Map qualified as M+import Swarm.Doc.Pedagogy+import Swarm.Game.ScenarioInfo (scenarioPath)+import Swarm.TUI.Model (RuntimeState, scenarios)+import Test.Tasty+import Test.Tasty.HUnit++testPedagogy :: RuntimeState -> TestTree+testPedagogy rs =+  testGroup+    "Pedagogical soundness"+    [ testGroup+        "Introduce new commands in the description"+        testList+    ]+ where+  tutorialInfos = generateIntroductionsSequence $ view scenarios rs++  testFromTut :: Int -> CoverageInfo -> TestTree+  testFromTut idx (CoverageInfo (TutorialInfo (_s, si) _ _ descCommands) novelCommands) =+    testCase+      (unwords [show idx, scPath])+      $ assertBool errMsg allCommandsCovered+   where+    missingCmds = M.withoutKeys novelCommands descCommands+    errMsg =+      unwords+        [ "command(s) missing from description:"+        , show $ M.keysSet missingCmds+        ]++    scPath = view scenarioPath si+    allCommandsCovered = M.null missingCmds++  testList = zipWith testFromTut [0 ..] tutorialInfos
test/unit/TestPretty.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} --- | Swarm unit tests+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Swarm unit tests module TestPretty where  import Swarm.Language.Pretty@@ -41,17 +44,17 @@         )     , testCase         "operators #8 - unary negation with strongly fixing binary operator"-        ( equalPretty "-1 ^ (-2)" $-            TApp (TConst Neg) $-              mkOp' Exp (TInt 1) $-                TApp (TConst Neg) (TInt 2)+        ( equalPretty "-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)" $-            TApp (TConst Neg) $-              mkOp' Add (TInt 1) $-                TApp (TConst Neg) (TInt 2)+        ( equalPretty "-(1 + -2)"+            . TApp (TConst Neg)+            . mkOp' Add (TInt 1)+            $ TApp (TConst Neg) (TInt 2)         )     , testCase         "operators #8 - simple infix operator"@@ -86,6 +89,11 @@     , testCase         "void type"         ( assertEqual "" "void" . show $ ppr TyVoid+        )+    , testCase+        "type ascription"+        ( equalPretty "1 : int" $+            TAnnotate (TInt 1) (Forall [] TyInt)         )     ]  where
+ test/unit/TestScoring.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}++-- | High score records+module TestScoring where++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.Language.Pipeline+import Swarm.Language.Syntax+import System.FilePath ((</>))+import Test.Tasty+import Test.Tasty.HUnit+import Witch (into)++baseTestPath :: FilePath+baseTestPath = "data/test/language-snippets/code-size"++testHighScores :: TestTree+testHighScores =+  testGroup+    "Scoring"+    [ testGroup+        "Code size"+        [ compareAstSize 1 "single-move-bare.sw"+        , 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"+        ]+    , testGroup+        "Precedence"+        [ testGroup+            "Single metrics"+            [ testCase+                "Attempted long > Attempted short"+                $ assertEqual "Longer is better for incomplete games" (Metric Attempted (5 :: Int))+                $ chooseBetter pure (Metric Attempted 3) (Metric Attempted 5)+            , testCase+                "Completed short > Completed long"+                $ assertEqual "Shorter is better for completed games" (Metric Completed (3 :: Int))+                $ chooseBetter pure (Metric Completed 3) (Metric Completed 5)+            ]+        , testGroup+            "Grouped metrics"+            [ betterReplTimeAfterCodeSizeRecord+            , betterCodeWorseTime+            ]+        ]+    ]++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+    Right x -> return x+    Left y -> assertFailure (into @String y)+  let actualSize = measureAstSize stx+  assertEqual "incorrect size" expectedSize actualSize++betterReplTimeAfterCodeSizeRecord :: TestTree+betterReplTimeAfterCodeSizeRecord =+  testCase+    "new repl win after code size record"+    $ assertEqual "incorrect" newExpectedBest newActualBest+ where+  mkZonedTime t = ZonedTime (LocalTime (fromOrdinalDate 2023 1) (TimeOfDay 0 t 0)) utc+  newRunWithoutCodeSize =+    Metric Completed $+      ProgressStats (mkZonedTime 1) $+        AttemptMetrics+          (DurationMetrics 1 $ TickNumber 1)+          Nothing++  oldCompletedRunWithCodeSize =+    Metric Completed $+      ProgressStats (mkZonedTime 0) $+        AttemptMetrics+          (DurationMetrics 2 $ TickNumber 2)+          (Just $ ScenarioCodeMetrics 1 1)++  oldBestWithCodeSize =+    BestRecords+      oldCompletedRunWithCodeSize+      oldCompletedRunWithCodeSize+      oldCompletedRunWithCodeSize+      oldCompletedRunWithCodeSize++  newExpectedBest =+    BestRecords+      newRunWithoutCodeSize+      newRunWithoutCodeSize+      oldCompletedRunWithCodeSize+      oldCompletedRunWithCodeSize++  newActualBest =+    updateBest+      newRunWithoutCodeSize+      oldBestWithCodeSize++betterCodeWorseTime :: TestTree+betterCodeWorseTime =+  testCase+    "improvement upon code size with a worse time"+    $ assertEqual "incorrect" newExpectedBests newActualBests+ where+  mkZonedTime t = ZonedTime (LocalTime (fromOrdinalDate 2023 1) (TimeOfDay 0 t 0)) utc+  newRunBetterCodeSize =+    Metric Completed $+      ProgressStats (mkZonedTime 1) $+        AttemptMetrics+          (DurationMetrics 2 $ TickNumber 2)+          (Just $ ScenarioCodeMetrics 1 1)++  oldRunPoorCodeSize =+    Metric Completed $+      ProgressStats (mkZonedTime 0) $+        AttemptMetrics+          (DurationMetrics 1 $ TickNumber 1)+          (Just $ ScenarioCodeMetrics 2 2)++  oldBests =+    BestRecords+      oldRunPoorCodeSize+      oldRunPoorCodeSize+      oldRunPoorCodeSize+      oldRunPoorCodeSize++  newExpectedBests =+    BestRecords+      oldRunPoorCodeSize+      oldRunPoorCodeSize+      newRunBetterCodeSize+      newRunBetterCodeSize++  newActualBests =+    updateBest+      newRunBetterCodeSize+      oldBests
test/unit/TestUtil.hs view
@@ -1,12 +1,16 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} --- | Utility functions+-- |+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Utility functions module TestUtil where  import Control.Lens (Ixed (ix), to, use, (&), (.~), (^.), (^?))-import Control.Monad.Except-import Control.Monad.State+import Control.Monad (void)+import Control.Monad.State (StateT (..), execState)+import Control.Monad.Trans (lift) import Data.Text (Text) import Data.Text qualified as T import Swarm.Game.CESK@@ -64,7 +68,7 @@   w <- use robotMap   case w ^? ix rid . to isActive of     Just True -> do-      gameTick+      void gameTick       playUntilDone rid     Just False -> return $ Right ()     Nothing -> return $ Left . T.pack $ "The robot with ID " <> show rid <> " is nowhere to be found!"